packages feed

hackport 0.2.13 → 0.2.14

raw patch · 372 files changed

+49868/−13504 lines, 372 filesdep +unixdep −Cabal

Dependencies added: unix

Dependencies removed: Cabal

Files

+ .gitignore view
@@ -0,0 +1,1 @@+dist/
Cabal2Ebuild.hs view
@@ -48,12 +48,14 @@     E.version     = display (Cabal.pkgVersion (Cabal.package pkg)),     E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg                                                else Cabal.synopsis pkg,+    E.long_desc       = if null (Cabal.description pkg) then Cabal.synopsis pkg+                                               else Cabal.description pkg,     E.homepage        = thisHomepage,     E.license         = Cabal.license pkg,     E.my_pn           = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,     E.features        = E.features E.ebuildTemplate                    ++ (if hasExe then ["bin"] else [])-                   ++ maybe [] (const (["lib","profile","haddock"]+                   ++ maybe [] (const (["lib","profile","haddock","hoogle"]                         ++ if cabalPkgName == "hscolour" then [] else ["hscolour"])                         ) (Cabal.library pkg) -- hscolour can't colour its own sources   } where@@ -117,7 +119,7 @@   ,"random"   ,"readline"     --has ebuild, but only in the overlay   ,"rts"-  ,"syb"          -- intentionally no ebuild. use ghc's version+  -- ,"syb"       -- was splitted off from ghc again   ,"template-haskell"   ,"unix"         --has ebuild, but only in the overlay   ]
Diff.hs view
@@ -23,7 +23,7 @@ import Distribution.Simple.Utils (equating)  -- cabal-install-import qualified Distribution.Client.IndexUtils as Index (getAvailablePackages )+import qualified Distribution.Client.IndexUtils as Index (getSourcePackages) import qualified Distribution.Client.Types as Cabal import Distribution.Client.Utils (mergeBy, MergeResult(..)) @@ -61,8 +61,8 @@ runDiff :: Verbosity -> FilePath -> DiffMode -> Cabal.Repo -> IO () runDiff verbosity overlayPath dm repo = do   -- get package list from hackage-  pkgDB <- Index.getAvailablePackages verbosity [ repo ]-  let (Cabal.AvailablePackageDb hackageIndex _) = pkgDB+  pkgDB <- Index.getSourcePackages verbosity [ repo ]+  let (Cabal.SourcePackageDb hackageIndex _) = pkgDB    -- get package list from the overlay   overlay0 <- (Portage.loadLazy overlayPath)@@ -71,8 +71,8 @@   let (subHackage, subOverlay)         = case dm of             ShowPackages pkgs ->-              (concatMap (Index.searchByNameSubstring hackageIndex) pkgs-              ,concatMap (Index.searchByNameSubstring overlayIndex) pkgs)+              (concatMap (concatMap snd . Index.searchByNameSubstring hackageIndex) pkgs+              ,concatMap (concatMap snd . Index.searchByNameSubstring overlayIndex) pkgs)             _ ->               (Index.allPackages hackageIndex               ,Index.allPackages overlayIndex)@@ -100,7 +100,7 @@           GT -> ">"           LT -> "<" -diff :: [Cabal.AvailablePackage]+diff :: [Cabal.SourcePackage]      -> [Portage.ExistingEbuild]      -> DiffMode      -> IO ()
DistroMap.hs view
@@ -46,7 +46,7 @@  import Distribution.Verbosity import Distribution.Text ( display )-import Distribution.Client.Types ( Repo, AvailablePackageDb(..), AvailablePackage(..) )+import Distribution.Client.Types ( Repo, SourcePackageDb(..), SourcePackage(..) ) import Distribution.Simple.Utils ( info )  import qualified Data.Version as Cabal@@ -83,8 +83,8 @@   info verbosity ("overlay map: " ++ show (Map.size overlayMap))   info verbosity ("complete map: " ++ show (Map.size completeMap)) -  AvailablePackageDb { packageIndex = packageIndex } <--    CabalInstall.getAvailablePackages verbosity [repo]+  SourcePackageDb { packageIndex = packageIndex } <-+    CabalInstall.getSourcePackages verbosity [repo]    let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex)       hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ]
Error.hs view
@@ -55,7 +55,7 @@ 	CabalParseFailed file reason -> "Error while parsing cabal file '"++file++"': "++reason 	BashNotFound -> "The 'bash' executable was not found. It is required to figure out your portage-overlay. If you don't want to install bash, use '-p path-to-overlay'" 	BashError str -> "Error while guessing your portage-overlay. Either set PORTDIR_OVERLAY in /etc/make.conf or use '-p path-to-overlay'.\nThe error was: \""++str++"\""-	MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using '-p path-to-overlay'"+	MultipleOverlays overlays -> "You have the following overlays available: '"++unwords overlays++"'. Please choose one by using 'hackport -p path-to-overlay' <command>" 	NoOverlay -> "You don't have PORTDIR_OVERLAY set in '/etc/make.conf'. Please set it or use '-p path-to-overlay'" 	UnknownVerbosityLevel str -> "The verbosity level '"++str++"' is invalid. Please use debug,normal or silent"         InvalidServer srv -> "Invalid server address, could not parse: " ++ srv
Main.hs view
@@ -102,10 +102,10 @@   let verbosity = fromFlag (listVerbosity flags)   overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)   let repo = defaultRepo overlayPath-  index <- fmap packageIndex (Index.getAvailablePackages verbosity [ repo ])+  index <- fmap packageIndex (Index.getSourcePackages verbosity [ repo ])   overlay <- Overlay.loadLazy overlayPath   let pkgs | null extraArgs = Index.allPackages index-           | otherwise = concatMap (Index.searchByNameSubstring index) extraArgs+           | otherwise = concatMap (concatMap snd . Index.searchByNameSubstring index) extraArgs       normalized = map (normalizeCabalPackageId . packageInfoId) pkgs   let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized   mapM_ (putStrLn . pretty) decorated
Merge.hs view
@@ -21,6 +21,7 @@ import System.Directory ( getCurrentDirectory                         , setCurrentDirectory                         , createDirectoryIfMissing+                        , doesFileExist                         ) import System.Cmd (system) import System.FilePath ((</>))@@ -38,7 +39,7 @@  import Network.URI -import Distribution.Client.IndexUtils ( getAvailablePackages )+import Distribution.Client.IndexUtils ( getSourcePackages ) import Distribution.Client.HttpUtils ( downloadURI ) import qualified Distribution.Client.PackageIndex as Index import Distribution.Client.Types@@ -46,6 +47,7 @@ import qualified Portage.PackageId as Portage import qualified Portage.Version as Portage import qualified Portage.Host as Host+import qualified Portage.Metadata as Portage import qualified Portage.Overlay as Overlay import qualified Portage.Resolve as Portage @@ -92,7 +94,7 @@ -- | Given a list of available packages, and maybe a preferred version, -- return the available package with that version. Latest version is chosen -- if no preference.-resolveVersion :: [AvailablePackage] -> Maybe Cabal.Version -> Maybe AvailablePackage+resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails resolveVersion avails (Just ver) = listToMaybe (filter match avails)   where@@ -119,14 +121,14 @@   overlay <- Overlay.loadLazy overlayPath   -- portage_path <- Host.portage_dir `fmap` Host.getInfo   -- portage <- Overlay.loadLazy portage_path-  index <- fmap packageIndex $ getAvailablePackages verbosity [ repo ]+  index <- fmap packageIndex $ getSourcePackages verbosity [ repo ]    -- find all packages that maches the user specified package name   availablePkgs <--    case Index.searchByName index user_pname_str of-      Index.None -> throwEx (PackageNotFound user_pname_str)-      Index.Ambiguous pkgs -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs)))-      Index.Unambiguous pkg -> return pkg+    case map snd (Index.searchByName index user_pname_str) of+      [] -> throwEx (PackageNotFound user_pname_str)+      [pkg] -> return pkg+      pkgs  -> throwEx (ArgumentError ("Ambiguous name: " ++ unwords (map show pkgs)))    -- select a single package taking into account the user specified version   selectedPkg <-@@ -235,6 +237,17 @@   let edir = target </> cat </> E.name ebuild       elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"       epath = edir </> elocal+      emeta = "metadata.xml"+      mpath = edir </> emeta+      default_meta = Portage.makeDefaultMetadata (E.long_desc ebuild)   createDirectoryIfMissing True edir-  info verbosity $ "Writing " ++ elocal+  notice verbosity $ "Writing " ++ elocal   writeFile epath (display ebuild)++  yet_meta <- doesFileExist mpath+  if (not yet_meta) -- TODO: add --force-meta-rewrite to opts+      then do notice verbosity $ "Writing " ++ emeta+              writeFile mpath default_meta+      else do current_meta <- readFile mpath+              when (current_meta /= default_meta) $+                  notice verbosity $ "Default and current " ++ emeta ++ " differ."
− Portage.hs 
@@ -1,20 +0,0 @@-module Portage where--import System.Directory-import Text.Regex-import Data.Maybe--ebuildVersionRegex :: String -> Regex-ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$")--filterPackages :: String -> [String] -> IO [String]-filterPackages _ [] = return []-filterPackages base (x:xs) = do-    ak <- case x of-        "." -> return Nothing-        ".." -> return Nothing-        dir -> do-            exists <- doesDirectoryExist (base++dir)-            return (if exists then Just dir else Nothing)-    rest <- filterPackages base xs-    return (maybe rest (:rest) ak)
Portage/EBuild.hs view
@@ -19,6 +19,7 @@     version :: String,     hackportVersion :: String,     description :: String,+    long_desc :: String,     homepage :: String,     license :: Cabal.License,     slot :: String,@@ -42,6 +43,7 @@     version = "0.1",     hackportVersion = getHackportVersion Paths_hackport.version,     description = "",+    long_desc = "",     homepage = "http://hackage.haskell.org/package/${PN}",     license = Cabal.UnknownLicense "xxx UNKNOWN xxx",     slot = "0",
Portage/GHCCore.hs view
@@ -21,8 +21,6 @@ import Data.Maybe import Data.List ( nub ) -import Text.PrettyPrint.HughesPJ- defaultGHC :: (CompilerId, [PackageName]) defaultGHC = let (g,pix) = ghc6123 in (g, packageNamesFromPackageIndex pix)
Portage/Host.hs view
@@ -4,7 +4,6 @@   ) where  import Util (run_cmd)-import Data.Char (isSpace) import Data.Maybe (fromJust, isJust, catMaybes) import Control.Applicative ( (<$>) )
Portage/Metadata.hs view
@@ -1,6 +1,7 @@ module Portage.Metadata         ( Metadata(..)         , metadataFromFile+        , makeDefaultMetadata         ) where  import qualified Data.ByteString as B@@ -9,8 +10,6 @@  import Text.XML.Light -import Control.Monad- data Metadata = Metadata       { metadataHerds :: [String]       -- , metadataMaintainers :: [String],@@ -29,3 +28,28 @@             {               metadataHerds = herds             }++-- don't use Text.XML.Light as we like our own pretty printer+makeDefaultMetadata :: String -> String+makeDefaultMetadata long_description =+    unlines [ "<?xml version=\"1.0\" encoding=\"UTF-8\"?>"+            , "<!DOCTYPE pkgmetadata SYSTEM \"http://www.gentoo.org/dtd/metadata.dtd\">"+            , "<pkgmetadata>"+            , "\t<herd>haskell</herd>"+            , "\t<maintainer>"+            , "\t\t<email>haskell@gentoo.org</email>"+            , "\t</maintainer>"+            , (init {- strip trailing newline-}+              . unlines+              . map (\l -> if l `elem` ["<longdescription>", "</longdescription>"]+                               then "\t"   ++ l -- leading/trailing lines+                               else "\t\t" ++ l -- description itself+                    )+              . lines+              . showElement+              . unode "longdescription"+              . ("\n" ++) -- prepend newline to separate form <longdescription>+              . (++ "\n") -- append newline+              ) long_description+            , "</pkgmetadata>"+            ]
README.rst view
@@ -11,13 +11,35 @@ Ebuilds from Cabal packages. It also does handy functions to compare hackage, the overlay and the portage tree. +Quick start+-----------++1. Build hackport binary by hand (or install it from haskell overlay).+2. Setup hackport database into overlay you plan to merge new ebuilds:++::++    $ mkdir ~/overlays+    $ cd ~/overlays+    $ git clone git clone git://github.com/gentoo-haskell/gentoo-haskell.git+    $ cd gentoo-haskell+    $ hackport update+    $ ls -1 .hackport/+        00-index.tar+        00-index.tar.gz++3. Add your ~/overlays/gentoo-haskell to PORTDIR_OVERLAY in /etc/make.conf.++Done! Now you can `hackport merge <package-name>` to get an ebuild merged to+your overlay!+ Features --------      'hackport update'         Update the local copy of hackage's package list. You should run this         every once in a while to get a more recent copy.-    +     'hackport list [FILTER]'         Print packages from hackage, with an optional substring matching. @@ -99,7 +121,7 @@                     - the ebuilds differ, or                     - the overlay has a more recent version -    'hackport make-ebuild <path/to/package.ebuild>'+    'hackport make-ebuild <path/to/package.cabal>'         Generates standalone .ebuild file from .cabal spec and stores result in same         directory.         Option is useful for packages not-on-hackage and for debug purposes.
TODO view
@@ -9,13 +9,13 @@     still are any missing. set good default values, and make sure we don't     get any 'fromFlag' errors due to missing defaults for all commands -* catch baseconstraints and upgrade ghc requirement+* catch base constraints and upgrade ghc requirement       (like in vty-4.0.0.1: base >= 4 leads to ghc >= 6.10)  Harder ====== -* translate the dev-db/libpq dependency into virtual/postgresql-base+* translate the dev-db/libpq dependency into dev-db/postgresql-base     the cabal field to describe c libs should be translated if we know the     proper gentoo package name. @@ -33,3 +33,7 @@ * Merge the separate tool keyword-stat into hackport, and make it use the     hackport API.     See http://code.haskell.org/gentoo/keyword-stat/++* Pick keywords from latest available ebuild++* hacport status --to-portage should warn about different 'ChangeLog' and 'metadata.xml' files
− cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Anonymous.hs 
@@ -1,311 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Reporting--- Copyright   :  (c) David Waern 2008--- License     :  BSD-like------ Maintainer  :  david.waern@gmail.com--- Stability   :  experimental--- Portability :  portable------ Anonymous build report data structure, printing and parsing----------------------------------------------------------------------------------module Distribution.Client.BuildReports.Anonymous (-    BuildReport(..),-    InstallOutcome(..),-    Outcome(..),--    -- * Constructing and writing reports-    new,--    -- * parsing and pretty printing-    parse,-    parseList,-    show,---    showList,-  ) where--import Distribution.Client.Types-         ( ConfiguredPackage(..) )-import qualified Distribution.Client.Types as BR-         ( BuildResult, BuildFailure(..), BuildSuccess(..)-         , DocsResult(..), TestsResult(..) )-import Distribution.Client.Utils-         ( mergeBy, MergeResult(..) )-import qualified Paths_cabal_install (version)--import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(packageId) )-import Distribution.PackageDescription-         ( FlagName(..), FlagAssignment )---import Distribution.Version---         ( Version )-import Distribution.System-         ( OS, Arch )-import Distribution.Compiler-         ( CompilerId )-import qualified Distribution.Text as Text-         ( Text(disp, parse) )-import Distribution.ParseUtils-         ( FieldDescr(..), ParseResult(..), Field(..)-         , simpleField, listField, ppFields, readFields-         , syntaxError, locatedErrorMsg )-import Distribution.Simple.Utils-         ( comparing )--import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, pfail, munch1, skipSpaces )-import qualified Text.PrettyPrint.HughesPJ as Disp-         ( Doc, render, char, text )-import Text.PrettyPrint.HughesPJ-         ( (<+>), (<>) )--import Data.List-         ( unfoldr, sortBy )-import Data.Char as Char-         ( isAlpha, isAlphaNum )--import Prelude hiding (show)--data BuildReport-   = BuildReport {-    -- | The package this build report is about-    package         :: PackageIdentifier,--    -- | The OS and Arch the package was built on-    os              :: OS,-    arch            :: Arch,--    -- | The Haskell compiler (and hopefully version) used-    compiler        :: CompilerId,--    -- | The uploading client, ie cabal-install-x.y.z-    client          :: PackageIdentifier,--    -- | Which configurations flags we used-    flagAssignment  :: FlagAssignment,--    -- | Which dependent packages we were using exactly-    dependencies    :: [PackageIdentifier],--    -- | Did installing work ok?-    installOutcome  :: InstallOutcome,--    --   Which version of the Cabal library was used to compile the Setup.hs---    cabalVersion    :: Version,--    --   Which build tools we were using (with versions)---    tools      :: [PackageIdentifier],--    -- | Configure outcome, did configure work ok?-    docsOutcome     :: Outcome,--    -- | Configure outcome, did configure work ok?-    testsOutcome    :: Outcome-  }--data InstallOutcome-   = DependencyFailed PackageIdentifier-   | DownloadFailed-   | UnpackFailed-   | SetupFailed-   | ConfigureFailed-   | BuildFailed-   | InstallFailed-   | InstallOk-  deriving Eq--data Outcome = NotTried | Failed | Ok-  deriving Eq--new :: OS -> Arch -> CompilerId -- -> Version-    -> ConfiguredPackage -> BR.BuildResult-    -> BuildReport-new os' arch' comp (ConfiguredPackage pkg flags deps) result =-  BuildReport {-    package               = packageId pkg,-    os                    = os',-    arch                  = arch',-    compiler              = comp,-    client                = cabalInstallID,-    flagAssignment        = flags,-    dependencies          = deps,-    installOutcome        = convertInstallOutcome,---    cabalVersion          = undefined-    docsOutcome           = convertDocsOutcome,-    testsOutcome          = convertTestsOutcome-  }-  where-    convertInstallOutcome = case result of-      Left  (BR.DependentFailed p) -> DependencyFailed p-      Left  (BR.DownloadFailed  _) -> DownloadFailed-      Left  (BR.UnpackFailed    _) -> UnpackFailed-      Left  (BR.ConfigureFailed _) -> ConfigureFailed-      Left  (BR.BuildFailed     _) -> BuildFailed-      Left  (BR.InstallFailed   _) -> InstallFailed-      Right (BR.BuildOk       _ _) -> InstallOk-    convertDocsOutcome = case result of-      Left _                                -> NotTried-      Right (BR.BuildOk BR.DocsNotTried _)  -> NotTried-      Right (BR.BuildOk BR.DocsFailed _)    -> Failed-      Right (BR.BuildOk BR.DocsOk _)        -> Ok-    convertTestsOutcome = case result of-      Left _                                -> NotTried-      Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried-      Right (BR.BuildOk _ BR.TestsFailed)   -> Failed-      Right (BR.BuildOk _ BR.TestsOk)       -> Ok--cabalInstallID :: PackageIdentifier-cabalInstallID =-  PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version---- --------------------------------------------------------------- * External format--- --------------------------------------------------------------initialBuildReport :: BuildReport-initialBuildReport = BuildReport {-    package         = requiredField "package",-    os              = requiredField "os",-    arch            = requiredField "arch",-    compiler        = requiredField "compiler",-    client          = requiredField "client",-    flagAssignment  = [],-    dependencies    = [],-    installOutcome  = requiredField "install-outcome",---    cabalVersion  = Nothing,---    tools         = [],-    docsOutcome     = NotTried,-    testsOutcome    = NotTried-  }-  where-    requiredField fname = error ("required field: " ++ fname)---- -------------------------------------------------------------------------------- Parsing--parse :: String -> Either String BuildReport-parse s = case parseFields s of-  ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror-  ParseOk   _ report -> Right report----FIXME: this does not allow for optional or repeated fields-parseFields :: String -> ParseResult BuildReport-parseFields input = do-  fields <- mapM extractField =<< readFields input-  let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)-                       sortedFieldDescrs-                       (sortBy (comparing (\(_,name,_) -> name)) fields)-  checkMerged initialBuildReport merged--  where-    extractField :: Field -> ParseResult (Int, String, String)-    extractField (F line name value)  = return (line, name, value)-    extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"-    extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"--    checkMerged report [] = return report-    checkMerged report (merged:remaining) = case merged of-      InBoth fieldDescr (line, _name, value) -> do-        report' <- fieldSet fieldDescr line value report-        checkMerged report' remaining-      OnlyInRight (line, name, _) ->-        syntaxError line ("Unrecognized field " ++ name)-      OnlyInLeft  fieldDescr ->-        fail ("Missing field " ++ fieldName fieldDescr)--parseList :: String -> [BuildReport]-parseList str =-  [ report | Right report <- map parse (split str) ]--  where-    split :: String -> [String]-    split = filter (not . null) . unfoldr chunk . lines-    chunk [] = Nothing-    chunk ls = case break null ls of-                 (r, rs) -> Just (unlines r, dropWhile null rs)---- -------------------------------------------------------------------------------- Pretty-printing--show :: BuildReport -> String-show = Disp.render . ppFields fieldDescrs---- -------------------------------------------------------------------------------- Description of the fields, for parsing/printing--fieldDescrs :: [FieldDescr BuildReport]-fieldDescrs =- [ simpleField "package"         Text.disp      Text.parse-                                 package        (\v r -> r { package = v })- , simpleField "os"              Text.disp      Text.parse-                                 os             (\v r -> r { os = v })- , simpleField "arch"            Text.disp      Text.parse-                                 arch           (\v r -> r { arch = v })- , simpleField "compiler"        Text.disp      Text.parse-                                 compiler       (\v r -> r { compiler = v })- , simpleField "client"          Text.disp      Text.parse-                                 client         (\v r -> r { client = v })- , listField   "flags"           dispFlag       parseFlag-                                 flagAssignment (\v r -> r { flagAssignment = v })- , listField   "dependencies"    Text.disp      Text.parse-                                 dependencies   (\v r -> r { dependencies = v })- , simpleField "install-outcome" Text.disp      Text.parse-                                 installOutcome (\v r -> r { installOutcome = v })- , simpleField "docs-outcome"    Text.disp      Text.parse-                                 docsOutcome    (\v r -> r { docsOutcome = v })- , simpleField "tests-outcome"   Text.disp      Text.parse-                                 testsOutcome   (\v r -> r { testsOutcome = v })- ]--sortedFieldDescrs :: [FieldDescr BuildReport]-sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs--dispFlag :: (FlagName, Bool) -> Disp.Doc-dispFlag (FlagName name, True)  =                  Disp.text name-dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name--parseFlag :: Parse.ReadP r (FlagName, Bool)-parseFlag = do-  name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')-  case name of-    ('-':flag) -> return (FlagName flag, False)-    flag       -> return (FlagName flag, True)--instance Text.Text InstallOutcome where-  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid-  disp DownloadFailed  = Disp.text "DownloadFailed"-  disp UnpackFailed    = Disp.text "UnpackFailed"-  disp SetupFailed     = Disp.text "SetupFailed"-  disp ConfigureFailed = Disp.text "ConfigureFailed"-  disp BuildFailed     = Disp.text "BuildFailed"-  disp InstallFailed   = Disp.text "InstallFailed"-  disp InstallOk       = Disp.text "InstallOk"--  parse = do-    name <- Parse.munch1 Char.isAlphaNum-    case name of-      "DependencyFailed" -> do Parse.skipSpaces-                               pkgid <- Text.parse-                               return (DependencyFailed pkgid)-      "DownloadFailed"   -> return DownloadFailed-      "UnpackFailed"     -> return UnpackFailed-      "SetupFailed"      -> return SetupFailed-      "ConfigureFailed"  -> return ConfigureFailed-      "BuildFailed"      -> return BuildFailed-      "InstallFailed"    -> return InstallFailed-      "InstallOk"        -> return InstallOk-      _                  -> Parse.pfail--instance Text.Text Outcome where-  disp NotTried = Disp.text "NotTried"-  disp Failed   = Disp.text "Failed"-  disp Ok       = Disp.text "Ok"-  parse = do-    name <- Parse.munch1 Char.isAlpha-    case name of-      "NotTried" -> return NotTried-      "Failed"   -> return Failed-      "Ok"       -> return Ok-      _          -> Parse.pfail
− cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Storage.hs 
@@ -1,129 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Reporting--- Copyright   :  (c) David Waern 2008--- License     :  BSD-like------ Maintainer  :  david.waern@gmail.com--- Stability   :  experimental--- Portability :  portable------ Anonymous build report data structure, printing and parsing----------------------------------------------------------------------------------module Distribution.Client.BuildReports.Storage (--    -- * Storing and retrieving build reports-    storeAnonymous,-    storeLocal,---    retrieve,--    -- * 'InstallPlan' support-    fromInstallPlan,-  ) where--import qualified Distribution.Client.BuildReports.Anonymous as BuildReport-import Distribution.Client.BuildReports.Anonymous (BuildReport)--import Distribution.Client.Types-         ( ConfiguredPackage(..), AvailablePackage(..)-         , AvailablePackageSource(..), Repo(..), RemoteRepo(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan-         ( InstallPlan )--import Distribution.Simple.InstallDirs-         ( PathTemplate, fromPathTemplate-         , initialPathTemplateEnv, substPathTemplate )-import Distribution.System-         ( Platform(Platform) )-import Distribution.Compiler-         ( CompilerId )-import Distribution.Simple.Utils-         ( comparing, equating )--import Data.List-         ( groupBy, sortBy )-import Data.Maybe-         ( catMaybes )-import System.FilePath-         ( (</>), takeDirectory )-import System.Directory-         ( createDirectoryIfMissing )--storeAnonymous :: [(BuildReport, Repo)] -> IO ()-storeAnonymous reports = sequence_-  [ appendFile file (concatMap format reports')-  | (repo, reports') <- separate reports-  , let file = repoLocalDir repo </> "build-reports.log" ]-  --TODO: make this concurrency safe, either lock the report file or make sure-  -- the writes for each report are atomic (under 4k and flush at boundaries)--  where-    format r = '\n' : BuildReport.show r ++ "\n"-    separate :: [(BuildReport, Repo)]-             -> [(Repo, [BuildReport])]-    separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))-             . map concat-             . groupBy (equating (repoName . head))-             . sortBy (comparing (repoName . head))-             . groupBy (equating repoName)-             . onlyRemote-    repoName (_,_,rrepo) = remoteRepoName rrepo--    onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]-    onlyRemote rs =-      [ (report, repo, remoteRepo)-      | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]--storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()-storeLocal templates reports = sequence_-  [ do createDirectoryIfMissing True (takeDirectory file)-       appendFile file output-       --TODO: make this concurrency safe, either lock the report file or make-       --      sure the writes for each report are atomic-  | (file, reports') <- groupByFileName-                          [ (reportFileName template report, report)-                          | template <- templates-                          , (report, _repo) <- reports ]-  , let output = concatMap format reports'-  ]-  where-    format r = '\n' : BuildReport.show r ++ "\n"--    reportFileName template report =-        fromPathTemplate (substPathTemplate env template)-      where env = initialPathTemplateEnv-                    (BuildReport.package  report)-                    (BuildReport.compiler report)--    groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))-                    . groupBy (equating  fst)-                    . sortBy  (comparing fst)---- --------------------------------------------------------------- * InstallPlan support--- --------------------------------------------------------------fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]-fromInstallPlan plan = catMaybes-                     . map (fromPlanPackage platform comp)-                     . InstallPlan.toList-                     $ plan-  where platform = InstallPlan.planPlatform plan-        comp     = InstallPlan.planCompiler plan--fromPlanPackage :: Platform -> CompilerId-                -> InstallPlan.PlanPackage-                -> Maybe (BuildReport, Repo)-fromPlanPackage (Platform arch os) comp planPackage = case planPackage of--  InstallPlan.Installed pkg@(ConfiguredPackage (AvailablePackage {-                          packageSource = RepoTarballPackage repo }) _ _) result-    -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)--  InstallPlan.Failed pkg@(ConfiguredPackage (AvailablePackage {-                       packageSource = RepoTarballPackage repo }) _ _) result-    -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)--  _ -> Nothing
− cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Types.hs 
@@ -1,44 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.BuildReports.Types--- Copyright   :  (c) Duncan Coutts 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Types related to build reporting----------------------------------------------------------------------------------module Distribution.Client.BuildReports.Types (-    ReportLevel(..),-  ) where--import qualified Distribution.Text as Text-         ( Text(..) )--import qualified Distribution.Compat.ReadP as Parse-         ( pfail, munch1 )-import qualified Text.PrettyPrint.HughesPJ as Disp-         ( text )--import Data.Char as Char-         ( isAlpha, toLower )--data ReportLevel = NoReports | AnonymousReports | DetailedReports-  deriving (Eq, Ord, Show)--instance Text.Text ReportLevel where-  disp NoReports        = Disp.text "none"-  disp AnonymousReports = Disp.text "anonymous"-  disp DetailedReports  = Disp.text "detailed"-  parse = do-    name <- Parse.munch1 Char.isAlpha-    case lowercase name of-      "none"       -> return NoReports-      "anonymous"  -> return AnonymousReports-      "detailed"   -> return DetailedReports-      _            -> Parse.pfail--lowercase :: String -> String-lowercase = map Char.toLower
− cabal-install-0.9.5_rc20101226/Distribution/Client/BuildReports/Upload.hs 
@@ -1,71 +0,0 @@-{-# LANGUAGE PatternGuards #-}--- This is a quick hack for uploading build reports to Hackage.--module Distribution.Client.BuildReports.Upload-    ( BuildLog-    , BuildReportId-    , uploadReports-    , postBuildReport-    , putBuildLog-    ) where--import Network.Browser-         ( BrowserAction, request, setAllowRedirects )-import Network.HTTP-         ( Header(..), HeaderName(..)-         , Request(..), RequestMethod(..), Response(..) )-import Network.TCP (HandleStream)-import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)--import Control.Monad-         ( forM_ )-import System.FilePath.Posix-         ( (</>) )-import qualified Distribution.Client.BuildReports.Anonymous as BuildReport-import Distribution.Client.BuildReports.Anonymous (BuildReport)--type BuildReportId = URI-type BuildLog = String--uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]-              ->  BrowserAction (HandleStream BuildLog) ()-uploadReports uri reports-    = forM_ reports $ \(report, mbBuildLog) ->-      do buildId <- postBuildReport uri report-         case mbBuildLog of-           Just buildLog -> putBuildLog buildId buildLog-           Nothing       -> return ()--postBuildReport :: URI -> BuildReport-                -> BrowserAction (HandleStream BuildLog) BuildReportId-postBuildReport uri buildReport = do-  setAllowRedirects False-  (_, response) <- request Request {-    rqURI     = uri { uriPath = "/buildreports" },-    rqMethod  = POST,-    rqHeaders = [Header HdrContentType   ("text/plain"),-                 Header HdrContentLength (show (length body)),-                 Header HdrAccept        ("text/plain")],-    rqBody    = body-  }-  case rspCode response of-    (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location-                                     relativeTo rel uri-                                  | Header HdrLocation location <- rspHeaders response ]-              -> return $ buildId-    _         -> error "Unrecognised response from server."-  where body  = BuildReport.show buildReport--putBuildLog :: BuildReportId -> BuildLog-            -> BrowserAction (HandleStream BuildLog) ()-putBuildLog reportId buildLog = do-  --FIXME: do something if the request fails-  (_, response) <- request Request {-      rqURI     = reportId{uriPath = uriPath reportId </> "buildlog"},-      rqMethod  = PUT,-      rqHeaders = [Header HdrContentType   ("text/plain"),-                   Header HdrContentLength (show (length buildLog)),-                   Header HdrAccept        ("text/plain")],-      rqBody    = buildLog-    }-  return ()
− cabal-install-0.9.5_rc20101226/Distribution/Client/Check.hs 
@@ -1,85 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Check--- Copyright   :  (c) Lennart Kolmodin 2008--- License     :  BSD-like------ Maintainer  :  kolmodin@haskell.org--- Stability   :  provisional--- Portability :  portable------ Check a package for common mistakes----------------------------------------------------------------------------------module Distribution.Client.Check (-    check-  ) where--import Control.Monad ( when, unless )--import Distribution.PackageDescription.Parse-         ( readPackageDescription )-import Distribution.PackageDescription.Check-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription )-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Simple.Utils-         ( defaultPackageDesc, toUTF8, wrapText )--check :: Verbosity -> IO Bool-check verbosity = do-    pdfile <- defaultPackageDesc verbosity-    ppd <- readPackageDescription verbosity pdfile-    -- flatten the generic package description into a regular package-    -- description-    -- TODO: this may give more warnings than it should give;-    --       consider two branches of a condition, one saying-    --          ghc-options: -Wall-    --       and the other-    --          ghc-options: -Werror-    --      joined into-    --          ghc-options: -Wall -Werror-    --      checkPackages will yield a warning on the last line, but it-    --      would not on each individual branch.-    --      Hovever, this is the same way hackage does it, so we will yield-    --      the exact same errors as it will.-    let pkg_desc = flattenPackageDescription ppd-    ioChecks <- checkPackageFiles pkg_desc "."-    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)-        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]-        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]-        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]-        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]--    unless (null buildImpossible) $ do-        putStrLn "The package will not build sanely due to these errors:"-        printCheckMessages buildImpossible--    unless (null buildWarning) $ do-        putStrLn "The following warnings are likely affect your build negatively:"-        printCheckMessages buildWarning--    unless (null distSuspicious) $ do-        putStrLn "These warnings may cause trouble when distributing the package:"-        printCheckMessages distSuspicious--    unless (null distInexusable) $ do-        putStrLn "The following errors will cause portability problems on other environments:"-        printCheckMessages distInexusable--    let isDistError (PackageDistSuspicious {}) = False-        isDistError _                          = True-        errors = filter isDistError packageChecks--    unless (null errors) $ do-        putStrLn "Hackage would reject this package."--    when (null packageChecks) $ do-        putStrLn "No errors or warnings could be found in the package."--    return (null packageChecks)--  where-    printCheckMessages = mapM_ (putStrLn . format . explanation)-    format = toUTF8 . wrapText . ("* "++)
− cabal-install-0.9.5_rc20101226/Distribution/Client/Config.hs 
@@ -1,519 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Config--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ Utilities for handling saved state such as known packages, known servers and downloaded packages.-------------------------------------------------------------------------------module Distribution.Client.Config (-    SavedConfig(..),-    loadConfig,--    showConfig,-    showConfigWithComments,-    parseConfig,--    defaultCabalDir,-    defaultConfigFile,-    defaultCacheDir,-    defaultLogsDir,-  ) where---import Distribution.Client.Types-         ( RemoteRepo(..), Username(..), Password(..) )-import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand-         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags-         , InstallFlags(..), installOptions, defaultInstallFlags-         , UploadFlags(..), uploadCommand-         , showRepo, parseRepo )--import Distribution.Simple.Setup-         ( ConfigFlags(..), configureOptions, defaultConfigFlags-         , installDirsOptions-         , Flag, toFlag, flagToMaybe, fromFlagOrDefault )-import Distribution.Simple.InstallDirs-         ( InstallDirs(..), defaultInstallDirs-         , PathTemplate, toPathTemplate )-import Distribution.ParseUtils-         ( FieldDescr(..), liftField-         , ParseResult(..), locatedErrorMsg, showPWarning-         , readFields, warning, lineNo-         , simpleField, listField, parseFilePathQ, parseTokenQ )-import qualified Distribution.ParseUtils as ParseUtils-         ( Field(..) )-import qualified Distribution.Text as Text-         ( Text(..) )-import Distribution.Simple.Command-         ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)-         , viewAsFieldDescr )-import Distribution.Simple.Program-         ( defaultProgramConfiguration )-import Distribution.Simple.Utils-         ( notice, warn, lowercase )-import Distribution.Compiler-         ( CompilerFlavor(..), defaultCompilerFlavor )-import Distribution.Verbosity-         ( Verbosity, normal )--import Data.List-         ( partition, find )-import Data.Maybe-         ( fromMaybe )-import Data.Monoid-         ( Monoid(..) )-import Control.Monad-         ( when, foldM, liftM )-import qualified Data.Map as Map-import qualified Distribution.Compat.ReadP as Parse-         ( option )-import qualified Text.PrettyPrint.HughesPJ as Disp-         ( Doc, render, text, colon, vcat, empty, isEmpty, nest )-import Text.PrettyPrint.HughesPJ-         ( (<>), (<+>), ($$), ($+$) )-import System.Directory-         ( createDirectoryIfMissing, getAppUserDataDirectory )-import Network.URI-         ( URI(..), URIAuth(..) )-import System.FilePath-         ( (</>), takeDirectory )-import System.Environment-         ( getEnvironment )-import System.IO.Error-         ( isDoesNotExistError )------- * Configuration saved in the config file-----data SavedConfig = SavedConfig {-    savedGlobalFlags       :: GlobalFlags,-    savedInstallFlags      :: InstallFlags,-    savedConfigureFlags    :: ConfigFlags,-    savedConfigureExFlags  :: ConfigExFlags,-    savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),-    savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),-    savedUploadFlags       :: UploadFlags-  }--instance Monoid SavedConfig where-  mempty = SavedConfig {-    savedGlobalFlags       = mempty,-    savedInstallFlags      = mempty,-    savedConfigureFlags    = mempty,-    savedConfigureExFlags  = mempty,-    savedUserInstallDirs   = mempty,-    savedGlobalInstallDirs = mempty,-    savedUploadFlags       = mempty-  }-  mappend a b = SavedConfig {-    savedGlobalFlags       = combine savedGlobalFlags,-    savedInstallFlags      = combine savedInstallFlags,-    savedConfigureFlags    = combine savedConfigureFlags,-    savedConfigureExFlags  = combine savedConfigureExFlags,-    savedUserInstallDirs   = combine savedUserInstallDirs,-    savedGlobalInstallDirs = combine savedGlobalInstallDirs,-    savedUploadFlags       = combine savedUploadFlags-  }-    where combine field = field a `mappend` field b--updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig-updateInstallDirs userInstallFlag-  savedConfig@SavedConfig {-    savedConfigureFlags    = configureFlags,-    savedUserInstallDirs   = userInstallDirs,-    savedGlobalInstallDirs = globalInstallDirs-  } =-  savedConfig {-    savedConfigureFlags = configureFlags {-      configInstallDirs = installDirs-    }-  }-  where-    installDirs | userInstall = userInstallDirs-                | otherwise   = globalInstallDirs-    userInstall = fromFlagOrDefault defaultUserInstall $-                    configUserInstall configureFlags `mappend` userInstallFlag------- * Default config------- | These are the absolute basic defaults. The fields that must be--- initialised. When we load the config from the file we layer the loaded--- values over these ones, so any missing fields in the file take their values--- from here.----baseSavedConfig :: IO SavedConfig-baseSavedConfig = do-  userPrefix <- defaultCabalDir-  logsDir    <- defaultLogsDir-  worldFile  <- defaultWorldFile-  return mempty {-    savedConfigureFlags  = mempty {-      configHcFlavor     = toFlag defaultCompiler,-      configUserInstall  = toFlag defaultUserInstall,-      configVerbosity    = toFlag normal-    },-    savedUserInstallDirs = mempty {-      prefix             = toFlag (toPathTemplate userPrefix)-    },-    savedGlobalFlags = mempty {-      globalLogsDir      = toFlag logsDir,-      globalWorldFile    = toFlag worldFile-    }-  }---- | This is the initial configuration that we write out to to the config file--- if the file does not exist (or the config we use if the file cannot be read--- for some other reason). When the config gets loaded it gets layered on top--- of 'baseSavedConfig' so we do not need to include it into the initial--- values we save into the config file.----initialSavedConfig :: IO SavedConfig-initialSavedConfig = do-  cacheDir   <- defaultCacheDir-  logsDir    <- defaultLogsDir-  worldFile  <- defaultWorldFile-  return mempty {-    savedGlobalFlags     = mempty {-      globalCacheDir     = toFlag cacheDir,-      globalRemoteRepos  = [defaultRemoteRepo],-      globalWorldFile    = toFlag worldFile-    },-    savedInstallFlags    = mempty {-      installSummaryFile = [toPathTemplate (logsDir </> "build.log")],-      installBuildReports= toFlag AnonymousReports-    }-  }----TODO: misleading, there's no way to override this default---      either make it possible or rename to simply getCabalDir.-defaultCabalDir :: IO FilePath-defaultCabalDir = getAppUserDataDirectory "cabal"--defaultConfigFile :: IO FilePath-defaultConfigFile = do-  dir <- defaultCabalDir-  return $ dir </> "config"--defaultCacheDir :: IO FilePath-defaultCacheDir = do-  dir <- defaultCabalDir-  return $ dir </> "packages"--defaultLogsDir :: IO FilePath-defaultLogsDir = do-  dir <- defaultCabalDir-  return $ dir </> "logs"---- | Default position of the world file-defaultWorldFile :: IO FilePath-defaultWorldFile = do-  dir <- defaultCabalDir-  return $ dir </> "world"--defaultCompiler :: CompilerFlavor-defaultCompiler = fromMaybe GHC defaultCompilerFlavor--defaultUserInstall :: Bool-defaultUserInstall = True--- We do per-user installs by default on all platforms. We used to default to--- global installs on Windows but that no longer works on Windows Vista or 7.--defaultRemoteRepo :: RemoteRepo-defaultRemoteRepo = RemoteRepo name uri-  where-    name = "hackage.haskell.org"-    uri  = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" ""------- * Config file reading-----loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig-loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do-  let sources = [-        ("commandline option",   return . flagToMaybe $ configFileFlag),-        ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),-        ("default config file",  Just `liftM` defaultConfigFile) ]--      getSource [] = error "no config file path candidate found."-      getSource ((msg,action): xs) = -                        action >>= maybe (getSource xs) (return . (,) msg)--  (source, configFile) <- getSource sources-  minp <- readConfigFile mempty configFile-  case minp of-    Nothing -> do-      notice verbosity $ "Config file path source is " ++ source ++ "."-      notice verbosity $ "Config file " ++ configFile ++ " not found."-      notice verbosity $ "Writing default configuration to " ++ configFile-      commentConf <- commentSavedConfig-      initialConf <- initialSavedConfig-      writeConfigFile configFile commentConf initialConf-      return initialConf-    Just (ParseOk ws conf) -> do-      when (not $ null ws) $ warn verbosity $-        unlines (map (showPWarning configFile) ws)-      return conf-    Just (ParseFailed err) -> do-      let (line, msg) = locatedErrorMsg err-      warn verbosity $-          "Error parsing config file " ++ configFile-        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg-      warn verbosity $ "Using default configuration."-      initialSavedConfig--  where-    addBaseConf body = do-      base  <- baseSavedConfig-      extra <- body-      return (updateInstallDirs userInstallFlag (base `mappend` extra))--readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))-readConfigFile initial file = handleNotExists $-  fmap (Just . parseConfig initial) (readFile file)--  where-    handleNotExists action = catch action $ \ioe ->-      if isDoesNotExistError ioe-        then return Nothing-        else ioError ioe--writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()-writeConfigFile file comments vals = do-  createDirectoryIfMissing True (takeDirectory file)-  writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"-  where-    explanation = unlines-      ["-- This is the configuration file for the 'cabal' command line tool."-      ,""-      ,"-- The available configuration options are listed below."-      ,"-- Some of them have default values listed."-      ,""-      ,"-- Lines (like this one) beginning with '--' are comments."-      ,"-- Be careful with spaces and indentation because they are"-      ,"-- used to indicate layout for nested sections."-      ,"",""-      ]---- | These are the default values that get used in Cabal if a no value is--- given. We use these here to include in comments when we write out the--- initial config file so that the user can see what default value they are--- overriding.----commentSavedConfig :: IO SavedConfig-commentSavedConfig = do-  userInstallDirs   <- defaultInstallDirs defaultCompiler True True-  globalInstallDirs <- defaultInstallDirs defaultCompiler False True-  return SavedConfig {-    savedGlobalFlags       = commandDefaultFlags globalCommand,-    savedInstallFlags      = defaultInstallFlags,-    savedConfigureExFlags  = defaultConfigExFlags,-    savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {-      configUserInstall    = toFlag defaultUserInstall-    },-    savedUserInstallDirs   = fmap toFlag userInstallDirs,-    savedGlobalInstallDirs = fmap toFlag globalInstallDirs,-    savedUploadFlags       = commandDefaultFlags uploadCommand-  }---- | All config file fields.----configFieldDescriptions :: [FieldDescr SavedConfig]-configFieldDescriptions =--     toSavedConfig liftGlobalFlag-       (commandOptions globalCommand ParseArgs)-       ["version", "numeric-version", "config-file"] []--  ++ toSavedConfig liftConfigFlag-       (configureOptions ParseArgs)-       (["builddir", "configure-option"] ++ map fieldName installDirsFields)--        --FIXME: this is only here because viewAsFieldDescr gives us a parser-        -- that only recognises 'ghc' etc, the case-sensitive flag names, not-        -- what the normal case-insensitive parser gives us.-       [simpleField "compiler"-          (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)-          configHcFlavor (\v flags -> flags { configHcFlavor = v })-       ]--  ++ toSavedConfig liftConfigExFlag-       (configureExOptions ParseArgs)-       [] []--  ++ toSavedConfig liftInstallFlag-       (installOptions ParseArgs)-       ["dry-run", "reinstall", "only"] []--  ++ toSavedConfig liftUploadFlag-       (commandOptions uploadCommand ParseArgs)-       ["verbose", "check"] []--  where-    toSavedConfig lift options exclusions replacements =-      [ lift (fromMaybe field replacement)-      | opt <- options-      , let field       = viewAsFieldDescr opt-            name        = fieldName field-            replacement = find ((== name) . fieldName) replacements-      , name `notElem` exclusions ]-    optional = Parse.option mempty . fmap toFlag---- TODO: next step, make the deprecated fields elicit a warning.----deprecatedFieldDescriptions :: [FieldDescr SavedConfig]-deprecatedFieldDescriptions =-  [ liftGlobalFlag $-    listField "repos"-      (Disp.text . showRepo) parseRepo-      globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs })-  , liftGlobalFlag $-    simpleField "cachedir"-      (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ)-      globalCacheDir    (\d cfg -> cfg { globalCacheDir = d })-  , liftUploadFlag $-    simpleField "hackage-username"-      (Disp.text . fromFlagOrDefault "" . fmap unUsername)-      (optional (fmap Username parseTokenQ))-      uploadUsername    (\d cfg -> cfg { uploadUsername = d })-  , liftUploadFlag $-    simpleField "hackage-password"-      (Disp.text . fromFlagOrDefault "" . fmap unPassword)-      (optional (fmap Password parseTokenQ))-      uploadPassword    (\d cfg -> cfg { uploadPassword = d })-  ]- ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)   installDirsFields- ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields-  where-    optional = Parse.option mempty . fmap toFlag-    modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a-    modifyFieldName f d = d { fieldName = f (fieldName d) }--liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))-                    -> FieldDescr SavedConfig-liftUserInstallDirs = liftField-  savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })--liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))-                      -> FieldDescr SavedConfig-liftGlobalInstallDirs = liftField-  savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags })--liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig-liftGlobalFlag = liftField-  savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })--liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig-liftConfigFlag = liftField-  savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })--liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig-liftConfigExFlag = liftField-  savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })--liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig-liftInstallFlag = liftField-  savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })--liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig-liftUploadFlag = liftField-  savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })--parseConfig :: SavedConfig -> String -> ParseResult SavedConfig-parseConfig initial = \str -> do-  fields <- readFields str-  let (knownSections, others) = partition isKnownSection fields-  config <- parse others-  let user0   = savedUserInstallDirs config-      global0 = savedGlobalInstallDirs config-  (user, global) <- foldM parseSections (user0, global0) knownSections-  return config {-    savedUserInstallDirs   = user,-    savedGlobalInstallDirs = global-  }--  where-    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True-    isKnownSection _                                          = False--    parse = parseFields (configFieldDescriptions-                      ++ deprecatedFieldDescriptions) initial--    parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs)-      | name' == "user"   = do u' <- parseFields installDirsFields u fs-                               return (u', g)-      | name' == "global" = do g' <- parseFields installDirsFields g fs-                               return (u, g')-      | otherwise         = do-          warning "The install-paths section should be for 'user' or 'global'"-          return accum-      where name' = lowercase name-    parseSections accum f = do-      warning $ "Unrecognized stanza on line " ++ show (lineNo f)-      return accum--showConfig :: SavedConfig -> String-showConfig = showConfigWithComments mempty--showConfigWithComments :: SavedConfig -> SavedConfig -> String-showConfigWithComments comment vals = Disp.render $-      ppFields configFieldDescriptions comment vals-  $+$ Disp.text ""-  $+$ installDirsSection "user"   savedUserInstallDirs-  $+$ Disp.text ""-  $+$ installDirsSection "global" savedGlobalInstallDirs-  where-    installDirsSection name field =-      ppSection "install-dirs" name installDirsFields-                (field comment) (field vals)----------------------------- * Parsing utils-------FIXME: replace this with something better in Cabal-1.5-parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a-parseFields fields initial = foldM setField initial-  where-    fieldMap = Map.fromList-      [ (name, f) | f@(FieldDescr name _ _) <- fields ]-    setField accum (ParseUtils.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---- | This is a customised version of the function from Cabal that also prints--- default values for empty fields as comments.----ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc-ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)-                                    | FieldDescr name getter _ <- fields]--ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc-ppField name def cur-  | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def-  | otherwise        =                    Disp.text name <> Disp.colon <+> cur--ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc-ppSection name arg fields def cur =-     Disp.text name <+> Disp.text arg-  $$ Disp.nest 2 (ppFields fields def cur)--installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]-installDirsFields = map viewAsFieldDescr installDirsOptions-
− cabal-install-0.9.5_rc20101226/Distribution/Client/Configure.hs 
@@ -1,205 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Configure--- Copyright   :  (c) David Himmelstrup 2005,---                    Duncan Coutts 2005--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ High level interface to configuring a package.-------------------------------------------------------------------------------module Distribution.Client.Configure (-    configure,-  ) where--import Data.Monoid-         ( Monoid(mempty) )-import qualified Data.Map as Map--import Distribution.Client.Dependency-         ( resolveDependenciesWithProgress-         , PackageConstraint(..)-         , PackagesPreference(..), PackagesPreferenceDefault(..)-         , PackagePreference(..)-         , Progress(..), foldProgress, )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, getInstalledPackages )-import Distribution.Client.Setup-         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )-import Distribution.Client.Types as Available-         ( AvailablePackage(..), AvailablePackageSource(..), Repo(..)-         , AvailablePackageDb(..), ConfiguredPackage(..), InstalledPackage )-import Distribution.Client.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )--import Distribution.Simple.Compiler-         ( CompilerId(..), Compiler(compilerId)-         , PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration )-import Distribution.Simple.Setup-         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Simple.Utils-         ( defaultPackageDesc )-import Distribution.Package-         ( PackageName, packageName, packageVersion-         , Package(..), Dependency(..), thisPackageVersion )-import Distribution.PackageDescription.Parse-         ( readPackageDescription )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Version-         ( VersionRange, anyVersion, thisVersion )-import Distribution.Simple.Utils as Utils-         ( notice, info, die )-import Distribution.System-         ( Platform, buildPlatform )-import Distribution.Verbosity as Verbosity-         ( Verbosity )---- | Configure the package found in the local directory-configure :: Verbosity-          -> PackageDBStack-          -> [Repo]-          -> Compiler-          -> ProgramConfiguration-          -> ConfigFlags-          -> ConfigExFlags-          -> [String]-          -> IO ()-configure verbosity packageDBs repos comp conf-  configFlags configExFlags extraArgs = do--  installed <- getInstalledPackages verbosity comp packageDBs conf-  available <- getAvailablePackages verbosity repos--  progress <- planLocalPackage verbosity comp configFlags configExFlags-                               installed available--  notice verbosity "Resolving dependencies..."-  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)-                            (return . Left) (return . Right) progress-  case maybePlan of-    Left message -> do-      info verbosity message-      setupWrapper verbosity (setupScriptOptions installed) Nothing-        configureCommand (const configFlags) extraArgs--    Right installPlan -> case InstallPlan.ready installPlan of-      [pkg@(ConfiguredPackage (AvailablePackage _ _ (LocalUnpackedPackage _)) _ _)] ->-        configurePackage verbosity-          (InstallPlan.planPlatform installPlan)-          (InstallPlan.planCompiler installPlan)-          (setupScriptOptions installed)-          configFlags pkg extraArgs--      _ -> die $ "internal error: configure install plan should have exactly "-              ++ "one local ready package."--  where-    setupScriptOptions index = SetupScriptOptions {-      useCabalVersion  = maybe anyVersion thisVersion-                         (flagToMaybe (configCabalVersion configExFlags)),-      useCompiler      = Just comp,-      -- Hack: we typically want to allow the UserPackageDB for finding the-      -- Cabal lib when compiling any Setup.hs even if we're doing a global-      -- install. However we also allow looking in a specific package db.-      usePackageDB     = if UserPackageDB `elem` packageDBs-                           then packageDBs-                           else packageDBs ++ [UserPackageDB],-      usePackageIndex  = if UserPackageDB `elem` packageDBs-                           then Just index-                           else Nothing,-      useProgramConfig = conf,-      useDistPref      = fromFlagOrDefault-                           (useDistPref defaultSetupScriptOptions)-                           (configDistPref configFlags),-      useLoggingHandle = Nothing,-      useWorkingDir    = Nothing-    }---- | Make an 'InstallPlan' for the unpacked package in the current directory,--- and all its dependencies.----planLocalPackage :: Verbosity -> Compiler-                 -> ConfigFlags -> ConfigExFlags-                 -> PackageIndex InstalledPackage-                 -> AvailablePackageDb-                 -> IO (Progress String String InstallPlan)-planLocalPackage verbosity comp configFlags configExFlags installed-  (AvailablePackageDb _ availablePrefs) = do-  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity-  let -- The trick is, we add the local package to the available index and-      -- remove it from the installed index. Then we ask to resolve a-      -- dependency on exactly that package. So the resolver ends up having-      -- to pick the local package.-      available' = PackageIndex.insert localPkg mempty-      installed' = PackageIndex.deletePackageId (packageId localPkg) installed-      localPkg = AvailablePackage {-        packageInfoId                = packageId pkg,-        Available.packageDescription = pkg,-        packageSource                = LocalUnpackedPackage Nothing-      }-      targets     = [packageName pkg]-      constraints = [PackageVersionConstraint (packageName pkg)-                       (thisVersion (packageVersion pkg))-                    ,PackageFlagsConstraint   (packageName pkg)-                       (configConfigurationsFlags configFlags)]-                 ++ [ PackageVersionConstraint name ver-                    | Dependency name ver <- configConstraints configFlags ]-      preferences = mergePackagePrefs PreferLatestForSelected-                                      availablePrefs configExFlags--  return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)-             installed' available' preferences constraints targets---mergePackagePrefs :: PackagesPreferenceDefault-                  -> Map.Map PackageName VersionRange-                  -> ConfigExFlags-                  -> PackagesPreference-mergePackagePrefs defaultPref availablePrefs configExFlags =-  PackagesPreference defaultPref $-       -- The preferences that come from the hackage index-       [ PackageVersionPreference name ver-       | (name, ver) <- Map.toList availablePrefs ]-       -- additional preferences from the config file or command line-    ++ [ PackageVersionPreference name ver-       | Dependency name ver <- configPreferences configExFlags ]---- | Call an installer for an 'AvailablePackage' but override the configure--- flags with the ones given by the 'ConfiguredPackage'. In particular the--- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly--- versioned package dependencies. So we ignore any previous partial flag--- assignment or dependency constraints and use the new ones.----configurePackage :: Verbosity-                 -> Platform -> CompilerId-                 -> SetupScriptOptions-                 -> ConfigFlags-                 -> ConfiguredPackage-                 -> [String]-                 -> IO ()-configurePackage verbosity platform comp scriptOptions configFlags-  (ConfiguredPackage (AvailablePackage _ gpkg _) flags deps) extraArgs =--  setupWrapper verbosity-    scriptOptions (Just pkg) configureCommand configureFlags extraArgs--  where-    configureFlags   = filterConfigureFlags configFlags {-      configConfigurationsFlags = flags,-      configConstraints         = map thisPackageVersion deps,-      configVerbosity           = toFlag verbosity-    }--    pkg = case finalizePackageDescription flags-           (const True)-           platform comp [] gpkg of-      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"-      Right (desc, _) -> desc
− cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency.hs 
@@ -1,318 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007---                    Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Top level interface to dependency resolution.-------------------------------------------------------------------------------module Distribution.Client.Dependency (-    module Distribution.Client.Dependency.Types,-    resolveDependencies,-    resolveDependenciesWithProgress,--    resolveAvailablePackages,--    dependencyConstraints,-    dependencyTargets,--    PackagesPreference(..),-    PackagesPreferenceDefault(..),-    PackagePreference(..),--    upgradableDependencies,-  ) where--import Distribution.Client.Dependency.TopDown (topDownResolver)-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.Types-         ( UnresolvedDependency(..), AvailablePackage(..), InstalledPackage )-import Distribution.Client.Dependency.Types-         ( DependencyResolver, PackageConstraint(..)-         , PackagePreferences(..), InstalledPreference(..)-         , Progress(..), foldProgress )-import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), packageVersion, packageName-         , Dependency(Dependency), Package(..), PackageFixedDeps(..) )-import Distribution.Version-         ( VersionRange, anyVersion, orLaterVersion-         , isAnyVersion, withinRange, simplifyVersionRange )-import Distribution.Compiler-         ( CompilerId(..) )-import Distribution.System-         ( Platform )-import Distribution.Simple.Utils (comparing)-import Distribution.Client.Utils (mergeBy, MergeResult(..))-import Distribution.Text-         ( display )--import Data.List (maximumBy)-import Data.Maybe (fromMaybe, isJust)-import qualified Data.Map as Map-import qualified Data.Set as Set-import Data.Set (Set)-import Control.Exception (assert)--defaultResolver :: DependencyResolver-defaultResolver = topDownResolver---- | Global policy for the versions of all packages.----data PackagesPreference = PackagesPreference-       PackagesPreferenceDefault-       [PackagePreference]--dependencyConstraints :: [UnresolvedDependency] -> [PackageConstraint]-dependencyConstraints deps =-     [ PackageVersionConstraint name versionRange-     | UnresolvedDependency (Dependency name versionRange) _ <- deps-     , not (isAnyVersion versionRange) ]--  ++ [ PackageFlagsConstraint name flags-     | UnresolvedDependency (Dependency name _) flags <- deps-     , not (null flags) ]--dependencyTargets :: [UnresolvedDependency] -> [PackageName]-dependencyTargets deps =-  [ name | UnresolvedDependency (Dependency name _) _ <- deps ]---- | Global policy for all packages to say if we prefer package versions that--- are already installed locally or if we just prefer the latest available.----data PackagesPreferenceDefault =--     -- | Always prefer the latest version irrespective of any existing-     -- installed version.-     ---     -- * This is the standard policy for upgrade.-     ---     PreferAllLatest--     -- | Always prefer the installed versions over ones that would need to be-     -- installed. Secondarily, prefer latest versions (eg the latest installed-     -- version or if there are none then the latest available version).-   | PreferAllInstalled--     -- | Prefer the latest version for packages that are explicitly requested-     -- but prefers the installed version for any other packages.-     ---     -- * This is the standard policy for install.-     ---   | PreferLatestForSelected--data PackagePreference-   = PackageVersionPreference   PackageName VersionRange-   | PackageInstalledPreference PackageName InstalledPreference--resolveDependencies :: Platform-                    -> CompilerId-                    -> PackageIndex InstalledPackage-                    -> PackageIndex AvailablePackage-                    -> PackagesPreference-                    -> [PackageConstraint]-                    -> [PackageName]-                    -> Either String InstallPlan-resolveDependencies platform comp installed available-                    preferences constraints targets =-  foldProgress (flip const) Left Right $-    resolveDependenciesWithProgress-      platform comp installed available-      preferences constraints targets--resolveDependenciesWithProgress :: Platform-                                -> CompilerId-                                -> PackageIndex InstalledPackage-                                -> PackageIndex AvailablePackage-                                -> PackagesPreference-                                -> [PackageConstraint]-                                -> [PackageName]-                                -> Progress String String InstallPlan-resolveDependenciesWithProgress platform comp installed available-                                pref constraints targets-    -- TODO: the top down resolver chokes on the base constraints-    -- below when there are no targets and thus no dep on base.-    -- Need to refactor contraints separate from needing packages.-  | null targets = return (toPlan [])-  | otherwise    =-  let installed' = hideBrokenPackages installed-      -- If the user is not explicitly asking to upgrade base then lets-      -- prevent that from happening accidentally since it is usually not what-      -- you want and it probably does not work anyway. We do it by adding a-      -- constraint to only pick an installed version of base and ghc-prim.-      extraConstraints =-        [ PackageInstalledConstraint pkgname-        | all (/=PackageName "base") targets-        , pkgname <-  [ PackageName "base", PackageName "ghc-prim" ]-        , not (null (PackageIndex.lookupPackageName installed pkgname)) ]-      preferences = interpretPackagesPreference (Set.fromList targets) pref-   in fmap toPlan-    $ defaultResolver platform comp installed' available-                      preferences (extraConstraints ++ constraints) targets--  where-    toPlan pkgs =-      case InstallPlan.new platform comp (PackageIndex.fromList pkgs) of-        Right plan     -> plan-        Left  problems -> error $ unlines $-            "internal error: could not construct a valid install plan."-          : "The proposed (invalid) plan contained the following problems:"-          : map InstallPlan.showPlanProblem problems--hideBrokenPackages :: PackageFixedDeps p => PackageIndex p -> PackageIndex p-hideBrokenPackages index =-    check (null . PackageIndex.brokenPackages)-  . foldr (PackageIndex.deletePackageId . packageId) index-  . PackageIndex.reverseDependencyClosure index-  . map (packageId . fst)-  $ PackageIndex.brokenPackages index-  where-    check p x = assert (p x) x---- | Give an interpretation to the global 'PackagesPreference' as---  specific per-package 'PackageVersionPreference'.----interpretPackagesPreference :: Set PackageName-                            -> PackagesPreference-                            -> (PackageName -> PackagePreferences)-interpretPackagesPreference selected (PackagesPreference defaultPref prefs) =-  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)--  where-    versionPref pkgname =-      fromMaybe anyVersion (Map.lookup pkgname versionPrefs)-    versionPrefs = Map.fromList-      [ (pkgname, pref)-      | PackageVersionPreference pkgname pref <- prefs ]--    installPref pkgname =-      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)-    installPrefs = Map.fromList-      [ (pkgname, pref)-      | PackageInstalledPreference pkgname pref <- prefs ]-    installPrefDefault = case defaultPref of-      PreferAllLatest         -> \_       -> PreferLatest-      PreferAllInstalled      -> \_       -> PreferInstalled-      PreferLatestForSelected -> \pkgname ->-        -- When you say cabal install foo, what you really mean is, prefer the-        -- latest version of foo, but the installed version of everything else-        if pkgname `Set.member` selected then PreferLatest-                                         else PreferInstalled---- --------------------------------------------------------------- * Simple resolver that ignores dependencies--- ---------------------------------------------------------------- | A simplistic method of resolving a list of target package names to--- available packages.------ Specifically, it does not consider package dependencies at all. Unlike--- 'resolveDependencies', no attempt is made to ensure that the selected--- packages have dependencies that are satisfiable or consistent with--- each other.------ It is suitable for tasks such as selecting packages to download for user--- inspection. It is not suitable for selecting packages to install.------ Note: if no installed package index is available, it is ok to pass 'mempty'.--- It simply means preferences for installed packages will be ignored.----resolveAvailablePackages-  :: PackageIndex InstalledPackage-  -> PackageIndex AvailablePackage-  -> PackagesPreference-  -> [PackageConstraint]-  -> [PackageName]-  -> Either [ResolveNoDepsError] [AvailablePackage]-resolveAvailablePackages installed available preferences constraints targets =-    collectEithers (map selectPackage targets)-  where-    selectPackage :: PackageName -> Either ResolveNoDepsError AvailablePackage-    selectPackage pkgname-      | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions-      | otherwise    = Right $! maximumBy bestByPrefs choices--      where-        -- Constraints-        requiredVersions = packageConstraints pkgname-        pkgDependency    = Dependency pkgname requiredVersions-        choices          = PackageIndex.lookupDependency available pkgDependency--        -- Preferences-        PackagePreferences preferredVersions preferInstalled-          = packagePreferences pkgname--        bestByPrefs   = comparing $ \pkg ->-                          (installPref pkg, versionPref pkg, packageVersion pkg)-        installPref   = case preferInstalled of-          PreferLatest    -> const False-          PreferInstalled -> isJust . PackageIndex.lookupPackageId installed-                           . packageId-        versionPref   pkg = packageVersion pkg `withinRange` preferredVersions--    packageConstraints :: PackageName -> VersionRange-    packageConstraints pkgname =-      Map.findWithDefault anyVersion pkgname packageVersionConstraintMap-    packageVersionConstraintMap =-      Map.fromList [ (name, range)-                   | PackageVersionConstraint name range <- constraints ]--    packagePreferences :: PackageName -> PackagePreferences-    packagePreferences = interpretPackagesPreference (Set.fromList targets) preferences---collectEithers :: [Either a b] -> Either [a] [b]-collectEithers = collect . partitionEithers-  where-    collect ([], xs) = Right xs-    collect (errs,_) = Left errs-    partitionEithers :: [Either a b] -> ([a],[b])-    partitionEithers = foldr (either left right) ([],[])-     where-       left  a (l, r) = (a:l, r)-       right a (l, r) = (l, a:r)---- | Errors for 'resolveWithoutDependencies'.----data ResolveNoDepsError =--     -- | A package name which cannot be resolved to a specific package.-     -- Also gives the constraint on the version and whether there was-     -- a constraint on the package being installed.-     ResolveUnsatisfiable PackageName VersionRange--instance Show ResolveNoDepsError where-  show (ResolveUnsatisfiable name ver) =-       "There is no available version of " ++ display name-    ++ " that satisfies " ++ display (simplifyVersionRange ver)---- --------------------------------------------------------------- * Finding upgradable packages--- ---------------------------------------------------------------- | Given the list of installed packages and available packages, figure--- out which packages can be upgraded.----upgradableDependencies :: PackageIndex InstalledPackage-                       -> PackageIndex AvailablePackage-                       -> [Dependency]-upgradableDependencies installed available =-  [ Dependency name (orLaterVersion latestVersion)-    -- This is really quick (linear time). The trick is that we're doing a-    -- merge join of two tables. We can do it as a merge because they're in-    -- a comparable order because we're getting them from the package indexs.-  | InBoth latestInstalled allAvailable-      <- mergeBy (\a (b:_) -> packageName a `compare` packageName b)-                 [ maximumBy (comparing packageVersion) pkgs-                 | pkgs <- PackageIndex.allPackagesByName installed ]-                 (PackageIndex.allPackagesByName available)-  , let (PackageIdentifier name latestVersion) = packageId latestInstalled-  , any (\p -> packageVersion p > latestVersion) allAvailable ]
− cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown.hs 
@@ -1,776 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.-------------------------------------------------------------------------------module Distribution.Client.Dependency.TopDown (-    topDownResolver-  ) where--import Distribution.Client.Dependency.TopDown.Types-import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints-import Distribution.Client.Dependency.TopDown.Constraints-         ( Satisfiable(..) )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan-         ( PlanPackage(..) )-import Distribution.Client.Types-         ( AvailablePackage(..), ConfiguredPackage(..), InstalledPackage(..) )-import Distribution.Client.Dependency.Types-         ( DependencyResolver, PackageConstraint(..)-         , PackagePreferences(..), InstalledPreference(..)-         , Progress(..), foldProgress )--import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Package-         ( PackageName(..), PackageIdentifier, Package(packageId), packageVersion, packageName-         , Dependency(Dependency), thisPackageVersion, notThisPackageVersion-         , PackageFixedDeps(depends) )-import Distribution.PackageDescription-         ( PackageDescription(buildDepends) )-import Distribution.Client.PackageUtils-         ( externalBuildDepends )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription, flattenPackageDescription )-import Distribution.Version-         ( VersionRange, anyVersion, withinRange, simplifyVersionRange-         , UpperBound(..), asVersionIntervals )-import Distribution.Compiler-         ( CompilerId )-import Distribution.System-         ( Platform )-import Distribution.Simple.Utils-         ( equating, comparing )-import Distribution.Text-         ( display )--import Data.List-         ( foldl', maximumBy, minimumBy, nub, sort, groupBy )-import Data.Maybe-         ( fromJust, fromMaybe, catMaybes )-import Data.Monoid-         ( Monoid(mempty) )-import Control.Monad-         ( guard )-import qualified Data.Set as Set-import Data.Set (Set)-import qualified Data.Map as Map-import qualified Data.Graph as Graph-import qualified Data.Array as Array-import Control.Exception-         ( assert )---- --------------------------------------------------------------- * Search state types--- --------------------------------------------------------------type Constraints  = Constraints.Constraints-                      InstalledPackageEx UnconfiguredPackage ExclusionReason-type SelectedPackages = PackageIndex SelectedPackage---- --------------------------------------------------------------- * The search tree type--- --------------------------------------------------------------data SearchSpace inherited pkg-   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]-   | Failure Failure---- --------------------------------------------------------------- * Traverse a search tree--- --------------------------------------------------------------explore :: (PackageName -> PackagePreferences)-        -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)-                       SelectablePackage-        -> Progress Log Failure (SelectedPackages, Constraints)--explore _    (Failure failure)       = Fail failure-explore _    (ChoiceNode (s,c,_) []) = Done (s,c)-explore pref (ChoiceNode _ choices)  =-  case [ choice | [choice] <- choices ] of-    ((_, node'):_) -> Step (logInfo node') (explore pref node')-    []             -> Step (logInfo node') (explore pref node')-      where-        choice     = minimumBy (comparing topSortNumber) choices-        pkgname    = packageName . fst . head $ choice-        (_, node') = maximumBy (bestByPref pkgname) choice-  where-    topSortNumber choice = case fst (head choice) of-      InstalledOnly           (InstalledPackageEx  _ i _) -> i-      AvailableOnly           (UnconfiguredPackage _ i _) -> i-      InstalledAndAvailable _ (UnconfiguredPackage _ i _) -> i--    bestByPref pkgname = case packageInstalledPreference of-        PreferLatest    ->-          comparing (\(p,_) -> (               isPreferred p, packageId p))-        PreferInstalled ->-          comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))-      where-        isInstalled (AvailableOnly _) = False-        isInstalled _                 = True-        isPreferred p = packageVersion p `withinRange` preferredVersions-        (PackagePreferences preferredVersions packageInstalledPreference)-          = pref pkgname--    logInfo node = Select selected discarded-      where (selected, discarded) = case node of-              Failure    _               -> ([], [])-              ChoiceNode (_,_,changes) _ -> changes---- --------------------------------------------------------------- * Generate a search tree--- --------------------------------------------------------------type ConfigurePackage = PackageIndex SelectablePackage-                     -> SelectablePackage-                     -> Either [Dependency] SelectedPackage---- | (packages selected, packages discarded)-type SelectionChanges = ([SelectedPackage], [PackageIdentifier])--searchSpace :: ConfigurePackage-            -> Constraints-            -> SelectedPackages-            -> SelectionChanges-            -> Set PackageName-            -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)-                           SelectablePackage-searchSpace configure constraints selected changes next =-  ChoiceNode (selected, constraints, changes)-    [ [ (pkg, select name pkg)-      | pkg <- PackageIndex.lookupPackageName available name ]-    | name <- Set.elems next ]-  where-    available = Constraints.choices constraints--    select name pkg = case configure available pkg of-      Left missing -> Failure $ ConfigureFailed pkg-                        [ (dep, Constraints.conflicting constraints dep)-                        | dep <- missing ]-      Right pkg' -> case constrainDeps pkg' newDeps constraints [] of-        Left failure       -> Failure failure-        Right (constraints', newDiscarded) ->-          searchSpace configure-            constraints' selected' (newSelected, newDiscarded) next'-        where-          selected' = foldl' (flip PackageIndex.insert) selected newSelected-          newSelected =-            case Constraints.isPaired constraints (packageId pkg) of-              Nothing     -> [pkg']-              Just pkgid' -> [pkg', pkg'']-                where-                  Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)-                    (PackageIndex.lookupPackageId available pkgid')--          newPkgs   = [ name'-                      | dep <- newDeps-                      , let (Dependency name' _) = untagDependency dep-                      , null (PackageIndex.lookupPackageName selected' name') ]-          newDeps   = concatMap packageConstraints newSelected-          next'     = Set.delete name-                    $ foldl' (flip Set.insert) next newPkgs--packageConstraints :: SelectedPackage -> [TaggedDependency]-packageConstraints = either installedConstraints availableConstraints-                   . preferAvailable-  where-    preferAvailable (InstalledOnly           pkg) = Left pkg-    preferAvailable (AvailableOnly           pkg) = Right pkg-    preferAvailable (InstalledAndAvailable _ pkg) = Right pkg-    installedConstraints (InstalledPackageEx    _ _ deps) =-      [ TaggedDependency InstalledConstraint (thisPackageVersion dep)-      | dep <- deps ]-    availableConstraints (SemiConfiguredPackage _ _ deps) =-      [ TaggedDependency NoInstalledConstraint dep | dep <- deps ]--constrainDeps :: SelectedPackage -> [TaggedDependency] -> Constraints-              -> [PackageIdentifier]-              -> Either Failure (Constraints, [PackageIdentifier])-constrainDeps pkg []         cs discard =-  case addPackageSelectConstraint (packageId pkg) cs of-    Satisfiable cs' discard' -> Right (cs', discard' ++ discard)-    _                        -> impossible-constrainDeps pkg (dep:deps) cs discard =-  case addPackageDependencyConstraint (packageId pkg) dep cs of-    Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)-    Unsatisfiable            -> impossible-    ConflictsWith conflicts  ->-      Left (DependencyConflict pkg dep conflicts)---- --------------------------------------------------------------- * The main algorithm--- --------------------------------------------------------------search :: ConfigurePackage-       -> (PackageName -> PackagePreferences)-       -> Constraints-       -> Set PackageName-       -> Progress Log Failure (SelectedPackages, Constraints)-search configure pref constraints =-  explore pref . searchSpace configure constraints mempty ([], [])---- --------------------------------------------------------------- * The top level resolver--- ---------------------------------------------------------------- | The main exported resolver, with string logging and failure types to fit--- the standard 'DependencyResolver' interface.----topDownResolver :: DependencyResolver-topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'-  where-    mapMessages :: Progress Log Failure a -> Progress String String a-    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done---- | The native resolver with detailed structured logging and failure types.----topDownResolver' :: Platform -> CompilerId-                 -> PackageIndex InstalledPackage-                 -> PackageIndex AvailablePackage-                 -> (PackageName -> PackagePreferences)-                 -> [PackageConstraint]-                 -> [PackageName]-                 -> Progress Log Failure [PlanPackage]-topDownResolver' platform comp installed available-                 preferences constraints targets =-      fmap (uncurry finalise)-    . (\cs -> search configure preferences cs initialPkgNames)-  =<< addTopLevelConstraints constraints constraintSet--  where-    configure   = configurePackage platform comp-    constraintSet :: Constraints-    constraintSet = Constraints.empty-      (annotateInstalledPackages             topSortNumber installed')-      (annotateAvailablePackages constraints topSortNumber available')-    (installed', available') = selectNeededSubset installed available-                                                  initialPkgNames-    topSortNumber = topologicalSortNumbering installed' available'--    initialPkgNames = Set.fromList targets--    finalise selected' constraints' =-        PackageIndex.allPackages-      . fst . improvePlan installed' constraints'-      . PackageIndex.fromList-      $ finaliseSelectedPackages preferences selected' constraints'--addTopLevelConstraints :: [PackageConstraint] -> Constraints-                       -> Progress a Failure Constraints-addTopLevelConstraints []                                      cs = Done cs-addTopLevelConstraints (PackageFlagsConstraint   _   _  :deps) cs =-  addTopLevelConstraints deps cs--addTopLevelConstraints (PackageVersionConstraint pkg ver:deps) cs =-  case addTopLevelVersionConstraint pkg ver cs of-    Satisfiable cs' _       ->-      addTopLevelConstraints deps cs'--    Unsatisfiable           ->-      Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)--    ConflictsWith conflicts ->-      Fail (TopLevelVersionConstraintConflict pkg ver conflicts)--addTopLevelConstraints (PackageInstalledConstraint pkg:deps) cs =-  case addTopLevelInstalledConstraint pkg cs of-    Satisfiable cs' _       -> addTopLevelConstraints deps cs'--    Unsatisfiable           ->-      Fail (TopLevelInstallConstraintUnsatisfiable pkg)--    ConflictsWith conflicts ->-      Fail (TopLevelInstallConstraintConflict pkg conflicts)--configurePackage :: Platform -> CompilerId -> ConfigurePackage-configurePackage platform comp available spkg = case spkg of-  InstalledOnly         ipkg      -> Right (InstalledOnly ipkg)-  AvailableOnly              apkg -> fmap AvailableOnly (configure apkg)-  InstalledAndAvailable ipkg apkg -> fmap (InstalledAndAvailable ipkg)-                                          (configure apkg)-  where-  configure (UnconfiguredPackage apkg@(AvailablePackage _ p _) _ flags) =-    case finalizePackageDescription flags dependencySatisfiable-                                    platform comp [] p of-      Left missing        -> Left missing-      Right (pkg, flags') -> Right $-        SemiConfiguredPackage apkg flags' (externalBuildDepends pkg)--  dependencySatisfiable = not . null . PackageIndex.lookupDependency available---- | Annotate each installed packages with its set of transative dependencies--- and its topological sort number.----annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)-                          -> PackageIndex InstalledPackage-                          -> PackageIndex InstalledPackageEx-annotateInstalledPackages dfsNumber installed = PackageIndex.fromList-  [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)-  | pkg <- PackageIndex.allPackages installed ]-  where-    transitiveDepends :: InstalledPackage -> [PackageIdentifier]-    transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph-                      . fromJust . toVertex . packageId-    (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed----- | Annotate each available packages with its topological sort number and any--- user-supplied partial flag assignment.----annotateAvailablePackages :: [PackageConstraint]-                          -> (PackageName -> TopologicalSortNumber)-                          -> PackageIndex AvailablePackage-                          -> PackageIndex UnconfiguredPackage-annotateAvailablePackages constraints dfsNumber available = PackageIndex.fromList-  [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)-  | pkg <- PackageIndex.allPackages available-  , let name = packageName pkg ]-  where-    flagsFor = fromMaybe [] . flip Map.lookup flagsMap-    flagsMap = Map.fromList-      [ (name, flags)-      | PackageFlagsConstraint name flags <- constraints ]---- | One of the heuristics we use when guessing which path to take in the--- search space is an ordering on the choices we make. It's generally better--- to make decisions about packages higer in the dep graph first since they--- place constraints on packages lower in the dep graph.------ To pick them in that order we annotate each package with its topological--- sort number. So if package A depends on package B then package A will have--- a lower topological sort number than B and we'll make a choice about which--- version of A to pick before we make a choice about B (unless there is only--- one possible choice for B in which case we pick that immediately).------ To construct these topological sort numbers we combine and flatten the--- installed and available package sets. We consider only dependencies between--- named packages, not including versions and for not-yet-configured packages--- we look at all the possible dependencies, not just those under any single--- flag assignment. This means we can actually get impossible combinations of--- edges and even cycles, but that doesn't really matter here, it's only a--- heuristic.----topologicalSortNumbering :: PackageIndex InstalledPackage-                         -> PackageIndex AvailablePackage-                         -> (PackageName -> TopologicalSortNumber)-topologicalSortNumbering installed available =-    \pkgname -> let Just vertex = toVertex pkgname-                 in topologicalSortNumbers Array.! vertex-  where-    topologicalSortNumbers = Array.array (Array.bounds graph)-                                         (zip (Graph.topSort graph) [0..])-    (graph, _, toVertex)   = Graph.graphFromEdges $-         [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installed-         , let deps = [ packageName dep-                      | pkg' <- pkgs-                      , dep  <- depends pkg' ] ]-      ++ [ ((), packageName pkg, nub deps)-         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName available-         , let deps = [ depName-                      | AvailablePackage _ pkg' _ <- pkgs-                      , Dependency depName _ <--                          buildDepends (flattenPackageDescription pkg') ] ]---- | We don't need the entire index (which is rather large and costly if we--- force it by examining the whole thing). So trace out the maximul subset of--- each index that we could possibly ever need. Do this by flattening packages--- and looking at the names of all possible dependencies.----selectNeededSubset :: PackageIndex InstalledPackage-                   -> PackageIndex AvailablePackage-                   -> Set PackageName-                   -> (PackageIndex InstalledPackage-                      ,PackageIndex AvailablePackage)-selectNeededSubset installed available = select mempty mempty-  where-    select :: PackageIndex InstalledPackage-           -> PackageIndex AvailablePackage-           -> Set PackageName-           -> (PackageIndex InstalledPackage-              ,PackageIndex AvailablePackage)-    select installed' available' remaining-      | Set.null remaining = (installed', available')-      | otherwise = select installed'' available'' remaining''-      where-        (next, remaining') = Set.deleteFindMin remaining-        moreInstalled = PackageIndex.lookupPackageName installed next-        moreAvailable = PackageIndex.lookupPackageName available next-        moreRemaining = -- we filter out packages already included in the indexes-                        -- this avoids an infinite loop if a package depends on itself-                        -- like base-3.0.3.0 with base-4.0.0.0-                        filter notAlreadyIncluded-                      $ [ packageName dep-                        | pkg <- moreInstalled-                        , dep <- depends pkg ]-                     ++ [ name-                        | AvailablePackage _ pkg _ <- moreAvailable-                        , Dependency name _ <--                            buildDepends (flattenPackageDescription pkg) ]-        installed''   = foldl' (flip PackageIndex.insert) installed' moreInstalled-        available''   = foldl' (flip PackageIndex.insert) available' moreAvailable-        remaining''   = foldl' (flip         Set.insert) remaining' moreRemaining-        notAlreadyIncluded name = null (PackageIndex.lookupPackageName installed' name)-                                  && null (PackageIndex.lookupPackageName available' name)---- --------------------------------------------------------------- * Post processing the solution--- --------------------------------------------------------------finaliseSelectedPackages :: (PackageName -> PackagePreferences)-                         -> SelectedPackages-                         -> Constraints-                         -> [PlanPackage]-finaliseSelectedPackages pref selected constraints =-  map finaliseSelected (PackageIndex.allPackages selected)-  where-    remainingChoices = Constraints.choices constraints-    finaliseSelected (InstalledOnly         ipkg     ) = finaliseInstalled ipkg-    finaliseSelected (AvailableOnly              apkg) = finaliseAvailable Nothing apkg-    finaliseSelected (InstalledAndAvailable ipkg apkg) =-      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of-        Nothing                          -> impossible --picked package not in constraints-        Just (AvailableOnly _)           -> impossible --to constrain to avail only-        Just (InstalledOnly _)           -> finaliseInstalled ipkg-        Just (InstalledAndAvailable _ _) -> finaliseAvailable (Just ipkg) apkg--    finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg-    finaliseAvailable mipkg (SemiConfiguredPackage pkg flags deps) =-      InstallPlan.Configured (ConfiguredPackage pkg flags deps')-      where-        deps' = map (packageId . pickRemaining mipkg) deps--    pickRemaining mipkg dep@(Dependency _name versionRange) =-          case PackageIndex.lookupDependency remainingChoices dep of-            []        -> impossible-            [pkg']    -> pkg'-            remaining -> assert (checkIsPaired remaining)-                       $ maximumBy bestByPref remaining-      where-        -- We order candidate packages to pick for a dependency by these-        -- three factors. The last factor is just highest version wins.-        bestByPref =-          comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))-        -- Is the package already used by the installed version of this-        -- package? If so we should pick that first. This stops us from doing-        -- silly things like deciding to rebuild haskell98 against base 3.-        isCurrent = case mipkg :: Maybe InstalledPackageEx of-          Nothing   -> \_ -> False-          Just ipkg -> \p -> packageId p `elem` depends ipkg-        -- If there is no upper bound on the version range then we apply a-        -- preferred version acording to the hackage or user's suggested-        -- version constraints. TODO: distinguish hacks from prefs-        bounded = boundedAbove versionRange-        isPreferred p-          | bounded   = True -- any constant will do-          | otherwise = packageVersion p `withinRange` preferredVersions-          where (PackagePreferences preferredVersions _) = pref (packageName p)--        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--        -- We really only expect to find more than one choice remaining when-        -- we're finalising a dependency on a paired package.-        checkIsPaired [p1, p2] =-          case Constraints.isPaired constraints (packageId p1) of-            Just p2'   -> packageId p2' == packageId p2-            Nothing    -> False-        checkIsPaired _ = False---- | Improve an existing installation plan by, where possible, swapping--- packages we plan to install with ones that are already installed.--- This may add additional constraints due to the dependencies of installed--- packages on other installed packages.----improvePlan :: PackageIndex InstalledPackage-            -> Constraints-            -> PackageIndex PlanPackage-            -> (PackageIndex PlanPackage, Constraints)-improvePlan installed constraints0 selected0 =-  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)-  where-    improve (selected, constraints) = fromMaybe (selected, constraints)-                                    . improvePkg selected constraints--    -- The idea is to improve the plan by swapping a configured package for-    -- an equivalent installed one. For a particular package the condition is-    -- that the package be in a configured state, that a the same version be-    -- already installed with the exact same dependencies and all the packages-    -- in the plan that it depends on are in the installed state-    improvePkg selected constraints pkgid = do-      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid-      ipkg            <- PackageIndex.lookupPackageId installed pkgid-      guard $ all (isInstalled selected) (depends pkg)-      tryInstalled selected constraints [ipkg]--    isInstalled selected pkgid =-      case PackageIndex.lookupPackageId selected pkgid of-        Just (PreExisting _) -> True-        _                    -> False--    tryInstalled :: PackageIndex PlanPackage -> Constraints-                 -> [InstalledPackage]-                 -> Maybe (PackageIndex PlanPackage, Constraints)-    tryInstalled selected constraints [] = Just (selected, constraints)-    tryInstalled selected constraints (pkg:pkgs) =-      case constraintsOk (packageId pkg) (depends pkg) constraints of-        Nothing           -> Nothing-        Just constraints' -> tryInstalled selected' constraints' pkgs'-          where-            selected' = PackageIndex.insert (PreExisting pkg) selected-            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs-            notSelected pkgid =-              case (PackageIndex.lookupPackageId installed pkgid-                   ,PackageIndex.lookupPackageId selected  pkgid) of-                (Just pkg', Nothing) -> Just pkg'-                _                    -> Nothing--    constraintsOk _     []              constraints = Just constraints-    constraintsOk pkgid (pkgid':pkgids) constraints =-      case addPackageDependencyConstraint pkgid dep constraints of-        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'-        _                          -> Nothing-      where-        dep = TaggedDependency InstalledConstraint (thisPackageVersion pkgid')--    reverseTopologicalOrder :: PackageFixedDeps pkg-                            => PackageIndex pkg -> [PackageIdentifier]-    reverseTopologicalOrder index = map (packageId . toPkg)-                                  . Graph.topSort-                                  . Graph.transposeG-                                  $ graph-      where (graph, toPkg, _) = PackageIndex.dependencyGraph index---- --------------------------------------------------------------- * Adding and recording constraints--- --------------------------------------------------------------addPackageSelectConstraint :: PackageIdentifier -> Constraints-                           -> Satisfiable Constraints-                                [PackageIdentifier] ExclusionReason-addPackageSelectConstraint pkgid constraints =-  Constraints.constrain dep reason constraints-  where-    dep    = TaggedDependency NoInstalledConstraint (thisPackageVersion pkgid)-    reason = SelectedOther pkgid--addPackageExcludeConstraint :: PackageIdentifier -> Constraints-                            -> Satisfiable Constraints-                                 [PackageIdentifier] ExclusionReason-addPackageExcludeConstraint pkgid constraints =-  Constraints.constrain dep reason constraints-  where-    dep    = TaggedDependency NoInstalledConstraint-               (notThisPackageVersion pkgid)-    reason = ExcludedByConfigureFail--addPackageDependencyConstraint :: PackageIdentifier -> TaggedDependency -> Constraints-                               -> Satisfiable Constraints-                                    [PackageIdentifier] ExclusionReason-addPackageDependencyConstraint pkgid dep constraints =-  Constraints.constrain dep reason constraints-  where-    reason = ExcludedByPackageDependency pkgid dep--addTopLevelVersionConstraint :: PackageName -> VersionRange-                             -> Constraints-                             -> Satisfiable Constraints-                                  [PackageIdentifier] ExclusionReason-addTopLevelVersionConstraint pkg ver constraints =-  Constraints.constrain taggedDep reason constraints-  where-    dep       = Dependency pkg ver-    taggedDep = TaggedDependency NoInstalledConstraint dep-    reason    = ExcludedByTopLevelDependency dep--addTopLevelInstalledConstraint :: PackageName-                               -> Constraints-                               -> Satisfiable Constraints-                                    [PackageIdentifier] ExclusionReason-addTopLevelInstalledConstraint pkg constraints =-  Constraints.constrain taggedDep reason constraints-  where-    dep       = Dependency pkg anyVersion-    taggedDep = TaggedDependency InstalledConstraint dep-    reason    = ExcludedByTopLevelDependency dep---- --------------------------------------------------------------- * Reasons for constraints--- ---------------------------------------------------------------- | For every constraint we record we also record the reason that constraint--- is needed. So if we end up failing due to conflicting constraints then we--- can give an explnanation as to what was conflicting and why.----data ExclusionReason =--     -- | We selected this other version of the package. That means we exclude-     -- all the other versions.-     SelectedOther PackageIdentifier--     -- | We excluded this version of the package because it failed to-     -- configure probably because of unsatisfiable deps.-   | ExcludedByConfigureFail--     -- | We excluded this version of the package because another package that-     -- we selected imposed a dependency which this package did not satisfy.-   | ExcludedByPackageDependency PackageIdentifier TaggedDependency--     -- | We excluded this version of the package because it did not satisfy-     -- a dependency given as an original top level input.-     ---   | ExcludedByTopLevelDependency Dependency---- | Given an excluded package and the reason it was excluded, produce a human--- readable explanation.----showExclusionReason :: PackageIdentifier -> ExclusionReason -> String-showExclusionReason pkgid (SelectedOther pkgid') =-  display pkgid ++ " was excluded because " ++-  display pkgid' ++ " was selected instead"-showExclusionReason pkgid ExcludedByConfigureFail =-  display pkgid ++ " was excluded because it could not be configured"-showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep) =-  display pkgid ++ " was excluded because " ++-  display pkgid' ++ " requires " ++ displayDep (untagDependency dep)-showExclusionReason pkgid (ExcludedByTopLevelDependency dep) =-  display pkgid ++ " was excluded because of the top level dependency " ++-  displayDep dep----- --------------------------------------------------------------- * Logging progress and failures--- --------------------------------------------------------------data Log = Select [SelectedPackage] [PackageIdentifier]-data Failure-   = ConfigureFailed-       SelectablePackage-       [(Dependency, [(PackageIdentifier, [ExclusionReason])])]-   | DependencyConflict-       SelectedPackage TaggedDependency-       [(PackageIdentifier, [ExclusionReason])]-   | TopLevelVersionConstraintConflict-       PackageName VersionRange-       [(PackageIdentifier, [ExclusionReason])]-   | TopLevelVersionConstraintUnsatisfiable-       PackageName VersionRange-   | TopLevelInstallConstraintConflict-       PackageName-       [(PackageIdentifier, [ExclusionReason])]-   | TopLevelInstallConstraintUnsatisfiable-       PackageName--showLog :: Log -> String-showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of-  ("", y) -> y-  (x, "") -> x-  (x,  y) -> x ++ " and " ++ y--  where-    selectedMsg  = "selecting " ++ case selected of-      []     -> ""-      [s]    -> display (packageId s) ++ " " ++ kind s-      (s:ss) -> listOf id-              $ (display (packageId s) ++ " " ++ kind s)-              : [ display (packageVersion s') ++ " " ++ kind s'-                | s' <- ss ]--    kind (InstalledOnly _)           = "(installed)"-    kind (AvailableOnly _)           = "(hackage)"-    kind (InstalledAndAvailable _ _) = "(installed or hackage)"--    discardedMsg = case discarded of-      []  -> ""-      _   -> "discarding " ++ listOf id-        [ element-        | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)-        , element <- display pkgid : map (display . packageVersion) pkgids ]--showFailure :: Failure -> String-showFailure (ConfigureFailed pkg missingDeps) =-     "cannot configure " ++ displayPkg pkg ++ ". It requires "-  ++ listOf (displayDep . fst) missingDeps-  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)--  where-    whyNot (Dependency name ver) [] =-         "There is no available version of " ++ display name-      ++ " that satisfies " ++ displayVer ver--    whyNot dep conflicts =-         "For the dependency on " ++ displayDep dep-      ++ " there are these packages: " ++ listOf display pkgs-      ++ ". However none of them are available.\n"-      ++ unlines [ showExclusionReason (packageId pkg') reason-                 | (pkg', reasons) <- conflicts, reason <- reasons ]--      where pkgs = map fst conflicts--showFailure (DependencyConflict pkg (TaggedDependency _ dep) conflicts) =-     "dependencies conflict: "-  ++ displayPkg pkg ++ " requires " ++ displayDep dep ++ " however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelVersionConstraintConflict name ver conflicts) =-     "constraints conflict: "-  ++ "top level constraint " ++ displayDep (Dependency name ver) ++ " however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =-     "There is no available version of " ++ display name-      ++ " that satisfies " ++ displayVer ver--showFailure (TopLevelInstallConstraintConflict name conflicts) =-     "constraints conflict: "-  ++ "top level constraint " ++ display name ++ "-installed however\n"-  ++ unlines [ showExclusionReason (packageId pkg') reason-             | (pkg', reasons) <- conflicts, reason <- reasons ]--showFailure (TopLevelInstallConstraintUnsatisfiable name) =-     "There is no installed version of " ++ display name--displayVer :: VersionRange -> String-displayVer = display . simplifyVersionRange--displayDep :: Dependency -> String-displayDep = display . simplifyDependency--simplifyDependency :: Dependency -> Dependency-simplifyDependency (Dependency name range) =-  Dependency name (simplifyVersionRange range)---- --------------------------------------------------------------- * Utils--- --------------------------------------------------------------impossible :: a-impossible = internalError "impossible"--internalError :: String -> a-internalError msg = error $ "internal error: " ++ msg--displayPkg :: Package pkg => pkg -> String-displayPkg = display . packageId--listOf :: (a -> String) -> [a] -> String-listOf _    []   = []-listOf disp [x0] = disp x0-listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs-  where go x []       = " and " ++ disp x-        go x (x':xs') = ", " ++ disp x ++ go x' xs'
− cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Constraints.hs 
@@ -1,316 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.TopDown.Constraints--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@haskell.org--- Stability   :  provisional--- Portability :  portable------ A set of satisfiable dependencies (package version constraints).-------------------------------------------------------------------------------module Distribution.Client.Dependency.TopDown.Constraints (-  Constraints,-  empty,-  choices,-  isPaired,--  constrain,-  Satisfiable(..),-  conflicting,-  ) where--import Distribution.Client.Dependency.TopDown.Types-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Package-         ( PackageName, PackageIdentifier(..)-         , Package(packageId), packageName, packageVersion-         , PackageFixedDeps(depends)-         , Dependency(Dependency) )-import Distribution.Version-         ( Version, withinRange )-import Distribution.Client.Utils-         ( mergeBy, MergeResult(..) )--import Data.List-         ( foldl' )-import Data.Monoid-         ( Monoid(mempty) )-import Data.Maybe-         ( catMaybes )-import qualified Data.Map as Map-import Data.Map (Map)-import Control.Exception-         ( assert )---- | A set of constraints on package versions. For each package name we record--- what other packages depends on it and what constraints they impose on the--- version of the package.----data (Package installed, Package available)-  => Constraints installed available reason-   = Constraints--       -- Remaining available choices-       (PackageIndex (InstalledOrAvailable installed available))--       -- Paired choices-       (Map PackageName (Version, Version))--       -- Choices that we have excluded for some reason-       -- usually by applying constraints-       (PackageIndex (ExcludedPackage PackageIdentifier reason))--       -- Purely for the invariant, we keep a copy of the original index-       (PackageIndex (InstalledOrAvailable installed available))---data ExcludedPackage pkg reason-   = ExcludedPackage pkg [reason] -- reasons for excluding just the available-                         [reason] -- reasons for excluding installed and avail--instance Package pkg => Package (ExcludedPackage pkg reason) where-  packageId (ExcludedPackage p _ _) = packageId p---- | There is a conservation of packages property. Packages are never gained or--- lost, they just transfer from the remaining pot to the excluded pot.----invariant :: (Package installed, Package available)-          => Constraints installed available a -> Bool-invariant (Constraints available _ excluded original) = all check merged-  where-    merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)-                     (PackageIndex.allPackages original)-                     (mergeBy (\a b -> packageId a `compare` packageId b)-                              (PackageIndex.allPackages available)-                              (PackageIndex.allPackages excluded))-      where-        mergedPackageId (OnlyInLeft  p  ) = packageId p-        mergedPackageId (OnlyInRight   p) = packageId p-        mergedPackageId (InBoth      p _) = packageId p--    check (InBoth (InstalledOnly _) cur) = case cur of-      -- If the package was originally installed only then-      -- now it's either still remaining as installed only-      -- or it has been excluded in which case we excluded both-      -- installed and available since it was only installed-      OnlyInLeft  (InstalledOnly _)            -> True-      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True-      _                                        -> False--    check (InBoth (AvailableOnly _) cur) = case cur of-      -- If the package was originally available only then-      -- now it's either still remaining as available only-      -- or it has been excluded in which case we excluded both-      -- installed and available since it was only available-      OnlyInLeft  (AvailableOnly   _)          -> True-      OnlyInRight (ExcludedPackage _ [] (_:_)) -> True-      _                                        -> True--    -- If the package was originally installed and available-    -- then there are three cases.-    check (InBoth (InstalledAndAvailable _ _) cur) = case cur of-      -- We can have both remaining:-      OnlyInLeft                    (InstalledAndAvailable _ _)  -> True-      -- both excluded, in particular it can have had the available excluded-      -- and later had both excluded so we do not mind if the available excluded-      -- is empty or non-empty.-      OnlyInRight                   (ExcludedPackage _ _  (_:_)) -> True-      -- the installed remaining and the available excluded:-      InBoth      (InstalledOnly _) (ExcludedPackage _ (_:_) []) -> True-      _                                                          -> False--    check _ = False---- | An update to the constraints can move packages between the two piles--- but not gain or loose packages.-transitionsTo :: (Package installed, Package available)-              => Constraints installed available a-              -> Constraints installed available a -> Bool-transitionsTo constraints @(Constraints available  _ excluded  _)-              constraints'@(Constraints available' _ excluded' _) =-     invariant constraints && invariant constraints'-  && null availableGained  && null excludedLost-  && map packageId availableLost == map packageId excludedGained--  where-    availableLost   = foldr lost [] availableChange where-      lost (OnlyInLeft  pkg)          rest = pkg : rest-      lost (InBoth (InstalledAndAvailable _ pkg)-                   (InstalledOnly _)) rest = AvailableOnly pkg : rest-      lost _                          rest = rest-    availableGained = [ pkg | OnlyInRight pkg <- availableChange ]-    excludedLost    = [ pkg | OnlyInLeft  pkg <- excludedChange  ]-    excludedGained  = [ pkg | OnlyInRight pkg <- excludedChange  ]-                   ++ [ pkg | InBoth (ExcludedPackage _ (_:_) [])-                                 pkg@(ExcludedPackage _ (_:_) (_:_))-                                              <- excludedChange  ]-    availableChange = mergeBy (\a b -> packageId a `compare` packageId b)-                              (PackageIndex.allPackages available)-                              (PackageIndex.allPackages available')-    excludedChange  = mergeBy (\a b -> packageId a `compare` packageId b)-                              (PackageIndex.allPackages excluded)-                              (PackageIndex.allPackages excluded')---- | We construct 'Constraints' with an initial 'PackageIndex' of all the--- packages available.----empty :: (PackageFixedDeps installed, Package available)-      => PackageIndex installed-      -> PackageIndex available-      -> Constraints installed available reason-empty installed available = Constraints pkgs pairs mempty pkgs-  where-    pkgs = PackageIndex.fromList-         . map toInstalledOrAvailable-         $ mergeBy (\a b -> packageId a `compare` packageId b)-                   (PackageIndex.allPackages installed)-                   (PackageIndex.allPackages available)-    toInstalledOrAvailable (OnlyInLeft  i  ) = InstalledOnly         i-    toInstalledOrAvailable (OnlyInRight   a) = AvailableOnly           a-    toInstalledOrAvailable (InBoth      i a) = InstalledAndAvailable i a--    -- pick up cases like base-3 and 4 where one version depends on the other:-    pairs = Map.fromList-      [ (name, (packageVersion pkgid1, packageVersion pkgid2))-      | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed-      , let name   = packageName pkg1-            pkgid1 = packageId pkg1-            pkgid2 = packageId pkg2-      ,    any ((pkgid1==) . packageId) (depends pkg2)-        || any ((pkgid2==) . packageId) (depends pkg1) ]---- | The package choices that are still available.----choices :: (Package installed, Package available)-        => Constraints installed available reason-        -> PackageIndex (InstalledOrAvailable installed available)-choices (Constraints available _ _ _) = available--isPaired :: (Package installed, Package available)-         => Constraints installed available reason-         -> PackageIdentifier -> Maybe PackageIdentifier-isPaired (Constraints _ pairs _ _) (PackageIdentifier name version) =-  case Map.lookup name pairs of-    Just (v1, v2)-      | version == v1 -> Just (PackageIdentifier name v2)-      | version == v2 -> Just (PackageIdentifier name v1)-    _                 -> Nothing--data Satisfiable constraints discarded reason-       = Satisfiable constraints discarded-       | Unsatisfiable-       | ConflictsWith [(PackageIdentifier, [reason])]--constrain :: (Package installed, Package available)-          => TaggedDependency-          -> reason-          -> Constraints installed available reason-          -> Satisfiable (Constraints installed available reason)-                         [PackageIdentifier] reason-constrain (TaggedDependency installedConstraint (Dependency name versionRange))-          reason constraints@(Constraints available paired excluded original)--  | not anyRemaining-  = if null conflicts then Unsatisfiable-                      else ConflictsWith conflicts--  | otherwise-  = let constraints' = Constraints available' paired excluded' original-     in assert (constraints `transitionsTo` constraints') $-        Satisfiable constraints' (map packageId newExcluded)--  where-  -- This tells us if any packages would remain at all for this package name if-  -- we applied this constraint. This amounts to checking if any package-  -- satisfies the given constraint, including version range and installation-  -- status.-  ---  anyRemaining = any satisfiesConstraint availableChoices--  conflicts = [ (packageId pkg, reasonsAvail ++ reasonsAll)-              | ExcludedPackage pkg reasonsAvail reasonsAll <- excludedChoices-              , satisfiesVersionConstraint pkg ]--  -- Applying this constraint may involve deleting some choices for this-  -- package name, or restricting which install states are available.-  available' = updateAvailable available-  updateAvailable = flip (foldl' (flip update)) availableChoices where-    update pkg | not (satisfiesVersionConstraint pkg)-               = PackageIndex.deletePackageId (packageId pkg)-    update _   | installedConstraint == NoInstalledConstraint-               = id-    update pkg = case pkg of-      InstalledOnly         _   -> id-      AvailableOnly           _ -> PackageIndex.deletePackageId (packageId pkg)-      InstalledAndAvailable i _ -> PackageIndex.insert (InstalledOnly i)--  -- Applying the constraint means adding exclusions for the packages that-  -- we're just freshly excluding, ie the ones we're removing from available.-  excluded' = foldl' (flip PackageIndex.insert) excluded-                (newExcluded ++ oldExcluded)--  newExcluded = catMaybes (map exclude availableChoices) where-    exclude pkg-      | not (satisfiesVersionConstraint pkg)-      = Just (ExcludedPackage pkgid [] [reason])-      | installedConstraint == NoInstalledConstraint-      = Nothing-      | otherwise = case pkg of-      InstalledOnly         _   -> Nothing-      AvailableOnly           _ -> Just (ExcludedPackage pkgid [] [reason])-      InstalledAndAvailable _ _ ->-        case PackageIndex.lookupPackageId excluded pkgid of-          Just (ExcludedPackage _ avail both)-                  -> Just (ExcludedPackage pkgid (reason:avail) both)-          Nothing -> Just (ExcludedPackage pkgid [reason] [])-      where pkgid = packageId pkg--  -- Additionally we have to add extra exclusions for any already-excluded-  -- packages that happen to be covered by the (inverse of the) constraint.-  oldExcluded = catMaybes (map exclude excludedChoices) where-    exclude (ExcludedPackage pkgid avail both)-      -- if it doesn't satisfy the version constraint then we exclude the-      -- package as a whole, the available or the installed instances or both.-      | not (satisfiesVersionConstraint pkgid)-      = Just (ExcludedPackage pkgid avail (reason:both))-      -- if on the other hand it does satisfy the constraint and we were also-      -- constraining to just the installed version then we exclude just the-      -- available instance.-      | installedConstraint == InstalledConstraint-      = Just (ExcludedPackage pkgid (reason:avail) both)-      | otherwise = Nothing--  -- util definitions-  availableChoices = PackageIndex.lookupPackageName available name-  excludedChoices  = PackageIndex.lookupPackageName excluded  name--  satisfiesConstraint pkg = satisfiesVersionConstraint pkg-                         && satisfiesInstallStateConstraint pkg--  satisfiesVersionConstraint :: Package pkg => pkg -> Bool-  satisfiesVersionConstraint = case Map.lookup name paired of-    Nothing       -> \pkg ->-      packageVersion pkg `withinRange` versionRange-    Just (v1, v2) -> \pkg -> case packageVersion pkg of-      v | v == v1-       || v == v2   -> v1 `withinRange` versionRange-                    || v2 `withinRange` versionRange-        | otherwise -> v `withinRange` versionRange--  satisfiesInstallStateConstraint = case installedConstraint of-    NoInstalledConstraint -> \_   -> True-    InstalledConstraint   -> \pkg -> case pkg of-      AvailableOnly _             -> False-      _                           -> True--conflicting :: (Package installed, Package available)-            => Constraints installed available reason-            -> Dependency-            -> [(PackageIdentifier, [reason])]-conflicting (Constraints _ _ excluded _) dep =-  [ (pkgid, reasonsAvail ++ reasonsAll) --TODO-  | ExcludedPackage pkgid reasonsAvail reasonsAll <--      PackageIndex.lookupDependency excluded dep ]
− cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/TopDown/Types.hs 
@@ -1,93 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.TopDown.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Types for the top-down dependency resolver.-------------------------------------------------------------------------------module Distribution.Client.Dependency.TopDown.Types where--import Distribution.Client.Types-         ( AvailablePackage(..), InstalledPackage )--import Distribution.Package-         ( PackageIdentifier, Dependency-         , Package(packageId), PackageFixedDeps(depends) )-import Distribution.PackageDescription-         ( FlagAssignment )---- --------------------------------------------------------------- * The various kinds of packages--- --------------------------------------------------------------type SelectablePackage-   = InstalledOrAvailable InstalledPackageEx UnconfiguredPackage--type SelectedPackage-   = InstalledOrAvailable InstalledPackageEx SemiConfiguredPackage--data InstalledOrAvailable installed available-   = InstalledOnly         installed-   | AvailableOnly                   available-   | InstalledAndAvailable installed available--type TopologicalSortNumber = Int--data InstalledPackageEx-   = InstalledPackageEx-       InstalledPackage-       !TopologicalSortNumber-       [PackageIdentifier]    -- transative closure of installed deps--data UnconfiguredPackage-   = UnconfiguredPackage-       AvailablePackage-       !TopologicalSortNumber-       FlagAssignment--data SemiConfiguredPackage-   = SemiConfiguredPackage-       AvailablePackage  -- package info-       FlagAssignment    -- total flag assignment for the package-       [Dependency]      -- dependencies we end up with when we apply-                         -- the flag assignment--instance Package InstalledPackageEx where-  packageId (InstalledPackageEx p _ _) = packageId p--instance PackageFixedDeps InstalledPackageEx where-  depends (InstalledPackageEx _ _ deps) = deps--instance Package UnconfiguredPackage where-  packageId (UnconfiguredPackage p _ _) = packageId p--instance Package SemiConfiguredPackage where-  packageId (SemiConfiguredPackage p _ _) = packageId p--instance (Package installed, Package available)-      => Package (InstalledOrAvailable installed available) where-  packageId (InstalledOnly         p  ) = packageId p-  packageId (AvailableOnly         p  ) = packageId p-  packageId (InstalledAndAvailable p _) = packageId p---- --------------------------------------------------------------- * Tagged Dependency type--- ---------------------------------------------------------------- | Installed packages can only depend on other installed packages while--- packages that are not yet installed but which we plan to install can depend--- on installed or other not-yet-installed packages.------ This makes life more complex as we have to remember these constraints.----data TaggedDependency = TaggedDependency InstalledConstraint Dependency-data InstalledConstraint = InstalledConstraint | NoInstalledConstraint-  deriving Eq--untagDependency :: TaggedDependency -> Dependency-untagDependency (TaggedDependency _ dep) = dep
− cabal-install-0.9.5_rc20101226/Distribution/Client/Dependency/Types.hs 
@@ -1,114 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Dependency.Types--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Common types for dependency resolution.-------------------------------------------------------------------------------module Distribution.Client.Dependency.Types (-    DependencyResolver,--    PackageConstraint(..),-    PackagePreferences(..),-    InstalledPreference(..),--    Progress(..),-    foldProgress,-  ) where--import Distribution.Client.Types-         ( AvailablePackage(..), InstalledPackage )-import qualified Distribution.Client.InstallPlan as InstallPlan--import Distribution.PackageDescription-         ( FlagAssignment )-import Distribution.Client.PackageIndex-         ( PackageIndex )-import Distribution.Package-         ( PackageName )-import Distribution.Version-         ( VersionRange )-import Distribution.Compiler-         ( CompilerId )-import Distribution.System-         ( Platform )--import Prelude hiding (fail)---- | A dependency resolver is a function that works out an installation plan--- given the set of installed and available packages and a set of deps to--- solve for.------ The reason for this interface is because there are dozens of approaches to--- solving the package dependency problem and we want to make it easy to swap--- in alternatives.----type DependencyResolver = Platform-                       -> CompilerId-                       -> PackageIndex InstalledPackage-                       -> PackageIndex AvailablePackage-                       -> (PackageName -> PackagePreferences)-                       -> [PackageConstraint]-                       -> [PackageName]-                       -> Progress String String [InstallPlan.PlanPackage]---- | Per-package constraints. Package constraints must be respected by the--- solver. Multiple constraints for each package can be given, though obviously--- it is possible to construct conflicting constraints (eg impossible version--- range or inconsistent flag assignment).----data PackageConstraint-   = PackageVersionConstraint   PackageName VersionRange-   | PackageInstalledConstraint PackageName-   | PackageFlagsConstraint     PackageName FlagAssignment---- | A per-package preference on the version. It is a soft constraint that the--- 'DependencyResolver' should try to respect where possible. It consists of--- a 'InstalledPreference' which says if we prefer versions of packages--- that are already installed. It also hase a 'PackageVersionPreference' which--- is a suggested constraint on the version number. The resolver should try to--- use package versions that satisfy the suggested version constraint.------ It is not specified if preferences on some packages are more important than--- others.----data PackagePreferences = PackagePreferences VersionRange InstalledPreference---- | Wether we prefer an installed version of a package or simply the latest--- version.----data InstalledPreference = PreferInstalled | PreferLatest---- | A type to represent the unfolding of an expensive long running--- calculation that may fail. We may get intermediate steps before the final--- retult which may be used to indicate progress and\/or logging messages.----data Progress step fail done = Step step (Progress step fail done)-                             | Fail fail-                             | Done done---- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with--- two base cases, one for a final result and one for failure.------ Eg to convert into a simple 'Either' result use:------ > foldProgress (flip const) Left Right----foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)-             -> Progress step fail done -> a-foldProgress step fail done = fold-  where fold (Step s p) = step s (fold p)-        fold (Fail f)   = fail f-        fold (Done r)   = done r--instance Functor (Progress step fail) where-  fmap f = foldProgress Step Fail (Done . f)--instance Monad (Progress step fail) where-  return a = Done a-  p >>= f  = foldProgress Step Fail f p
− cabal-install-0.9.5_rc20101226/Distribution/Client/Fetch.hs 
@@ -1,259 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Fetch--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Distribution.Client.Fetch (--    -- * Commands-    fetch,--    -- * Utilities-    fetchPackage,-    isFetched,-    downloadIndex,-  ) where--import Distribution.Client.Types-         ( UnresolvedDependency (..), AvailablePackage(..)-         , AvailablePackageSource(..), AvailablePackageDb(..)-         , Repo(..), RemoteRepo(..), LocalRepo(..)-         , InstalledPackage )-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Client.Dependency as Dependency-         ( resolveDependenciesWithProgress-         , resolveAvailablePackages-         , dependencyConstraints, dependencyTargets-         , PackagesPreference(..), PackagesPreferenceDefault(..)-         , PackagePreference(..) )-import Distribution.Client.Dependency.Types-         ( foldProgress )-import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, disambiguateDependencies-         , getInstalledPackages )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.HttpUtils-         ( downloadURI, isOldHackageURI )-import Distribution.Client.Setup-         ( FetchFlags(..) )--import Distribution.Package-         ( PackageIdentifier, packageId, packageName, packageVersion-         , Dependency(..) )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Simple.Compiler-         ( Compiler(compilerId), PackageDBStack )-import Distribution.Simple.Program-         ( ProgramConfiguration )-import Distribution.Simple.Setup-         ( fromFlag )-import Distribution.Simple.Utils-         ( die, notice, info, debug, setupMessage )-import Distribution.System-         ( buildPlatform )-import Distribution.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity )--import qualified Data.Map as Map-import Control.Monad-         ( when, filterM )-import System.Directory-         ( doesFileExist, createDirectoryIfMissing )-import System.FilePath-         ( (</>), (<.>) )-import qualified System.FilePath.Posix as FilePath.Posix-         ( combine, joinPath )-import Network.URI-         ( URI(uriPath) )----- Downloads a package to [config-dir/packages/package-id] and returns the path to the package.-downloadPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String-downloadPackage _ repo@Repo{ repoKind = Right LocalRepo } pkgid =-  return (packageFile repo pkgid)--downloadPackage verbosity repo@Repo{ repoKind = Left remoteRepo } pkgid = do-  let uri  = packageURI remoteRepo pkgid-      dir  = packageDir       repo pkgid-      path = packageFile      repo pkgid-  debug verbosity $ "GET " ++ show uri-  createDirectoryIfMissing True dir-  downloadURI verbosity uri path-  return path---- Downloads an index file to [config-dir/packages/serv-id].-downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath-downloadIndex verbosity repo cacheDir = do-  let uri = (remoteRepoURI repo) {-              uriPath = uriPath (remoteRepoURI repo)-                          `FilePath.Posix.combine` "00-index.tar.gz"-            }-      path = cacheDir </> "00-index" <.> "tar.gz"-  createDirectoryIfMissing True cacheDir-  downloadURI verbosity uri path-  return path---- |Returns @True@ if the package has already been fetched.-isFetched :: AvailablePackage -> IO Bool-isFetched (AvailablePackage pkgid _ source) = case source of-  LocalUnpackedPackage _  -> return True-  LocalTarballPackage  _  -> return True-  RemoteTarballPackage _  -> return False --TODO: ad-hoc download caching-  RepoTarballPackage repo -> doesFileExist (packageFile repo pkgid)---- |Fetch a package if we don't have it already.-fetchPackage :: Verbosity -> Repo -> PackageIdentifier -> IO String-fetchPackage verbosity repo pkgid = do-  fetched <- doesFileExist (packageFile repo pkgid)-  if fetched-    then do info verbosity $ display pkgid ++ " has already been downloaded."-            return (packageFile repo pkgid)-    else do setupMessage verbosity "Downloading" pkgid-            downloadPackage verbosity repo pkgid---- |Fetch a list of packages and their dependencies.-fetch :: Verbosity-      -> PackageDBStack-      -> [Repo]-      -> Compiler-      -> ProgramConfiguration-      -> FetchFlags-      -> [UnresolvedDependency]-      -> IO ()-fetch verbosity _ _ _ _ _ [] =-  notice verbosity "No packages requested. Nothing to do."--fetch verbosity packageDBs repos comp conf flags deps = do--  installed <- getInstalledPackages verbosity comp packageDBs conf-  availableDb@(AvailablePackageDb available _)-        <- getAvailablePackages verbosity repos-  deps' <- IndexUtils.disambiguateDependencies available deps--  pkgs <- resolvePackages verbosity-            includeDeps comp-            installed availableDb deps'--  pkgs' <- filterM (fmap not . isFetched) pkgs-  when (null pkgs') $-    notice verbosity $ "No packages need to be fetched. "-                    ++ "All the requested packages are already cached."-  if dryRun-    then notice verbosity $ unlines $-            "The following packages would be fetched:"-          : map (display . packageId) pkgs'-    else sequence_-           [ fetchPackage verbosity repo pkgid-           | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- pkgs' ]-  where-    includeDeps = fromFlag (fetchDeps flags)-    dryRun      = fromFlag (fetchDryRun flags)---resolvePackages-  :: Verbosity-  -> Bool-  -> Compiler-  -> PackageIndex InstalledPackage-  -> AvailablePackageDb-  -> [UnresolvedDependency]-  -> IO [AvailablePackage]-resolvePackages verbosity includeDependencies comp-  installed (AvailablePackageDb available availablePrefs) deps--  | includeDependencies = do--      notice verbosity "Resolving dependencies..."-      plan <- foldProgress logMsg die return $-                resolveDependenciesWithProgress-                  buildPlatform (compilerId comp)-                  installed' available-                  preferences constraints-                  targets-      --TODO: suggest using --no-deps, unpack or fetch -o-      -- if cannot satisfy deps-      --TODO: add commandline constraint and preference args for fetch--      return (selectPackagesToFetch plan)--  | otherwise = do--    either (die . unlines . map show) return $-      resolveAvailablePackages-        installed   available-        preferences constraints-        targets--  where-    targets     = dependencyTargets     deps-    constraints = dependencyConstraints deps-    preferences = PackagesPreference-                    PreferLatestForSelected-                    [ PackageVersionPreference name ver-                    | (name, ver) <- Map.toList availablePrefs ]--    installed'  = hideGivenDeps deps installed--    -- Hide the packages given on the command line so that the dep resolver-    -- will decide that they need fetching, even if they're already-    -- installed. Sicne we want to get the source packages of things we might-    -- have installed (but not have the sources for).--    -- TODO: to allow for preferences on selecting an available version-    -- corresponding to a package we've got installed, instead of hiding the-    -- installed instances, we should add a constraint on using an installed-    -- instance.-    hideGivenDeps pkgs index =-      foldr PackageIndex.deletePackageName index-        [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]--    -- The packages we want to fetch are those packages the 'InstallPlan' that-    -- are in the 'InstallPlan.Configured' state.-    selectPackagesToFetch :: InstallPlan.InstallPlan -> [AvailablePackage]-    selectPackagesToFetch plan =-      [ pkg | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))-                 <- InstallPlan.toList plan ]--    logMsg message rest = info verbosity message >> rest----- |Generate the full path to the locally cached copy of--- the tarball for a given @PackageIdentifer@.-packageFile :: Repo -> PackageIdentifier -> FilePath-packageFile repo pkgid = packageDir repo pkgid-                     </> display pkgid-                     <.> "tar.gz"---- |Generate the full path to the directory where the local cached copy of--- the tarball for a given @PackageIdentifer@ is stored.-packageDir :: Repo -> PackageIdentifier -> FilePath-packageDir repo pkgid = repoLocalDir repo-                    </> display (packageName    pkgid)-                    </> display (packageVersion pkgid)---- | Generate the URI of the tarball for a given package.-packageURI :: RemoteRepo -> PackageIdentifier -> URI-packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =-  (remoteRepoURI repo) {-    uriPath = FilePath.Posix.joinPath-      [uriPath (remoteRepoURI repo)-      ,display (packageName    pkgid)-      ,display (packageVersion pkgid)-      ,display pkgid <.> "tar.gz"]-  }-packageURI repo pkgid =-  (remoteRepoURI repo) {-    uriPath = FilePath.Posix.joinPath-      [uriPath (remoteRepoURI repo)-      ,"package"-      ,display pkgid <.> "tar.gz"]-  }
− cabal-install-0.9.5_rc20101226/Distribution/Client/GZipUtils.hs 
@@ -1,44 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.GZipUtils--- Copyright   :  (c) Dmitry Astapov 2010--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Provides a convenience functions for working with files that may or may not--- be zipped.-------------------------------------------------------------------------------module Distribution.Client.GZipUtils (-    maybeDecompress,-  ) where--import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..))-import Data.ByteString.Lazy (ByteString)-import Codec.Compression.GZip-import Codec.Compression.Zlib.Internal---- | Attempts to decompress the `bytes' under the assumption that--- "data format" error at the very beginning of the stream means--- that it is already decompressed. Caller should make sanity checks--- to verify that it is not, in fact, garbage.------ This is to deal with http proxies that lie to us and transparently--- decompress without removing the content-encoding header. See:--- <http://hackage.haskell.org/trac/hackage/ticket/686>----maybeDecompress :: ByteString -> ByteString-maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes-  where-    -- DataError at the beginning of the stream probably means that stream is not compressed.-    -- Returning it as-is.-    -- TODO: alternatively, we might consider looking for the two magic bytes-    -- at the beginning of the gzip header.-    foldStream (StreamError DataError _) = bytes-    foldStream somethingElse = doFold somethingElse--    doFold StreamEnd               = BS.Empty-    doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)-    doFold (StreamError _ msg)  = error $ "Codec.Compression.Zlib: " ++ msg
− cabal-install-0.9.5_rc20101226/Distribution/Client/Haddock.hs 
@@ -1,105 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Haddock--- Copyright   :  (c) Andrea Vezzosi 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Interfacing with Haddock----------------------------------------------------------------------------------module Distribution.Client.Haddock -    (-     regenerateHaddockIndex-    )-    where--import Data.Maybe (listToMaybe)-import Data.List (maximumBy)-import Control.Monad (guard)-import System.Directory (createDirectoryIfMissing, doesFileExist,-                         renameFile)-import System.FilePath ((</>), splitFileName)-import Distribution.Package (Package(..))-import Distribution.Simple.Program (haddockProgram, ProgramConfiguration-                                   , rawSystemProgram, requireProgramVersion)-import Distribution.Version (Version(Version), orLaterVersion)-import Distribution.Verbosity (Verbosity)-import Distribution.Text (display)-import Distribution.Client.PackageIndex(PackageIndex, allPackages,-                                        allPackagesByName, fromList)-import Distribution.Simple.Utils-         ( comparing, intercalate, debug-         , installDirectoryContents, withTempDirectory )-import Distribution.InstalledPackageInfo as InstalledPackageInfo -         ( InstalledPackageInfo-         , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )-import Distribution.Client.Types-         ( InstalledPackage(..) )--regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO ()-regenerateHaddockIndex verbosity pkgs conf index = do-      (paths,warns) <- haddockPackagePaths pkgs'-      case warns of-        Nothing -> return ()-        Just m  -> debug verbosity m-      -      (confHaddock, _, _) <--          requireProgramVersion verbosity haddockProgram-                                    (orLaterVersion (Version [0,6] [])) conf--      createDirectoryIfMissing True destDir--      withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do--        let flags = [ "--gen-contents"-                    , "--gen-index"-                    , "--odir=" ++ tempDir-                    , "--title=Haskell modules on this system" ]-                 ++ [ "--read-interface=" ++ html ++ "," ++ interface-                    | (interface, html) <- paths ]-        rawSystemProgram verbosity confHaddock flags-        renameFile (tempDir </> "index.html") (tempDir </> destFile)-        installDirectoryContents verbosity tempDir destDir-      -  where -    (destDir,destFile) = splitFileName index-    pkgs' = map (maximumBy $ comparing packageId) -            . allPackagesByName -            . fromList-            . filter exposed-            . map (\(InstalledPackage pkg _) -> pkg)-            . allPackages-            $ pkgs--haddockPackagePaths :: [InstalledPackageInfo]-                       -> IO ([(FilePath, FilePath)], Maybe String)-haddockPackagePaths pkgs = do-  interfaces <- sequence-    [ case interfaceAndHtmlPath pkg of-        Just (interface, html) -> do-          exists <- doesFileExist interface-          if exists-            then return (pkgid, Just (interface, html))-            else return (pkgid, Nothing)-        Nothing -> return (pkgid, Nothing)-    | pkg <- pkgs, let pkgid = packageId pkg ]--  let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]--      warning = "The documentation for the following packages are not "-             ++ "installed. No links will be generated to these packages: "-             ++ intercalate ", " (map display missing)--      flags = [ x | (_, Just x) <- interfaces ]--  return (flags, if null missing then Nothing else Just warning)--  where-    interfaceAndHtmlPath pkg = do-      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)-      html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)-      guard (not . null $ html)-      return (interface, html)
− cabal-install-0.9.5_rc20101226/Distribution/Client/HttpUtils.hs 
@@ -1,197 +0,0 @@-{-# OPTIONS -cpp #-}--------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists -------------------------------------------------------------------------------module Distribution.Client.HttpUtils (-    downloadURI,-    getHTTP,-    proxy,-    isOldHackageURI-  ) where--import Network.HTTP-         ( Request (..), Response (..), RequestMethod (..)-         , Header(..), HeaderName(..) )-import Network.URI-         ( URI (..), URIAuth (..), parseAbsoluteURI )-import Network.Stream-         ( Result, ConnError(..) )-import Network.Browser-         ( Proxy (..), Authority (..), browse-         , setOutHandler, setErrHandler, setProxy, request)-import Control.Monad-         ( mplus, join, liftM2 )-import qualified Data.ByteString.Lazy.Char8 as ByteString-import Data.ByteString.Lazy (ByteString)-#ifdef WIN32-import System.Win32.Types-         ( DWORD, HKEY )-import System.Win32.Registry-         ( hKEY_CURRENT_USER, regOpenKey, regCloseKey-         , regQueryValue, regQueryValueEx )-import Control.Exception-         ( bracket )-import Distribution.Compat.Exception-         ( handleIO )-import Foreign-         ( toBool, Storable(peek, sizeOf), castPtr, alloca )-#endif-import System.Environment (getEnvironment)--import qualified Paths_cabal_install (version)-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils-         ( die, info, warn, debug-         , copyFileVerbose, writeFileAtomic )-import Distribution.Text-         ( display )-import qualified System.FilePath.Posix as FilePath.Posix-         ( splitDirectories )---- FIXME: all this proxy stuff is far too complicated, especially parsing--- the proxy strings. Network.Browser should have a way to pick up the--- proxy settings hiding all this system-dependent stuff below.---- try to read the system proxy settings on windows or unix-proxyString, envProxyString, registryProxyString :: IO (Maybe String)-#ifdef WIN32--- read proxy settings from the windows registry-registryProxyString = handleIO (\_ -> return Nothing) $-  bracket (regOpenKey hive path) regCloseKey $ \hkey -> do-    enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"-    if enable-        then fmap Just $ regQueryValue hkey (Just "ProxyServer")-        else return Nothing-  where-    -- some sources say proxy settings should be at -    -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows-    --                   \CurrentVersion\Internet Settings\ProxyServer-    -- but if the user sets them with IE connection panel they seem to-    -- end up in the following place:-    hive  = hKEY_CURRENT_USER-    path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"--    regQueryValueDWORD :: HKEY -> String -> IO DWORD-    regQueryValueDWORD hkey name = alloca $ \ptr -> do-      regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))-      peek ptr-#else-registryProxyString = return Nothing-#endif---- read proxy settings by looking for an env var-envProxyString = do-  env <- getEnvironment-  return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)--proxyString = liftM2 mplus envProxyString registryProxyString----- |Get the local proxy settings  -proxy :: Verbosity -> IO Proxy-proxy verbosity = do-  mstr <- proxyString-  case mstr of-    Nothing   -> return NoProxy-    Just str  -> case parseHttpProxy str of-      Nothing -> do-        warn verbosity $ "invalid http proxy uri: " ++ show str-        warn verbosity $ "proxy uri must be http with a hostname"-        warn verbosity $ "ignoring http proxy, trying a direct connection"-        return NoProxy-      Just p  -> return p---TODO: print info message when we're using a proxy---- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@--- which lack the @\"http://\"@ URI scheme. The problem is that--- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme--- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.------ So our strategy is to try parsing as normal uri first and if it lacks the--- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.----parseHttpProxy :: String -> Maybe Proxy-parseHttpProxy str = join-                   . fmap uri2proxy-                   $ parseHttpURI str-             `mplus` parseHttpURI ("http://" ++ str)-  where-    parseHttpURI str' = case parseAbsoluteURI str' of-      Just uri@URI { uriAuthority = Just _ }-         -> Just (fixUserInfo uri)-      _  -> Nothing--fixUserInfo :: URI -> URI-fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }-    where-      f a@URIAuth{ uriUserInfo = s } =-          a{ uriUserInfo = case reverse s of-                             '@':s' -> reverse s'-                             _      -> s-           }-uri2proxy :: URI -> Maybe Proxy-uri2proxy uri@URI{ uriScheme = "http:"-                 , uriAuthority = Just (URIAuth auth' host port)-                 } = Just (Proxy (host ++ port) auth)-  where auth = if null auth'-                 then Nothing-                 else Just (AuthBasic "" usr pwd uri)-        (usr,pwd') = break (==':') auth'-        pwd        = case pwd' of-                       ':':cs -> cs-                       _      -> pwd'-uri2proxy _ = Nothing--mkRequest :: URI -> Request ByteString-mkRequest uri = Request{ rqURI     = uri-                       , rqMethod  = GET-                       , rqHeaders = [Header HdrUserAgent userAgent]-                       , rqBody    = ByteString.empty }-  where userAgent = "cabal-install/" ++ display Paths_cabal_install.version---- |Carry out a GET request, using the local proxy settings-getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))-getHTTP verbosity uri = do-                 p   <- proxy verbosity-                 let req = mkRequest uri-                 (_, resp) <- browse $ do-                                setErrHandler (warn verbosity . ("http error: "++))-                                setOutHandler (debug verbosity)-                                setProxy p-                                request req-                 return (Right resp)--downloadURI :: Verbosity-            -> URI      -- ^ What to download-            -> FilePath -- ^ Where to put it-            -> IO ()-downloadURI verbosity uri path | uriScheme uri == "file:" =-  copyFileVerbose verbosity (uriPath uri) path-downloadURI verbosity uri path = do-  result <- getHTTP verbosity uri-  let result' = case result of-        Left  err -> Left err-        Right rsp -> case rspCode rsp of-          (2,0,0) -> Right (rspBody rsp)-          (a,b,c) -> Left err-            where-              err = ErrorMisc $ "Unsucessful HTTP code: "-                             ++ concatMap show [a,b,c]--  case result' of-    Left err   -> die $ "Failed to download " ++ show uri ++ " : " ++ show err-    Right body -> do-      info verbosity ("Downloaded to " ++ path)-      writeFileAtomic path (ByteString.unpack body)-      --FIXME: check the content-length header matches the body length.-      --TODO: stream the download into the file rather than buffering the whole-      --      thing in memory.-      --      remember the ETag so we can not re-download if nothing changed.---- Utility function for legacy support.-isOldHackageURI :: URI -> Bool-isOldHackageURI uri-    = case uriAuthority uri of-        Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->-            FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]-        _ -> False
− cabal-install-0.9.5_rc20101226/Distribution/Client/IndexUtils.hs 
@@ -1,299 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.IndexUtils--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@haskell.org--- Stability   :  provisional--- Portability :  portable------ Extra utils related to the package indexes.-------------------------------------------------------------------------------module Distribution.Client.IndexUtils (-  getInstalledPackages,-  getAvailablePackages,--  readPackageIndexFile,-  parseRepoIndex,--  disambiguatePackageName,-  disambiguateDependencies-  ) where--import qualified Distribution.Client.Tar as Tar-import Distribution.Client.Types-         ( UnresolvedDependency(..), AvailablePackage(..)-         , AvailablePackageSource(..), Repo(..), RemoteRepo(..)-         , AvailablePackageDb(..), InstalledPackage(..) )--import Distribution.Package-         ( PackageId, PackageIdentifier(..), PackageName(..), Package(..)-         , Dependency(Dependency), InstalledPackageId(..) )-import Distribution.Client.PackageIndex (PackageIndex)-import qualified Distribution.Client.PackageIndex as PackageIndex-import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex-import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo-import Distribution.PackageDescription-         ( GenericPackageDescription )-import Distribution.PackageDescription.Parse-         ( parsePackageDescription )-import Distribution.Simple.Compiler-         ( Compiler, PackageDBStack )-import Distribution.Simple.Program-         ( ProgramConfiguration )-import qualified Distribution.Simple.Configure as Configure-         ( getInstalledPackages )-import Distribution.ParseUtils-         ( ParseResult(..) )-import Distribution.Version-         ( Version(Version), intersectVersionRanges )-import Distribution.Text-         ( display, simpleParse )-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (die, warn, info, intercalate, fromUTF8)--import Data.Maybe  (catMaybes, fromMaybe)-import Data.List   (isPrefixOf)-import Data.Monoid (Monoid(..))-import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus), when)-import Control.Exception (evaluate)-import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)-import Distribution.Client.GZipUtils (maybeDecompress)-import System.FilePath ((</>), takeExtension, splitDirectories, normalise)-import System.FilePath.Posix as FilePath.Posix-         ( takeFileName )-import System.IO.Error (isDoesNotExistError)-import System.Directory-         ( getModificationTime )-import System.Time-         ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) )--getInstalledPackages :: Verbosity -> Compiler-                     -> PackageDBStack -> ProgramConfiguration-                     -> IO (PackageIndex InstalledPackage)-getInstalledPackages verbosity comp packageDbs conf =-  fmap convert (Configure.getInstalledPackages verbosity comp packageDbs conf)-  where-    convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage-    convert index = PackageIndex.fromList $-      reverse -- because later ones mask earlier ones, but-              -- InstalledPackageIndex.allPackages gives us the most preferred-              -- instances first, when packages share a package id, like when-              -- the same package is installed in the global & user dbs.-      [ InstalledPackage ipkg (sourceDeps index ipkg)-      | ipkg <- InstalledPackageIndex.allPackages index ]--    -- The InstalledPackageInfo only lists dependencies by the-    -- InstalledPackageId, which means we do not directly know the corresponding-    -- source dependency. The only way to find out is to lookup the-    -- InstalledPackageId to get the InstalledPackageInfo and look at its-    -- source PackageId. But if the package is broken because it depends on-    -- other packages that do not exist then we have a problem we cannot find-    -- the original source package id. Instead we make up a bogus package id.-    -- This should have the same effect since it should be a dependency on a-    -- non-existant package.-    sourceDeps index ipkg =-      [ maybe (brokenPackageId depid) packageId mdep-      | let depids = InstalledPackageInfo.depends ipkg-            getpkg = InstalledPackageIndex.lookupInstalledPackageId index-      , (depid, mdep) <- zip depids (map getpkg depids) ]--    brokenPackageId (InstalledPackageId str) =-      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])---- | Read a repository index from disk, from the local files specified by--- a list of 'Repo's.------ All the 'AvailablePackage's are marked as having come from the appropriate--- 'Repo'.------ This is a higher level wrapper used internally in cabal-install.----getAvailablePackages :: Verbosity -> [Repo] -> IO AvailablePackageDb-getAvailablePackages verbosity [] = do-  warn verbosity $ "No remote package servers have been specified. Usually "-                ++ "you would have one specified in the config file."-  return AvailablePackageDb {-    packageIndex       = mempty,-    packagePreferences = mempty-  }-getAvailablePackages verbosity repos = do-  info verbosity "Reading available packages..."-  pkgss <- mapM (readRepoIndex verbosity) repos-  let (pkgs, prefs) = mconcat pkgss-      prefs' = Map.fromListWith intersectVersionRanges-                 [ (name, range) | Dependency name range <- prefs ]-  _ <- evaluate pkgs-  _ <- evaluate prefs'-  return AvailablePackageDb {-    packageIndex       = pkgs,-    packagePreferences = prefs'-  }---- | Read a repository index from disk, from the local file specified by--- the 'Repo'.------ All the 'AvailablePackage's are marked as having come from the given 'Repo'.------ This is a higher level wrapper used internally in cabal-install.----readRepoIndex :: Verbosity -> Repo-              -> IO (PackageIndex AvailablePackage, [Dependency])-readRepoIndex verbosity repo = handleNotFound $ do-  let indexFile = repoLocalDir repo </> "00-index.tar"-  (pkgs, prefs) <- either fail return-                 . foldlTarball extract ([], [])-               =<< BS.readFile indexFile--  pkgIndex <- evaluate $ PackageIndex.fromList-    [ AvailablePackage {-        packageInfoId      = pkgid,-        packageDescription = pkg,-        packageSource      = RepoTarballPackage repo-      }-    | (pkgid, pkg) <- pkgs]--  warnIfIndexIsOld indexFile-  return (pkgIndex, prefs)--  where-    extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $-              (do pkg <- extractPkg entry; return (pkg:pkgs, prefs))-      `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs))--    extractPrefs :: Tar.Entry -> Maybe [Dependency]-    extractPrefs entry = case Tar.entryContent entry of-      Tar.NormalFile content _-         | takeFileName (Tar.entryPath entry) == "preferred-versions"-        -> Just . parsePreferredVersions-         . BS.Char8.unpack $ content-      _ -> Nothing--    handleNotFound action = catch action $ \e -> if isDoesNotExistError e-      then do-        case repoKind repo of-          Left  remoteRepo -> warn verbosity $-               "The package list for '" ++ remoteRepoName remoteRepo-            ++ "' does not exist. Run 'hackport update' to download it."-          Right _localRepo -> warn verbosity $-               "The package list for the local repo '" ++ repoLocalDir repo-            ++ "' is missing. The repo is invalid."-        return mempty-      else ioError e--    isOldThreshold = 15 --days-    warnIfIndexIsOld indexFile = do-      indexTime   <- getModificationTime indexFile-      currentTime <- getClockTime-      let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime)-      when (tdDay diff >= isOldThreshold) $ case repoKind repo of-        Left  remoteRepo -> warn verbosity $-             "The package list for '" ++ remoteRepoName remoteRepo-          ++ "' is " ++ show (tdDay diff)  ++ " days old.\nRun "-          ++ "'hackport update' to get the latest list of available packages."-        Right _localRepo -> return ()--parsePreferredVersions :: String -> [Dependency]-parsePreferredVersions = catMaybes-                       . map simpleParse-                       . filter (not . isPrefixOf "--")-                       . lines---- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'.------ This is supposed to be an \"all in one\" way to easily get at the info in--- the hackage package index.------ It takes a function to map a 'GenericPackageDescription' into any more--- specific instance of 'Package' that you might want to use. In the simple--- case you can just use @\_ p -> p@ here.----readPackageIndexFile :: Package pkg-                     => (PackageId -> GenericPackageDescription -> pkg)-                     -> FilePath -> IO (PackageIndex pkg)-readPackageIndexFile mkPkg indexFile = do-  pkgs <- either fail return-        . parseRepoIndex-        . maybeDecompress-      =<< BS.readFile indexFile-  -  evaluate $ PackageIndex.fromList-   [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs]---- | Parse an uncompressed \"00-index.tar\" repository index file represented--- as a 'ByteString'.----parseRepoIndex :: ByteString-               -> Either String [(PackageId, GenericPackageDescription)]-parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) []--extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription)-extractPkg entry = case Tar.entryContent entry of-  Tar.NormalFile content _-     | takeExtension fileName == ".cabal"-    -> case splitDirectories (normalise fileName) of-        [pkgname,vers,_] -> case simpleParse vers of-          Just ver -> Just (pkgid, descr)-            where-              pkgid  = PackageIdentifier (PackageName pkgname) ver-              parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack-                                               $ content-              descr  = case parsed of-                ParseOk _ d -> d-                _           -> error $ "Couldn't read cabal file "-                                    ++ show fileName-          _ -> Nothing-        _ -> Nothing-  _ -> Nothing-  where-    fileName = Tar.entryPath entry--foldlTarball :: (a -> Tar.Entry -> a) -> a-             -> ByteString -> Either String a-foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read-  where-    check _  (Tar.Fail err)  = Left  err-    check ok Tar.Done        = Right ok-    check ok (Tar.Next e es) = check (e:ok) es---- | Disambiguate a set of packages using 'disambiguatePackage' and report any--- ambiguities to the user.----disambiguateDependencies :: PackageIndex AvailablePackage-                         -> [UnresolvedDependency]-                         -> IO [UnresolvedDependency]-disambiguateDependencies index deps = do-  let names = [ (name, disambiguatePackageName index name)-              | UnresolvedDependency (Dependency name _) _ <- deps ]-   in case [ (name, matches) | (name, Right matches) <- names ] of-        []        -> return-          [ UnresolvedDependency (Dependency name vrange) flags-          | (UnresolvedDependency (Dependency _ vrange) flags,-             (_, Left name)) <- zip deps names ]-        ambigious -> die $ unlines-          [ if null matches-              then "There is no package named " ++ display name ++ ". "-                ++ "Perhaps you need to run 'hackport update' first?"-              else "The package name " ++ display name ++ "is ambigious. "-                ++ "It could be: " ++ intercalate ", " (map display matches)-          | (name, matches) <- ambigious ]---- | Given an index of known packages and a package name, figure out which one it--- might be referring to. If there is an exact case-sensitive match then that's--- ok. If it matches just one package case-insensitively then that's also ok.--- The only problem is if it matches multiple packages case-insensitively, in--- that case it is ambigious.----disambiguatePackageName :: PackageIndex AvailablePackage-                        -> PackageName-                        -> Either PackageName [PackageName]-disambiguatePackageName index (PackageName name) =-    case PackageIndex.searchByName index name of-      PackageIndex.None              -> Right []-      PackageIndex.Unambiguous pkgs  -> Left (pkgName (packageId (head pkgs)))-      PackageIndex.Ambiguous   pkgss -> Right [ pkgName (packageId pkg)-                                           | (pkg:_) <- pkgss ]
− cabal-install-0.9.5_rc20101226/Distribution/Client/Init.hs 
@@ -1,556 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init--- Copyright   :  (c) Brent Yorgey 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Implementation of the 'cabal init' command, which creates an initial .cabal--- file for a project.-----------------------------------------------------------------------------------module Distribution.Client.Init (--    -- * Commands-    initCabal--  ) where--import System.IO-  ( hSetBuffering, stdout, BufferMode(..) )-import System.Directory-  ( getCurrentDirectory )-import Data.Time-  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )--import Data.List-  ( intersperse )-import Data.Maybe-  ( fromMaybe, isJust )-import Data.Traversable-  ( traverse )-import Control.Monad-  ( when )-#if MIN_VERSION_base(3,0,0)-import Control.Monad-  ( (>=>) )-#endif--import Text.PrettyPrint.HughesPJ hiding (mode, cat)--import Data.Version-  ( Version(..) )-import Distribution.Version-  ( orLaterVersion )--import Distribution.Client.Init.Types-  ( InitFlags(..), PackageType(..), Category(..) )-import Distribution.Client.Init.Licenses-  ( bsd3, gplv2, gplv3, lgpl2, lgpl3 )-import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms )--import Distribution.License-  ( License(..), knownLicenses )-import Distribution.ModuleName-  ( ) -- for the Text instance--import Distribution.ReadE-  ( runReadE, readP_to_E )-import Distribution.Simple.Setup-  ( Flag(..), flagToMaybe )-import Distribution.Text-  ( display, Text(..) )--initCabal :: InitFlags -> IO ()-initCabal initFlags = do-  hSetBuffering stdout NoBuffering--  initFlags' <- extendFlags initFlags--  writeLicense initFlags'-  writeSetupFile initFlags'-  success <- writeCabalFile initFlags'--  when success $ generateWarnings initFlags'--------------------------------------------------------------------------------  Flag acquisition  ------------------------------------------------------------------------------------------------------------------------------------- | Fill in more details by guessing, discovering, or prompting the---   user.-extendFlags :: InitFlags -> IO InitFlags-extendFlags =  getPackageName-           >=> getVersion-           >=> getLicense-           >=> getAuthorInfo-           >=> getHomepage-           >=> getSynopsis-           >=> getCategory-           >=> getLibOrExec-           >=> getSrcDir-           >=> getModulesAndBuildTools---- | Combine two actions which may return a value, preferring the first. That---   is, run the second action only if the first doesn't return a value.-infixr 1 ?>>-(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)-f ?>> g = do-  ma <- f-  if isJust ma-    then return ma-    else g---- | Witness the isomorphism between Maybe and Flag.-maybeToFlag :: Maybe a -> Flag a-maybeToFlag = maybe NoFlag Flag---- | Get the package name: use the package directory (supplied, or the current---   directory by default) as a guess.-getPackageName :: InitFlags -> IO InitFlags-getPackageName flags = do-  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)-              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)--  pkgName' <-     return (flagToMaybe $ packageName flags)-              ?>> maybePrompt flags (promptStr "Package name" guess)-              ?>> return guess--  return $ flags { packageName = maybeToFlag pkgName' }---- | Package version: use 0.1 as a last resort, but try prompting the user if---   possible.-getVersion :: InitFlags -> IO InitFlags-getVersion flags = do-  let v = Just $ Version { versionBranch = [0,1], versionTags = [] }-  v' <-     return (flagToMaybe $ version flags)-        ?>> maybePrompt flags (prompt "Package version" v)-        ?>> return v-  return $ flags { version = maybeToFlag v' }---- | Choose a license.-getLicense :: InitFlags -> IO InitFlags-getLicense flags = do-  lic <-     return (flagToMaybe $ license flags)-         ?>> fmap (fmap (either UnknownLicense id))-                  (maybePrompt flags-                    (promptList "Please choose a license"-                                knownLicenses (Just BSD3) True))-  return $ flags { license = maybeToFlag lic }---- | The author's name and email. Prompt, or try to guess from an existing---   darcs repo.-getAuthorInfo :: InitFlags -> IO InitFlags-getAuthorInfo flags = do-  (authorName, authorEmail)  <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail-  authorName'  <-     return (flagToMaybe $ author flags)-                  ?>> maybePrompt flags (promptStr "Author name" authorName)-                  ?>> return authorName--  authorEmail' <-     return (flagToMaybe $ email flags)-                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)-                  ?>> return authorEmail--  return $ flags { author = maybeToFlag authorName'-                 , email  = maybeToFlag authorEmail'-                 }---- | Prompt for a homepage URL.-getHomepage :: InitFlags -> IO InitFlags-getHomepage flags = do-  hp  <- queryHomepage-  hp' <-     return (flagToMaybe $ homepage flags)-         ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp)-         ?>> return hp--  return $ flags { homepage = maybeToFlag hp' }---- | Right now this does nothing, but it could be changed to do some---   intelligent guessing.-queryHomepage :: IO (Maybe String)-queryHomepage = return Nothing     -- get default remote darcs repo?---- | Prompt for a project synopsis.-getSynopsis :: InitFlags -> IO InitFlags-getSynopsis flags = do-  syn <-     return (flagToMaybe $ synopsis flags)-         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)--  return $ flags { synopsis = maybeToFlag syn }---- | Prompt for a package category.---   Note that it should be possible to do some smarter guessing here too, i.e.---   look at the name of the top level source directory.-getCategory :: InitFlags -> IO InitFlags-getCategory flags = do-  cat <-     return (flagToMaybe $ category flags)-         ?>> maybePrompt flags (promptList "Project category" [Codec ..]-                                                              Nothing True)-  return $ flags { category = maybeToFlag cat }---- | Ask whether the project builds a library or executable.-getLibOrExec :: InitFlags -> IO InitFlags-getLibOrExec flags = do-  isLib <-     return (flagToMaybe $ packageType flags)-           ?>> maybePrompt flags (either (const Library) id `fmap`-                                   (promptList "What does the package build"-                                               [Library, Executable]-                                               Nothing False))-           ?>> return (Just Library)--  return $ flags { packageType = maybeToFlag isLib }---- | Try to guess the source root directory (don't prompt the user).-getSrcDir :: InitFlags -> IO InitFlags-getSrcDir flags = do-  srcDirs <-     return (sourceDirs flags)-             ?>> guessSourceDirs--  return $ flags { sourceDirs = srcDirs }---- XXX--- | Try to guess source directories.-guessSourceDirs :: IO (Maybe [String])-guessSourceDirs = return Nothing---- | Get the list of exposed modules and extra tools needed to build them.-getModulesAndBuildTools :: InitFlags -> IO InitFlags-getModulesAndBuildTools flags = do-  dir <- fromMaybe getCurrentDirectory-                   (fmap return . flagToMaybe $ packageDir flags)--  -- XXX really should use guessed source roots.-  sourceFiles <- scanForModules dir--  mods <-      return (exposedModules flags)-           ?>> (return . Just . map moduleName $ sourceFiles)--  tools <-     return (buildTools flags)-           ?>> (return . Just . neededBuildPrograms $ sourceFiles)--  return $ flags { exposedModules = mods-                 , buildTools     = tools }--------------------------------------------------------------------------------  Prompting/user interaction  --------------------------------------------------------------------------------------------------------------------------- | Run a prompt or not based on the nonInteractive flag of the---   InitFlags structure.-maybePrompt :: InitFlags -> IO t -> IO (Maybe t)-maybePrompt flags p =-  case nonInteractive flags of-    Flag True -> return Nothing-    _         -> Just `fmap` p---- | Create a prompt with optional default value that returns a---   String.-promptStr :: String -> Maybe String -> IO String-promptStr = promptDefault' Just id---- | Create a prompt with optional default value that returns a value---   of some Text instance.-prompt :: Text t => String -> Maybe t -> IO t-prompt = promptDefault'-           (either (const Nothing) Just . runReadE (readP_to_E id parse))-           display---- | Create a prompt with an optional default value.-promptDefault' :: (String -> Maybe t)       -- ^ parser-               -> (t -> String)             -- ^ pretty-printer-               -> String                    -- ^ prompt message-               -> Maybe t                   -- ^ optional default value-               -> IO t-promptDefault' parser pretty pr def = do-  putStr $ mkDefPrompt pr (pretty `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d)  -> return d-    _  -> case parser inp of-            Just t  -> return t-            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"-                          promptDefault' parser pretty pr def---- | Create a prompt from a prompt string and a String representation---   of an optional default value.-mkDefPrompt :: String -> Maybe String -> String-mkDefPrompt pr def = pr ++ defStr def ++ "? "-  where defStr Nothing  = ""-        defStr (Just s) = " [default \"" ++ s ++ "\"]"---- | Create a prompt from a list of items.-promptList :: (Text t, Eq t)-           => String            -- ^ prompt-           -> [t]               -- ^ choices-           -> Maybe t           -- ^ optional default value-           -> Bool              -- ^ whether to allow an 'other' option-           -> IO (Either String t)-promptList pr choices def other = do-  putStrLn $ pr ++ ":"-  let options1 = map (\c -> (Just c == def, display c)) choices-      options2 = zip ([1..]::[Int])-                     (options1 ++ if other then [(False, "Other (specify)")]-                                           else [])-  mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2-  promptList' (length options2) choices def other- where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest-                      | otherwise = " " ++ star i ++ rest-                  where rest = show n ++ ") "-                        star True = "*"-                        star False = " "--promptList' :: Text t => Int -> [t] -> Maybe t -> Bool -> IO (Either String t)-promptList' numChoices choices def other = do-  putStr $ mkDefPrompt "Your choice" (display `fmap` def)-  inp <- getLine-  case (inp, def) of-    ("", Just d) -> return $ Right d-    _  -> case readMaybe inp of-            Nothing -> invalidChoice inp-            Just n  -> getChoice n- where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."-                              promptList' numChoices choices def other-       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)-                   | n < numChoices ||-                     (n == numChoices && not other)-                                  = return . Right $ choices !! (n-1)-                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing--readMaybe :: (Read a) => String -> Maybe a-readMaybe s = case reads s of-                [(a,"")] -> Just a-                _        -> Nothing--------------------------------------------------------------------------------  File generation  ------------------------------------------------------------------------------------------------------------------------------------writeLicense :: InitFlags -> IO ()-writeLicense flags = do-  message flags "Generating LICENSE..."-  year <- getYear-  let licenseFile =-        case license flags of-          Flag BSD3 -> Just $ bsd3 (fromMaybe "???"-                                  . flagToMaybe-                                  . author-                                  $ flags)-                              (show year)--          Flag (GPL (Just (Version {versionBranch = [2]})))-            -> Just gplv2--          Flag (GPL (Just (Version {versionBranch = [3]})))-            -> Just gplv3--          Flag (LGPL (Just (Version {versionBranch = [2]})))-            -> Just lgpl2--          Flag (LGPL (Just (Version {versionBranch = [3]})))-            -> Just lgpl3--          _ -> Nothing--  case licenseFile of-    Just licenseText -> writeFile "LICENSE" licenseText-    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."--getYear :: IO Integer-getYear = do-  u <- getCurrentTime-  z <- getCurrentTimeZone-  let l = utcToLocalTime z u-      (y, _, _) = toGregorian $ localDay l-  return y--writeSetupFile :: InitFlags -> IO ()-writeSetupFile flags = do-  message flags "Generating Setup.hs..."-  writeFile "Setup.hs" setupFile- where-  setupFile = unlines-    [ "import Distribution.Simple"-    , "main = defaultMain"-    ]--writeCabalFile :: InitFlags -> IO Bool-writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do-  message flags "Error: no package name provided."-  return False-writeCabalFile flags@(InitFlags{packageName = Flag p}) = do-  let cabalFileName = p ++ ".cabal"-  message flags $ "Generating " ++ cabalFileName ++ "..."-  writeFile cabalFileName (generateCabalFile cabalFileName flags)-  return True---- | Generate a .cabal file from an InitFlags structure.  NOTE: this---   is rather ad-hoc!  What we would REALLY like is to have a---   standard low-level AST type representing .cabal files, which---   preserves things like comments, and to write an *inverse*---   parser/pretty-printer pair between .cabal files and this AST.---   Then instead of this ad-hoc code we could just map an InitFlags---   structure onto a low-level AST structure and use the existing---   pretty-printing code to generate the file.-generateCabalFile :: String -> InitFlags -> String-generateCabalFile fileName c = render $-  (if (minimal c /= Flag True)-    then showComment (Just $ fileName ++ " auto-generated by cabal init.  For additional options, see http://www.haskell.org/cabal/release/cabal-latest/doc/users-guide/authors.html#pkg-descr.")-    else empty)-  $$-  vcat [ fieldS "Name"          (packageName   c)-                (Just "The name of the package.")-                True--       , field  "Version"       (version       c)-                (Just "The package version.  See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.")-                True--       , fieldS "Synopsis"      (synopsis      c)-                (Just "A short (one-line) description of the package.")-                True--       , fieldS "Description"   NoFlag-                (Just "A longer description of the package.")-                True--       , fieldS "Homepage"      (homepage     c)-                (Just "URL for the project homepage or repository.")-                False--       , fieldS "Bug-reports"   NoFlag-                (Just "A URL where users can report bugs.")-                False--       , field  "License"       (license      c)-                (Just "The license under which the package is released.")-                True--       , fieldS "License-file" (Flag "LICENSE")-                (Just "The file containing the license text.")-                True--       , fieldS "Author"        (author       c)-                (Just "The package author(s).")-                True--       , fieldS "Maintainer"    (email        c)-                (Just "An email address to which users can send suggestions, bug reports, and patches.")-                True--       , fieldS "Copyright"     NoFlag-                (Just "A copyright notice.")-                True--       , fieldS "Category"      (either id display `fmap` category c)-                Nothing-                True--       , fieldS "Build-type"    (Flag "Simple")-                Nothing-                True--       , fieldS "Extra-source-files" NoFlag-                (Just "Extra files to be distributed with the package, such as examples or a README.")-                True--       , field  "Cabal-version" (Flag $ orLaterVersion (Version [1,2] []))-                (Just "Constraint on the version of Cabal needed to build this package.")-                False--       , case packageType c of-           Flag Executable ->-             text "\nExecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat-             [ fieldS "Main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True--             , generateBuildInfo c-             ])-           Flag Library    -> text "\nLibrary" $$ (nest 2 $ vcat-             [ fieldS "Exposed-modules" (listField (exposedModules c))-                      (Just "Modules exported by the library.")-                      True--             , generateBuildInfo c-             ])-           _               -> empty-       ]- where-   generateBuildInfo :: InitFlags -> Doc-   generateBuildInfo c' = vcat-     [ fieldS "Build-depends" (listField (dependencies c'))-              (Just "Packages needed in order to build this package.")-              True--     , fieldS "Other-modules" (listField (otherModules c'))-              (Just "Modules not exported by this package.")-              True--     , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))-              (Just "Directories other than the root containing source files.")-              False--     , fieldS "Build-tools" (listFieldS (buildTools c'))-              (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")-              True-     ]--   listField :: Text s => Maybe [s] -> Flag String-   listField = listFieldS . fmap (map display)--   listFieldS :: Maybe [String] -> Flag String-   listFieldS = Flag . maybe "" (concat . intersperse ", ")--   field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc-   field s f = fieldS s (fmap display f)--   fieldS :: String        -- ^ Name of the field-          -> Flag String   -- ^ Field contents-          -> Maybe String  -- ^ Comment to explain the field-          -> Bool          -- ^ Should the field be included (commented out) even if blank?-          -> Doc-   fieldS _ NoFlag _    inc | not inc || (minimal c == Flag True) = empty-   fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty-   fieldS s f com _ = case (isJust com, noComments c, minimal c) of-                        (_, _, Flag True) -> id-                        (_, Flag True, _) -> id-                        (True, _, _)      -> (showComment com $$) . ($$ text "")-                        (False, _, _)     -> ($$ text "")-                      $-                      comment f <> text s <> colon-                                <> text (take (20 - length s) (repeat ' '))-                                <> text (fromMaybe "" . flagToMaybe $ f)-   comment NoFlag    = text "-- "-   comment (Flag "") = text "-- "-   comment _         = text ""--   showComment :: Maybe String -> Doc-   showComment (Just t) = vcat . map text-                        . map ("-- "++) . lines-                        . render . fsep . map text . words $ t-   showComment Nothing  = text ""---- | Generate warnings for missing fields etc.-generateWarnings :: InitFlags -> IO ()-generateWarnings flags = do-  message flags ""-  when (synopsis flags `elem` [NoFlag, Flag ""])-       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")--  message flags "You may want to edit the .cabal file and add a Description field."---- | Possibly generate a message to stdout, taking into account the---   --quiet flag.-message :: InitFlags -> String -> IO ()-message (InitFlags{quiet = Flag True}) _ = return ()-message _ s = putStrLn s--#if MIN_VERSION_base(3,0,0)-#else-(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)-f >=> g     = \x -> f x >>= g-#endif
− cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Heuristics.hs 
@@ -1,191 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Heuristics--- Copyright   :  (c) Benedikt Huber 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Heuristics for creating initial cabal files.----------------------------------------------------------------------------------module Distribution.Client.Init.Heuristics (-    guessPackageName,-    scanForModules,     SourceFileEntry(..),-    neededBuildPrograms,-    guessAuthorNameMail,-    knownCategories,-) where-import Distribution.Simple.Setup(Flag(..))-import Distribution.ModuleName ( ModuleName, fromString )-import Distribution.Client.PackageIndex-    ( allPackagesByName )-import qualified Distribution.PackageDescription as PD-    ( category, packageDescription )-import Distribution.Simple.Utils-         ( intercalate )--import Distribution.Client.Types ( packageDescription, AvailablePackageDb(..) )-import Control.Monad (liftM )-import Data.Char   ( isUpper, isLower, isSpace )-#if MIN_VERSION_base(3,0,3)-import Data.Either ( partitionEithers )-#endif-import Data.Maybe  ( catMaybes )-import Data.Monoid ( mempty, mappend )-import qualified Data.Set as Set ( fromList, toList )-import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist,-                          getHomeDirectory, canonicalizePath )-import System.Environment ( getEnvironment )-import System.FilePath ( takeExtension, takeBaseName, dropExtension,-                         (</>), splitDirectories, makeRelative )---- |Guess the package name based on the given root directory-guessPackageName :: FilePath -> IO String-guessPackageName = liftM (last . splitDirectories) . canonicalizePath---- |Data type of source files found in the working directory-data SourceFileEntry = SourceFileEntry-    { relativeSourcePath :: FilePath-    , moduleName :: ModuleName-    , fileExtension :: String-    } deriving Show---- |Search for source files in the given directory--- and return pairs of guessed haskell source path and--- module names.-scanForModules :: FilePath -> IO [SourceFileEntry]-scanForModules rootDir = scanForModulesIn rootDir rootDir--scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry]-scanForModulesIn projectRoot srcRoot = scan srcRoot []-  where-    scan dir hierarchy = do-        entries <- getDirectoryContents (projectRoot </> dir)-        (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries)-        let modules = catMaybes [ guessModuleName hierarchy file-                                | file <- files-                                , isUpper (head file) ]-        recMods <- mapM (scanRecursive dir hierarchy) dirs-        return $ concat (modules : recMods)-    tagIsDir parent entry = do-        isDir <- doesDirectoryExist (parent </> entry)-        return $ (if isDir then Right else Left) entry-    guessModuleName hierarchy entry-        | takeBaseName entry == "Setup" = Nothing-        | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext-        | otherwise = Nothing-      where-        relRoot = makeRelative projectRoot srcRoot-        unqualModName = dropExtension entry-        modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy)-        ext = case takeExtension entry of '.':e -> e; e -> e-    scanRecursive parent hierarchy entry-      | isUpper (head entry) = scan (parent </> entry) (entry : hierarchy)-      | isLower (head entry) && not (ignoreDir entry) =-          scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy)-      | otherwise = return []-    ignoreDir ('.':_)  = True-    ignoreDir dir      = dir `elem` ["dist", "_darcs"]---- Unfortunately we cannot use the version exported by Distribution.Simple.Program-knownSuffixHandlers :: [(String,String)]-knownSuffixHandlers =-  [ ("gc",     "greencard")-  , ("chs",    "chs")-  , ("hsc",    "hsc2hs")-  , ("x",      "alex")-  , ("y",      "happy")-  , ("ly",     "happy")-  , ("cpphs",  "cpp")-  ]--sourceExtensions :: [String]-sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers--neededBuildPrograms :: [SourceFileEntry] -> [String]-neededBuildPrograms entries =-    [ handler-    | ext <- nubSet (map fileExtension entries)-    , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers)-    ]---- |Guess author and email-guessAuthorNameMail :: IO (Flag String, Flag String)-guessAuthorNameMail =-  update (readFromFile authorRepoFile) mempty >>=-  update (getAuthorHome >>= readFromFile) >>=-  update readFromEnvironment-  where-    update _ info@(Flag _, Flag _) = return info-    update extract info = liftM (`mappend` info) extract -- prefer info-    readFromFile file = do-      exists <- doesFileExist file-      if exists then liftM nameAndMail (readFile file) else return mempty-    readFromEnvironment = fmap extractFromEnvironment getEnvironment-    extractFromEnvironment env =-        let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env)-            emailEnv      = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env)-        in darcsEmailEnv `mappend` emailEnv-    getAuthorHome   = liftM (</> (".darcs" </> "author")) getHomeDirectory-    authorRepoFile  = "_darcs" </> "prefs" </> "author"---- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached-knownCategories :: AvailablePackageDb -> [String]-knownCategories (AvailablePackageDb available _) = nubSet $-    [ cat | pkg <- map head (allPackagesByName available)-          , let catList = (PD.category . PD.packageDescription . packageDescription) pkg-          , cat <- splitString ',' catList-    ]---- Parse name and email, from darcs pref files or environment variable-nameAndMail :: String -> (Flag String, Flag String)-nameAndMail str-  | all isSpace nameOrEmail = mempty-  | null erest = (mempty, Flag $ trim nameOrEmail)-  | otherwise  = (Flag $ trim nameOrEmail, Flag email)-  where-    (nameOrEmail,erest) = break (== '<') str-    (email,_)           = break (== '>') (tail erest)-    trim                = removeLeadingSpace . reverse . removeLeadingSpace . reverse-    removeLeadingSpace  = dropWhile isSpace---- split string at given character, and remove whitespaces-splitString :: Char -> String -> [String]-splitString sep str = go str where-    go s = if null s' then [] else tok : go rest where-      s' = dropWhile (\c -> c == sep || isSpace c) s-      (tok,rest) = break (==sep) s'--nubSet :: (Ord a) => [a] -> [a]-nubSet = Set.toList . Set.fromList--{--test db testProjectRoot = do-  putStrLn "Guessed package name"-  (guessPackageName >=> print) testProjectRoot-  putStrLn "Guessed name and email"-  guessAuthorNameMail >>= print--  mods <- scanForModules testProjectRoot--  putStrLn "Guessed modules"-  mapM_ print mods-  putStrLn "Needed build programs"-  print (neededBuildPrograms mods)--  putStrLn "List of known categories"-  print $ knownCategories db--}--#if MIN_VERSION_base(3,0,3)-#else-partitionEithers :: [Either a b] -> ([a],[b])-partitionEithers = foldr (either left right) ([],[])- where-   left  a (l, r) = (a:l, r)-   right a (l, r) = (l, a:r)-#endif
− cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Licenses.hs 
@@ -1,1722 +0,0 @@-module Distribution.Client.Init.Licenses-  ( License-  , bsd3-  , gplv2-  , gplv3-  , lgpl2-  , lgpl3--  ) where--type License = String--bsd3 :: String -> String -> License-bsd3 authors year = unlines-    [ "Copyright (c)" ++ year ++ ", " ++ authors-    , ""-    , "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 " ++ authors ++ " 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."-    ]--gplv2 :: License-gplv2 = unlines-    [ "             GNU GENERAL PUBLIC LICENSE"-    , "                Version 2, June 1991"-    , ""-    , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.,"-    , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA"-    , " Everyone is permitted to copy and distribute verbatim copies"-    , " of this license document, but changing it is not allowed."-    , ""-    , "                     Preamble"-    , ""-    , "  The licenses for most software are designed to take away your"-    , "freedom to share and change it.  By contrast, the GNU General Public"-    , "License is intended to guarantee your freedom to share and change free"-    , "software--to make sure the software is free for all its users.  This"-    , "General Public License applies to most of the Free Software"-    , "Foundation's software and to any other program whose authors commit to"-    , "using it.  (Some other Free Software Foundation software is covered by"-    , "the GNU Lesser General Public License instead.)  You can apply it to"-    , "your programs, too."-    , ""-    , "  When we speak of free software, we are referring to freedom, not"-    , "price.  Our General Public Licenses are designed to make sure that you"-    , "have the freedom to distribute copies of free software (and charge for"-    , "this service if you wish), that you receive source code or can get it"-    , "if you want it, that you can change the software or use pieces of it"-    , "in new free programs; and that you know you can do these things."-    , ""-    , "  To protect your rights, we need to make restrictions that forbid"-    , "anyone to deny you these rights or to ask you to surrender the rights."-    , "These restrictions translate to certain responsibilities for you if you"-    , "distribute copies of the software, or if you modify it."-    , ""-    , "  For example, if you distribute copies of such a program, whether"-    , "gratis or for a fee, you must give the recipients all the rights that"-    , "you have.  You must make sure that they, too, receive or can get the"-    , "source code.  And you must show them these terms so they know their"-    , "rights."-    , ""-    , "  We protect your rights with two steps: (1) copyright the software, and"-    , "(2) offer you this license which gives you legal permission to copy,"-    , "distribute and/or modify the software."-    , ""-    , "  Also, for each author's protection and ours, we want to make certain"-    , "that everyone understands that there is no warranty for this free"-    , "software.  If the software is modified by someone else and passed on, we"-    , "want its recipients to know that what they have is not the original, so"-    , "that any problems introduced by others will not reflect on the original"-    , "authors' reputations."-    , ""-    , "  Finally, any free program is threatened constantly by software"-    , "patents.  We wish to avoid the danger that redistributors of a free"-    , "program will individually obtain patent licenses, in effect making the"-    , "program proprietary.  To prevent this, we have made it clear that any"-    , "patent must be licensed for everyone's free use or not licensed at all."-    , ""-    , "  The precise terms and conditions for copying, distribution and"-    , "modification follow."-    , ""-    , "             GNU GENERAL PUBLIC LICENSE"-    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"-    , ""-    , "  0. This License applies to any program or other work which contains"-    , "a notice placed by the copyright holder saying it may be distributed"-    , "under the terms of this General Public License.  The \"Program\", below,"-    , "refers to any such program or work, and a \"work based on the Program\""-    , "means either the Program or any derivative work under copyright law:"-    , "that is to say, a work containing the Program or a portion of it,"-    , "either verbatim or with modifications and/or translated into another"-    , "language.  (Hereinafter, translation is included without limitation in"-    , "the term \"modification\".)  Each licensee is addressed as \"you\"."-    , ""-    , "Activities other than copying, distribution and modification are not"-    , "covered by this License; they are outside its scope.  The act of"-    , "running the Program is not restricted, and the output from the Program"-    , "is covered only if its contents constitute a work based on the"-    , "Program (independent of having been made by running the Program)."-    , "Whether that is true depends on what the Program does."-    , ""-    , "  1. You may copy and distribute verbatim copies of the Program's"-    , "source code as you receive it, in any medium, provided that you"-    , "conspicuously and appropriately publish on each copy an appropriate"-    , "copyright notice and disclaimer of warranty; keep intact all the"-    , "notices that refer to this License and to the absence of any warranty;"-    , "and give any other recipients of the Program a copy of this License"-    , "along with the Program."-    , ""-    , "You may charge a fee for the physical act of transferring a copy, and"-    , "you may at your option offer warranty protection in exchange for a fee."-    , ""-    , "  2. You may modify your copy or copies of the Program or any portion"-    , "of it, thus forming a work based on the Program, and copy and"-    , "distribute such modifications or work under the terms of Section 1"-    , "above, provided that you also meet all of these conditions:"-    , ""-    , "    a) You must cause the modified files to carry prominent notices"-    , "    stating that you changed the files and the date of any change."-    , ""-    , "    b) You must cause any work that you distribute or publish, that in"-    , "    whole or in part contains or is derived from the Program or any"-    , "    part thereof, to be licensed as a whole at no charge to all third"-    , "    parties under the terms of this License."-    , ""-    , "    c) If the modified program normally reads commands interactively"-    , "    when run, you must cause it, when started running for such"-    , "    interactive use in the most ordinary way, to print or display an"-    , "    announcement including an appropriate copyright notice and a"-    , "    notice that there is no warranty (or else, saying that you provide"-    , "    a warranty) and that users may redistribute the program under"-    , "    these conditions, and telling the user how to view a copy of this"-    , "    License.  (Exception: if the Program itself is interactive but"-    , "    does not normally print such an announcement, your work based on"-    , "    the Program is not required to print an announcement.)"-    , ""-    , "These requirements apply to the modified work as a whole.  If"-    , "identifiable sections of that work are not derived from the Program,"-    , "and can be reasonably considered independent and separate works in"-    , "themselves, then this License, and its terms, do not apply to those"-    , "sections when you distribute them as separate works.  But when you"-    , "distribute the same sections as part of a whole which is a work based"-    , "on the Program, the distribution of the whole must be on the terms of"-    , "this License, whose permissions for other licensees extend to the"-    , "entire whole, and thus to each and every part regardless of who wrote it."-    , ""-    , "Thus, it is not the intent of this section to claim rights or contest"-    , "your rights to work written entirely by you; rather, the intent is to"-    , "exercise the right to control the distribution of derivative or"-    , "collective works based on the Program."-    , ""-    , "In addition, mere aggregation of another work not based on the Program"-    , "with the Program (or with a work based on the Program) on a volume of"-    , "a storage or distribution medium does not bring the other work under"-    , "the scope of this License."-    , ""-    , "  3. You may copy and distribute the Program (or a work based on it,"-    , "under Section 2) in object code or executable form under the terms of"-    , "Sections 1 and 2 above provided that you also do one of the following:"-    , ""-    , "    a) Accompany it with the complete corresponding machine-readable"-    , "    source code, which must be distributed under the terms of Sections"-    , "    1 and 2 above on a medium customarily used for software interchange; or,"-    , ""-    , "    b) Accompany it with a written offer, valid for at least three"-    , "    years, to give any third party, for a charge no more than your"-    , "    cost of physically performing source distribution, a complete"-    , "    machine-readable copy of the corresponding source code, to be"-    , "    distributed under the terms of Sections 1 and 2 above on a medium"-    , "    customarily used for software interchange; or,"-    , ""-    , "    c) Accompany it with the information you received as to the offer"-    , "    to distribute corresponding source code.  (This alternative is"-    , "    allowed only for noncommercial distribution and only if you"-    , "    received the program in object code or executable form with such"-    , "    an offer, in accord with Subsection b above.)"-    , ""-    , "The source code for a work means the preferred form of the work for"-    , "making modifications to it.  For an executable work, complete source"-    , "code means all the source code for all modules it contains, plus any"-    , "associated interface definition files, plus the scripts used to"-    , "control compilation and installation of the executable.  However, as a"-    , "special exception, the source code distributed need not include"-    , "anything that is normally distributed (in either source or binary"-    , "form) with the major components (compiler, kernel, and so on) of the"-    , "operating system on which the executable runs, unless that component"-    , "itself accompanies the executable."-    , ""-    , "If distribution of executable or object code is made by offering"-    , "access to copy from a designated place, then offering equivalent"-    , "access to copy the source code from the same place counts as"-    , "distribution of the source code, even though third parties are not"-    , "compelled to copy the source along with the object code."-    , ""-    , "  4. You may not copy, modify, sublicense, or distribute the Program"-    , "except as expressly provided under this License.  Any attempt"-    , "otherwise to copy, modify, sublicense or distribute the Program is"-    , "void, and will automatically terminate your rights under this License."-    , "However, parties who have received copies, or rights, from you under"-    , "this License will not have their licenses terminated so long as such"-    , "parties remain in full compliance."-    , ""-    , "  5. You are not required to accept this License, since you have not"-    , "signed it.  However, nothing else grants you permission to modify or"-    , "distribute the Program or its derivative works.  These actions are"-    , "prohibited by law if you do not accept this License.  Therefore, by"-    , "modifying or distributing the Program (or any work based on the"-    , "Program), you indicate your acceptance of this License to do so, and"-    , "all its terms and conditions for copying, distributing or modifying"-    , "the Program or works based on it."-    , ""-    , "  6. Each time you redistribute the Program (or any work based on the"-    , "Program), the recipient automatically receives a license from the"-    , "original licensor to copy, distribute or modify the Program subject to"-    , "these terms and conditions.  You may not impose any further"-    , "restrictions on the recipients' exercise of the rights granted herein."-    , "You are not responsible for enforcing compliance by third parties to"-    , "this License."-    , ""-    , "  7. If, as a consequence of a court judgment or allegation of patent"-    , "infringement or for any other reason (not limited to patent issues),"-    , "conditions are imposed on you (whether by court order, agreement or"-    , "otherwise) that contradict the conditions of this License, they do not"-    , "excuse you from the conditions of this License.  If you cannot"-    , "distribute so as to satisfy simultaneously your obligations under this"-    , "License and any other pertinent obligations, then as a consequence you"-    , "may not distribute the Program at all.  For example, if a patent"-    , "license would not permit royalty-free redistribution of the Program by"-    , "all those who receive copies directly or indirectly through you, then"-    , "the only way you could satisfy both it and this License would be to"-    , "refrain entirely from distribution of the Program."-    , ""-    , "If any portion of this section is held invalid or unenforceable under"-    , "any particular circumstance, the balance of the section is intended to"-    , "apply and the section as a whole is intended to apply in other"-    , "circumstances."-    , ""-    , "It is not the purpose of this section to induce you to infringe any"-    , "patents or other property right claims or to contest validity of any"-    , "such claims; this section has the sole purpose of protecting the"-    , "integrity of the free software distribution system, which is"-    , "implemented by public license practices.  Many people have made"-    , "generous contributions to the wide range of software distributed"-    , "through that system in reliance on consistent application of that"-    , "system; it is up to the author/donor to decide if he or she is willing"-    , "to distribute software through any other system and a licensee cannot"-    , "impose that choice."-    , ""-    , "This section is intended to make thoroughly clear what is believed to"-    , "be a consequence of the rest of this License."-    , ""-    , "  8. If the distribution and/or use of the Program is restricted in"-    , "certain countries either by patents or by copyrighted interfaces, the"-    , "original copyright holder who places the Program under this License"-    , "may add an explicit geographical distribution limitation excluding"-    , "those countries, so that distribution is permitted only in or among"-    , "countries not thus excluded.  In such case, this License incorporates"-    , "the limitation as if written in the body of this License."-    , ""-    , "  9. The Free Software Foundation may publish revised and/or new versions"-    , "of the General Public License from time to time.  Such new versions will"-    , "be similar in spirit to the present version, but may differ in detail to"-    , "address new problems or concerns."-    , ""-    , "Each version is given a distinguishing version number.  If the Program"-    , "specifies a version number of this License which applies to it and \"any"-    , "later version\", you have the option of following the terms and conditions"-    , "either of that version or of any later version published by the Free"-    , "Software Foundation.  If the Program does not specify a version number of"-    , "this License, you may choose any version ever published by the Free Software"-    , "Foundation."-    , ""-    , "  10. If you wish to incorporate parts of the Program into other free"-    , "programs whose distribution conditions are different, write to the author"-    , "to ask for permission.  For software which is copyrighted by the Free"-    , "Software Foundation, write to the Free Software Foundation; we sometimes"-    , "make exceptions for this.  Our decision will be guided by the two goals"-    , "of preserving the free status of all derivatives of our free software and"-    , "of promoting the sharing and reuse of software generally."-    , ""-    , "                     NO WARRANTY"-    , ""-    , "  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY"-    , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN"-    , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES"-    , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED"-    , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF"-    , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS"-    , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE"-    , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,"-    , "REPAIR OR CORRECTION."-    , ""-    , "  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"-    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR"-    , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,"-    , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING"-    , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED"-    , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY"-    , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER"-    , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE"-    , "POSSIBILITY OF SUCH DAMAGES."-    , ""-    , "              END OF TERMS AND CONDITIONS"-    , ""-    , "     How to Apply These Terms to Your New Programs"-    , ""-    , "  If you develop a new program, and you want it to be of the greatest"-    , "possible use to the public, the best way to achieve this is to make it"-    , "free software which everyone can redistribute and change under these terms."-    , ""-    , "  To do so, attach the following notices to the program.  It is safest"-    , "to attach them to the start of each source file to most effectively"-    , "convey the exclusion of warranty; and each file should have at least"-    , "the \"copyright\" line and a pointer to where the full notice is found."-    , ""-    , "    <one line to give the program's name and a brief idea of what it does.>"-    , "    Copyright (C) <year>  <name of author>"-    , ""-    , "    This program is free software; you can redistribute it and/or modify"-    , "    it under the terms of the GNU General Public License as published by"-    , "    the Free Software Foundation; either version 2 of the License, or"-    , "    (at your option) any later version."-    , ""-    , "    This program is distributed in the hope that it will be useful,"-    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"-    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"-    , "    GNU General Public License for more details."-    , ""-    , "    You should have received a copy of the GNU General Public License along"-    , "    with this program; if not, write to the Free Software Foundation, Inc.,"-    , "    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA."-    , ""-    , "Also add information on how to contact you by electronic and paper mail."-    , ""-    , "If the program is interactive, make it output a short notice like this"-    , "when it starts in an interactive mode:"-    , ""-    , "    Gnomovision version 69, Copyright (C) year name of author"-    , "    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'."-    , "    This is free software, and you are welcome to redistribute it"-    , "    under certain conditions; type `show c' for details."-    , ""-    , "The hypothetical commands `show w' and `show c' should show the appropriate"-    , "parts of the General Public License.  Of course, the commands you use may"-    , "be called something other than `show w' and `show c'; they could even be"-    , "mouse-clicks or menu items--whatever suits your program."-    , ""-    , "You should also get your employer (if you work as a programmer) or your"-    , "school, if any, to sign a \"copyright disclaimer\" for the program, if"-    , "necessary.  Here is a sample; alter the names:"-    , ""-    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the program"-    , "  `Gnomovision' (which makes passes at compilers) written by James Hacker."-    , ""-    , "  <signature of Ty Coon>, 1 April 1989"-    , "  Ty Coon, President of Vice"-    , ""-    , "This General Public License does not permit incorporating your program into"-    , "proprietary programs.  If your program is a subroutine library, you may"-    , "consider it more useful to permit linking proprietary applications with the"-    , "library.  If this is what you want to do, use the GNU Lesser General"-    , "Public License instead of this License."-    ]--gplv3 :: License-gplv3 = unlines-    [ "              GNU GENERAL PUBLIC LICENSE"-    , "                Version 3, 29 June 2007"-    , ""-    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"-    , " Everyone is permitted to copy and distribute verbatim copies"-    , " of this license document, but changing it is not allowed."-    , ""-    , "                     Preamble"-    , ""-    , "  The GNU General Public License is a free, copyleft license for"-    , "software and other kinds of works."-    , ""-    , "  The licenses for most software and other practical works are designed"-    , "to take away your freedom to share and change the works.  By contrast,"-    , "the GNU General Public License is intended to guarantee your freedom to"-    , "share and change all versions of a program--to make sure it remains free"-    , "software for all its users.  We, the Free Software Foundation, use the"-    , "GNU General Public License for most of our software; it applies also to"-    , "any other work released this way by its authors.  You can apply it to"-    , "your programs, too."-    , ""-    , "  When we speak of free software, we are referring to freedom, not"-    , "price.  Our General Public Licenses are designed to make sure that you"-    , "have the freedom to distribute copies of free software (and charge for"-    , "them if you wish), that you receive source code or can get it if you"-    , "want it, that you can change the software or use pieces of it in new"-    , "free programs, and that you know you can do these things."-    , ""-    , "  To protect your rights, we need to prevent others from denying you"-    , "these rights or asking you to surrender the rights.  Therefore, you have"-    , "certain responsibilities if you distribute copies of the software, or if"-    , "you modify it: responsibilities to respect the freedom of others."-    , ""-    , "  For example, if you distribute copies of such a program, whether"-    , "gratis or for a fee, you must pass on to the recipients the same"-    , "freedoms that you received.  You must make sure that they, too, receive"-    , "or can get the source code.  And you must show them these terms so they"-    , "know their rights."-    , ""-    , "  Developers that use the GNU GPL protect your rights with two steps:"-    , "(1) assert copyright on the software, and (2) offer you this License"-    , "giving you legal permission to copy, distribute and/or modify it."-    , ""-    , "  For the developers' and authors' protection, the GPL clearly explains"-    , "that there is no warranty for this free software.  For both users' and"-    , "authors' sake, the GPL requires that modified versions be marked as"-    , "changed, so that their problems will not be attributed erroneously to"-    , "authors of previous versions."-    , ""-    , "  Some devices are designed to deny users access to install or run"-    , "modified versions of the software inside them, although the manufacturer"-    , "can do so.  This is fundamentally incompatible with the aim of"-    , "protecting users' freedom to change the software.  The systematic"-    , "pattern of such abuse occurs in the area of products for individuals to"-    , "use, which is precisely where it is most unacceptable.  Therefore, we"-    , "have designed this version of the GPL to prohibit the practice for those"-    , "products.  If such problems arise substantially in other domains, we"-    , "stand ready to extend this provision to those domains in future versions"-    , "of the GPL, as needed to protect the freedom of users."-    , ""-    , "  Finally, every program is threatened constantly by software patents."-    , "States should not allow patents to restrict development and use of"-    , "software on general-purpose computers, but in those that do, we wish to"-    , "avoid the special danger that patents applied to a free program could"-    , "make it effectively proprietary.  To prevent this, the GPL assures that"-    , "patents cannot be used to render the program non-free."-    , ""-    , "  The precise terms and conditions for copying, distribution and"-    , "modification follow."-    , ""-    , "                TERMS AND CONDITIONS"-    , ""-    , "  0. Definitions."-    , ""-    , "  \"This License\" refers to version 3 of the GNU General Public License."-    , ""-    , "  \"Copyright\" also means copyright-like laws that apply to other kinds of"-    , "works, such as semiconductor masks."-    , " "-    , "  \"The Program\" refers to any copyrightable work licensed under this"-    , "License.  Each licensee is addressed as \"you\".  \"Licensees\" and"-    , "\"recipients\" may be individuals or organizations."-    , ""-    , "  To \"modify\" a work means to copy from or adapt all or part of the work"-    , "in a fashion requiring copyright permission, other than the making of an"-    , "exact copy.  The resulting work is called a \"modified version\" of the"-    , "earlier work or a work \"based on\" the earlier work."-    , ""-    , "  A \"covered work\" means either the unmodified Program or a work based"-    , "on the Program."-    , ""-    , "  To \"propagate\" a work means to do anything with it that, without"-    , "permission, would make you directly or secondarily liable for"-    , "infringement under applicable copyright law, except executing it on a"-    , "computer or modifying a private copy.  Propagation includes copying,"-    , "distribution (with or without modification), making available to the"-    , "public, and in some countries other activities as well."-    , ""-    , "  To \"convey\" a work means any kind of propagation that enables other"-    , "parties to make or receive copies.  Mere interaction with a user through"-    , "a computer network, with no transfer of a copy, is not conveying."-    , ""-    , "  An interactive user interface displays \"Appropriate Legal Notices\""-    , "to the extent that it includes a convenient and prominently visible"-    , "feature that (1) displays an appropriate copyright notice, and (2)"-    , "tells the user that there is no warranty for the work (except to the"-    , "extent that warranties are provided), that licensees may convey the"-    , "work under this License, and how to view a copy of this License.  If"-    , "the interface presents a list of user commands or options, such as a"-    , "menu, a prominent item in the list meets this criterion."-    , ""-    , "  1. Source Code."-    , ""-    , "  The \"source code\" for a work means the preferred form of the work"-    , "for making modifications to it.  \"Object code\" means any non-source"-    , "form of a work."-    , ""-    , "  A \"Standard Interface\" means an interface that either is an official"-    , "standard defined by a recognized standards body, or, in the case of"-    , "interfaces specified for a particular programming language, one that"-    , "is widely used among developers working in that language."-    , ""-    , "  The \"System Libraries\" of an executable work include anything, other"-    , "than the work as a whole, that (a) is included in the normal form of"-    , "packaging a Major Component, but which is not part of that Major"-    , "Component, and (b) serves only to enable use of the work with that"-    , "Major Component, or to implement a Standard Interface for which an"-    , "implementation is available to the public in source code form.  A"-    , "\"Major Component\", in this context, means a major essential component"-    , "(kernel, window system, and so on) of the specific operating system"-    , "(if any) on which the executable work runs, or a compiler used to"-    , "produce the work, or an object code interpreter used to run it."-    , ""-    , "  The \"Corresponding Source\" for a work in object code form means all"-    , "the source code needed to generate, install, and (for an executable"-    , "work) run the object code and to modify the work, including scripts to"-    , "control those activities.  However, it does not include the work's"-    , "System Libraries, or general-purpose tools or generally available free"-    , "programs which are used unmodified in performing those activities but"-    , "which are not part of the work.  For example, Corresponding Source"-    , "includes interface definition files associated with source files for"-    , "the work, and the source code for shared libraries and dynamically"-    , "linked subprograms that the work is specifically designed to require,"-    , "such as by intimate data communication or control flow between those"-    , "subprograms and other parts of the work."-    , ""-    , "  The Corresponding Source need not include anything that users"-    , "can regenerate automatically from other parts of the Corresponding"-    , "Source."-    , ""-    , "  The Corresponding Source for a work in source code form is that"-    , "same work."-    , ""-    , "  2. Basic Permissions."-    , ""-    , "  All rights granted under this License are granted for the term of"-    , "copyright on the Program, and are irrevocable provided the stated"-    , "conditions are met.  This License explicitly affirms your unlimited"-    , "permission to run the unmodified Program.  The output from running a"-    , "covered work is covered by this License only if the output, given its"-    , "content, constitutes a covered work.  This License acknowledges your"-    , "rights of fair use or other equivalent, as provided by copyright law."-    , ""-    , "  You may make, run and propagate covered works that you do not"-    , "convey, without conditions so long as your license otherwise remains"-    , "in force.  You may convey covered works to others for the sole purpose"-    , "of having them make modifications exclusively for you, or provide you"-    , "with facilities for running those works, provided that you comply with"-    , "the terms of this License in conveying all material for which you do"-    , "not control copyright.  Those thus making or running the covered works"-    , "for you must do so exclusively on your behalf, under your direction"-    , "and control, on terms that prohibit them from making any copies of"-    , "your copyrighted material outside their relationship with you."-    , ""-    , "  Conveying under any other circumstances is permitted solely under"-    , "the conditions stated below.  Sublicensing is not allowed; section 10"-    , "makes it unnecessary."-    , ""-    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."-    , ""-    , "  No covered work shall be deemed part of an effective technological"-    , "measure under any applicable law fulfilling obligations under article"-    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"-    , "similar laws prohibiting or restricting circumvention of such"-    , "measures."-    , ""-    , "  When you convey a covered work, you waive any legal power to forbid"-    , "circumvention of technological measures to the extent such circumvention"-    , "is effected by exercising rights under this License with respect to"-    , "the covered work, and you disclaim any intention to limit operation or"-    , "modification of the work as a means of enforcing, against the work's"-    , "users, your or third parties' legal rights to forbid circumvention of"-    , "technological measures."-    , ""-    , "  4. Conveying Verbatim Copies."-    , ""-    , "  You may convey verbatim copies of the Program's source code as you"-    , "receive it, in any medium, provided that you conspicuously and"-    , "appropriately publish on each copy an appropriate copyright notice;"-    , "keep intact all notices stating that this License and any"-    , "non-permissive terms added in accord with section 7 apply to the code;"-    , "keep intact all notices of the absence of any warranty; and give all"-    , "recipients a copy of this License along with the Program."-    , ""-    , "  You may charge any price or no price for each copy that you convey,"-    , "and you may offer support or warranty protection for a fee."-    , ""-    , "  5. Conveying Modified Source Versions."-    , ""-    , "  You may convey a work based on the Program, or the modifications to"-    , "produce it from the Program, in the form of source code under the"-    , "terms of section 4, provided that you also meet all of these conditions:"-    , ""-    , "    a) The work must carry prominent notices stating that you modified"-    , "    it, and giving a relevant date."-    , ""-    , "    b) The work must carry prominent notices stating that it is"-    , "    released under this License and any conditions added under section"-    , "    7.  This requirement modifies the requirement in section 4 to"-    , "    \"keep intact all notices\"."-    , ""-    , "    c) You must license the entire work, as a whole, under this"-    , "    License to anyone who comes into possession of a copy.  This"-    , "    License will therefore apply, along with any applicable section 7"-    , "    additional terms, to the whole of the work, and all its parts,"-    , "    regardless of how they are packaged.  This License gives no"-    , "    permission to license the work in any other way, but it does not"-    , "    invalidate such permission if you have separately received it."-    , ""-    , "    d) If the work has interactive user interfaces, each must display"-    , "    Appropriate Legal Notices; however, if the Program has interactive"-    , "    interfaces that do not display Appropriate Legal Notices, your"-    , "    work need not make them do so."-    , ""-    , "  A compilation of a covered work with other separate and independent"-    , "works, which are not by their nature extensions of the covered work,"-    , "and which are not combined with it such as to form a larger program,"-    , "in or on a volume of a storage or distribution medium, is called an"-    , "\"aggregate\" if the compilation and its resulting copyright are not"-    , "used to limit the access or legal rights of the compilation's users"-    , "beyond what the individual works permit.  Inclusion of a covered work"-    , "in an aggregate does not cause this License to apply to the other"-    , "parts of the aggregate."-    , ""-    , "  6. Conveying Non-Source Forms."-    , ""-    , "  You may convey a covered work in object code form under the terms"-    , "of sections 4 and 5, provided that you also convey the"-    , "machine-readable Corresponding Source under the terms of this License,"-    , "in one of these ways:"-    , ""-    , "    a) Convey the object code in, or embodied in, a physical product"-    , "    (including a physical distribution medium), accompanied by the"-    , "    Corresponding Source fixed on a durable physical medium"-    , "    customarily used for software interchange."-    , ""-    , "    b) Convey the object code in, or embodied in, a physical product"-    , "    (including a physical distribution medium), accompanied by a"-    , "    written offer, valid for at least three years and valid for as"-    , "    long as you offer spare parts or customer support for that product"-    , "    model, to give anyone who possesses the object code either (1) a"-    , "    copy of the Corresponding Source for all the software in the"-    , "    product that is covered by this License, on a durable physical"-    , "    medium customarily used for software interchange, for a price no"-    , "    more than your reasonable cost of physically performing this"-    , "    conveying of source, or (2) access to copy the"-    , "    Corresponding Source from a network server at no charge."-    , ""-    , "    c) Convey individual copies of the object code with a copy of the"-    , "    written offer to provide the Corresponding Source.  This"-    , "    alternative is allowed only occasionally and noncommercially, and"-    , "    only if you received the object code with such an offer, in accord"-    , "    with subsection 6b."-    , ""-    , "    d) Convey the object code by offering access from a designated"-    , "    place (gratis or for a charge), and offer equivalent access to the"-    , "    Corresponding Source in the same way through the same place at no"-    , "    further charge.  You need not require recipients to copy the"-    , "    Corresponding Source along with the object code.  If the place to"-    , "    copy the object code is a network server, the Corresponding Source"-    , "    may be on a different server (operated by you or a third party)"-    , "    that supports equivalent copying facilities, provided you maintain"-    , "    clear directions next to the object code saying where to find the"-    , "    Corresponding Source.  Regardless of what server hosts the"-    , "    Corresponding Source, you remain obligated to ensure that it is"-    , "    available for as long as needed to satisfy these requirements."-    , ""-    , "    e) Convey the object code using peer-to-peer transmission, provided"-    , "    you inform other peers where the object code and Corresponding"-    , "    Source of the work are being offered to the general public at no"-    , "    charge under subsection 6d."-    , ""-    , "  A separable portion of the object code, whose source code is excluded"-    , "from the Corresponding Source as a System Library, need not be"-    , "included in conveying the object code work."-    , ""-    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"-    , "tangible personal property which is normally used for personal, family,"-    , "or household purposes, or (2) anything designed or sold for incorporation"-    , "into a dwelling.  In determining whether a product is a consumer product,"-    , "doubtful cases shall be resolved in favor of coverage.  For a particular"-    , "product received by a particular user, \"normally used\" refers to a"-    , "typical or common use of that class of product, regardless of the status"-    , "of the particular user or of the way in which the particular user"-    , "actually uses, or expects or is expected to use, the product.  A product"-    , "is a consumer product regardless of whether the product has substantial"-    , "commercial, industrial or non-consumer uses, unless such uses represent"-    , "the only significant mode of use of the product."-    , ""-    , "  \"Installation Information\" for a User Product means any methods,"-    , "procedures, authorization keys, or other information required to install"-    , "and execute modified versions of a covered work in that User Product from"-    , "a modified version of its Corresponding Source.  The information must"-    , "suffice to ensure that the continued functioning of the modified object"-    , "code is in no case prevented or interfered with solely because"-    , "modification has been made."-    , ""-    , "  If you convey an object code work under this section in, or with, or"-    , "specifically for use in, a User Product, and the conveying occurs as"-    , "part of a transaction in which the right of possession and use of the"-    , "User Product is transferred to the recipient in perpetuity or for a"-    , "fixed term (regardless of how the transaction is characterized), the"-    , "Corresponding Source conveyed under this section must be accompanied"-    , "by the Installation Information.  But this requirement does not apply"-    , "if neither you nor any third party retains the ability to install"-    , "modified object code on the User Product (for example, the work has"-    , "been installed in ROM)."-    , ""-    , "  The requirement to provide Installation Information does not include a"-    , "requirement to continue to provide support service, warranty, or updates"-    , "for a work that has been modified or installed by the recipient, or for"-    , "the User Product in which it has been modified or installed.  Access to a"-    , "network may be denied when the modification itself materially and"-    , "adversely affects the operation of the network or violates the rules and"-    , "protocols for communication across the network."-    , ""-    , "  Corresponding Source conveyed, and Installation Information provided,"-    , "in accord with this section must be in a format that is publicly"-    , "documented (and with an implementation available to the public in"-    , "source code form), and must require no special password or key for"-    , "unpacking, reading or copying."-    , ""-    , "  7. Additional Terms."-    , ""-    , "  \"Additional permissions\" are terms that supplement the terms of this"-    , "License by making exceptions from one or more of its conditions."-    , "Additional permissions that are applicable to the entire Program shall"-    , "be treated as though they were included in this License, to the extent"-    , "that they are valid under applicable law.  If additional permissions"-    , "apply only to part of the Program, that part may be used separately"-    , "under those permissions, but the entire Program remains governed by"-    , "this License without regard to the additional permissions."-    , ""-    , "  When you convey a copy of a covered work, you may at your option"-    , "remove any additional permissions from that copy, or from any part of"-    , "it.  (Additional permissions may be written to require their own"-    , "removal in certain cases when you modify the work.)  You may place"-    , "additional permissions on material, added by you to a covered work,"-    , "for which you have or can give appropriate copyright permission."-    , ""-    , "  Notwithstanding any other provision of this License, for material you"-    , "add to a covered work, you may (if authorized by the copyright holders of"-    , "that material) supplement the terms of this License with terms:"-    , ""-    , "    a) Disclaiming warranty or limiting liability differently from the"-    , "    terms of sections 15 and 16 of this License; or"-    , ""-    , "    b) Requiring preservation of specified reasonable legal notices or"-    , "    author attributions in that material or in the Appropriate Legal"-    , "    Notices displayed by works containing it; or"-    , ""-    , "    c) Prohibiting misrepresentation of the origin of that material, or"-    , "    requiring that modified versions of such material be marked in"-    , "    reasonable ways as different from the original version; or"-    , ""-    , "    d) Limiting the use for publicity purposes of names of licensors or"-    , "    authors of the material; or"-    , ""-    , "    e) Declining to grant rights under trademark law for use of some"-    , "    trade names, trademarks, or service marks; or"-    , ""-    , "    f) Requiring indemnification of licensors and authors of that"-    , "    material by anyone who conveys the material (or modified versions of"-    , "    it) with contractual assumptions of liability to the recipient, for"-    , "    any liability that these contractual assumptions directly impose on"-    , "    those licensors and authors."-    , ""-    , "  All other non-permissive additional terms are considered \"further"-    , "restrictions\" within the meaning of section 10.  If the Program as you"-    , "received it, or any part of it, contains a notice stating that it is"-    , "governed by this License along with a term that is a further"-    , "restriction, you may remove that term.  If a license document contains"-    , "a further restriction but permits relicensing or conveying under this"-    , "License, you may add to a covered work material governed by the terms"-    , "of that license document, provided that the further restriction does"-    , "not survive such relicensing or conveying."-    , ""-    , "  If you add terms to a covered work in accord with this section, you"-    , "must place, in the relevant source files, a statement of the"-    , "additional terms that apply to those files, or a notice indicating"-    , "where to find the applicable terms."-    , ""-    , "  Additional terms, permissive or non-permissive, may be stated in the"-    , "form of a separately written license, or stated as exceptions;"-    , "the above requirements apply either way."-    , ""-    , "  8. Termination."-    , ""-    , "  You may not propagate or modify a covered work except as expressly"-    , "provided under this License.  Any attempt otherwise to propagate or"-    , "modify it is void, and will automatically terminate your rights under"-    , "this License (including any patent licenses granted under the third"-    , "paragraph of section 11)."-    , ""-    , "  However, if you cease all violation of this License, then your"-    , "license from a particular copyright holder is reinstated (a)"-    , "provisionally, unless and until the copyright holder explicitly and"-    , "finally terminates your license, and (b) permanently, if the copyright"-    , "holder fails to notify you of the violation by some reasonable means"-    , "prior to 60 days after the cessation."-    , ""-    , "  Moreover, your license from a particular copyright holder is"-    , "reinstated permanently if the copyright holder notifies you of the"-    , "violation by some reasonable means, this is the first time you have"-    , "received notice of violation of this License (for any work) from that"-    , "copyright holder, and you cure the violation prior to 30 days after"-    , "your receipt of the notice."-    , ""-    , "  Termination of your rights under this section does not terminate the"-    , "licenses of parties who have received copies or rights from you under"-    , "this License.  If your rights have been terminated and not permanently"-    , "reinstated, you do not qualify to receive new licenses for the same"-    , "material under section 10."-    , ""-    , "  9. Acceptance Not Required for Having Copies."-    , ""-    , "  You are not required to accept this License in order to receive or"-    , "run a copy of the Program.  Ancillary propagation of a covered work"-    , "occurring solely as a consequence of using peer-to-peer transmission"-    , "to receive a copy likewise does not require acceptance.  However,"-    , "nothing other than this License grants you permission to propagate or"-    , "modify any covered work.  These actions infringe copyright if you do"-    , "not accept this License.  Therefore, by modifying or propagating a"-    , "covered work, you indicate your acceptance of this License to do so."-    , ""-    , "  10. Automatic Licensing of Downstream Recipients."-    , ""-    , "  Each time you convey a covered work, the recipient automatically"-    , "receives a license from the original licensors, to run, modify and"-    , "propagate that work, subject to this License.  You are not responsible"-    , "for enforcing compliance by third parties with this License."-    , ""-    , "  An \"entity transaction\" is a transaction transferring control of an"-    , "organization, or substantially all assets of one, or subdividing an"-    , "organization, or merging organizations.  If propagation of a covered"-    , "work results from an entity transaction, each party to that"-    , "transaction who receives a copy of the work also receives whatever"-    , "licenses to the work the party's predecessor in interest had or could"-    , "give under the previous paragraph, plus a right to possession of the"-    , "Corresponding Source of the work from the predecessor in interest, if"-    , "the predecessor has it or can get it with reasonable efforts."-    , ""-    , "  You may not impose any further restrictions on the exercise of the"-    , "rights granted or affirmed under this License.  For example, you may"-    , "not impose a license fee, royalty, or other charge for exercise of"-    , "rights granted under this License, and you may not initiate litigation"-    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"-    , "any patent claim is infringed by making, using, selling, offering for"-    , "sale, or importing the Program or any portion of it."-    , ""-    , "  11. Patents."-    , ""-    , "  A \"contributor\" is a copyright holder who authorizes use under this"-    , "License of the Program or a work on which the Program is based.  The"-    , "work thus licensed is called the contributor's \"contributor version\"."-    , ""-    , "  A contributor's \"essential patent claims\" are all patent claims"-    , "owned or controlled by the contributor, whether already acquired or"-    , "hereafter acquired, that would be infringed by some manner, permitted"-    , "by this License, of making, using, or selling its contributor version,"-    , "but do not include claims that would be infringed only as a"-    , "consequence of further modification of the contributor version.  For"-    , "purposes of this definition, \"control\" includes the right to grant"-    , "patent sublicenses in a manner consistent with the requirements of"-    , "this License."-    , ""-    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"-    , "patent license under the contributor's essential patent claims, to"-    , "make, use, sell, offer for sale, import and otherwise run, modify and"-    , "propagate the contents of its contributor version."-    , ""-    , "  In the following three paragraphs, a \"patent license\" is any express"-    , "agreement or commitment, however denominated, not to enforce a patent"-    , "(such as an express permission to practice a patent or covenant not to"-    , "sue for patent infringement).  To \"grant\" such a patent license to a"-    , "party means to make such an agreement or commitment not to enforce a"-    , "patent against the party."-    , ""-    , "  If you convey a covered work, knowingly relying on a patent license,"-    , "and the Corresponding Source of the work is not available for anyone"-    , "to copy, free of charge and under the terms of this License, through a"-    , "publicly available network server or other readily accessible means,"-    , "then you must either (1) cause the Corresponding Source to be so"-    , "available, or (2) arrange to deprive yourself of the benefit of the"-    , "patent license for this particular work, or (3) arrange, in a manner"-    , "consistent with the requirements of this License, to extend the patent"-    , "license to downstream recipients.  \"Knowingly relying\" means you have"-    , "actual knowledge that, but for the patent license, your conveying the"-    , "covered work in a country, or your recipient's use of the covered work"-    , "in a country, would infringe one or more identifiable patents in that"-    , "country that you have reason to believe are valid."-    , "  "-    , "  If, pursuant to or in connection with a single transaction or"-    , "arrangement, you convey, or propagate by procuring conveyance of, a"-    , "covered work, and grant a patent license to some of the parties"-    , "receiving the covered work authorizing them to use, propagate, modify"-    , "or convey a specific copy of the covered work, then the patent license"-    , "you grant is automatically extended to all recipients of the covered"-    , "work and works based on it."-    , ""-    , "  A patent license is \"discriminatory\" if it does not include within"-    , "the scope of its coverage, prohibits the exercise of, or is"-    , "conditioned on the non-exercise of one or more of the rights that are"-    , "specifically granted under this License.  You may not convey a covered"-    , "work if you are a party to an arrangement with a third party that is"-    , "in the business of distributing software, under which you make payment"-    , "to the third party based on the extent of your activity of conveying"-    , "the work, and under which the third party grants, to any of the"-    , "parties who would receive the covered work from you, a discriminatory"-    , "patent license (a) in connection with copies of the covered work"-    , "conveyed by you (or copies made from those copies), or (b) primarily"-    , "for and in connection with specific products or compilations that"-    , "contain the covered work, unless you entered into that arrangement,"-    , "or that patent license was granted, prior to 28 March 2007."-    , ""-    , "  Nothing in this License shall be construed as excluding or limiting"-    , "any implied license or other defenses to infringement that may"-    , "otherwise be available to you under applicable patent law."-    , ""-    , "  12. No Surrender of Others' Freedom."-    , ""-    , "  If conditions are imposed on you (whether by court order, agreement or"-    , "otherwise) that contradict the conditions of this License, they do not"-    , "excuse you from the conditions of this License.  If you cannot convey a"-    , "covered work so as to satisfy simultaneously your obligations under this"-    , "License and any other pertinent obligations, then as a consequence you may"-    , "not convey it at all.  For example, if you agree to terms that obligate you"-    , "to collect a royalty for further conveying from those to whom you convey"-    , "the Program, the only way you could satisfy both those terms and this"-    , "License would be to refrain entirely from conveying the Program."-    , ""-    , "  13. Use with the GNU Affero General Public License."-    , ""-    , "  Notwithstanding any other provision of this License, you have"-    , "permission to link or combine any covered work with a work licensed"-    , "under version 3 of the GNU Affero General Public License into a single"-    , "combined work, and to convey the resulting work.  The terms of this"-    , "License will continue to apply to the part which is the covered work,"-    , "but the special requirements of the GNU Affero General Public License,"-    , "section 13, concerning interaction through a network will apply to the"-    , "combination as such."-    , ""-    , "  14. Revised Versions of this License."-    , ""-    , "  The Free Software Foundation may publish revised and/or new versions of"-    , "the GNU General Public License from time to time.  Such new versions will"-    , "be similar in spirit to the present version, but may differ in detail to"-    , "address new problems or concerns."-    , ""-    , "  Each version is given a distinguishing version number.  If the"-    , "Program specifies that a certain numbered version of the GNU General"-    , "Public License \"or any later version\" applies to it, you have the"-    , "option of following the terms and conditions either of that numbered"-    , "version or of any later version published by the Free Software"-    , "Foundation.  If the Program does not specify a version number of the"-    , "GNU General Public License, you may choose any version ever published"-    , "by the Free Software Foundation."-    , ""-    , "  If the Program specifies that a proxy can decide which future"-    , "versions of the GNU General Public License can be used, that proxy's"-    , "public statement of acceptance of a version permanently authorizes you"-    , "to choose that version for the Program."-    , ""-    , "  Later license versions may give you additional or different"-    , "permissions.  However, no additional obligations are imposed on any"-    , "author or copyright holder as a result of your choosing to follow a"-    , "later version."-    , ""-    , "  15. Disclaimer of Warranty."-    , ""-    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"-    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"-    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"-    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"-    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"-    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"-    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"-    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."-    , ""-    , "  16. Limitation of Liability."-    , ""-    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"-    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"-    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"-    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"-    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"-    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"-    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"-    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"-    , "SUCH DAMAGES."-    , ""-    , "  17. Interpretation of Sections 15 and 16."-    , ""-    , "  If the disclaimer of warranty and limitation of liability provided"-    , "above cannot be given local legal effect according to their terms,"-    , "reviewing courts shall apply local law that most closely approximates"-    , "an absolute waiver of all civil liability in connection with the"-    , "Program, unless a warranty or assumption of liability accompanies a"-    , "copy of the Program in return for a fee."-    , ""-    , "              END OF TERMS AND CONDITIONS"-    , ""-    , "     How to Apply These Terms to Your New Programs"-    , ""-    , "  If you develop a new program, and you want it to be of the greatest"-    , "possible use to the public, the best way to achieve this is to make it"-    , "free software which everyone can redistribute and change under these terms."-    , ""-    , "  To do so, attach the following notices to the program.  It is safest"-    , "to attach them to the start of each source file to most effectively"-    , "state the exclusion of warranty; and each file should have at least"-    , "the \"copyright\" line and a pointer to where the full notice is found."-    , ""-    , "    <one line to give the program's name and a brief idea of what it does.>"-    , "    Copyright (C) <year>  <name of author>"-    , ""-    , "    This program is free software: you can redistribute it and/or modify"-    , "    it under the terms of the GNU General Public License as published by"-    , "    the Free Software Foundation, either version 3 of the License, or"-    , "    (at your option) any later version."-    , ""-    , "    This program is distributed in the hope that it will be useful,"-    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"-    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"-    , "    GNU General Public License for more details."-    , ""-    , "    You should have received a copy of the GNU General Public License"-    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."-    , ""-    , "Also add information on how to contact you by electronic and paper mail."-    , ""-    , "  If the program does terminal interaction, make it output a short"-    , "notice like this when it starts in an interactive mode:"-    , ""-    , "    <program>  Copyright (C) <year>  <name of author>"-    , "    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'."-    , "    This is free software, and you are welcome to redistribute it"-    , "    under certain conditions; type `show c' for details."-    , ""-    , "The hypothetical commands `show w' and `show c' should show the appropriate"-    , "parts of the General Public License.  Of course, your program's commands"-    , "might be different; for a GUI interface, you would use an \"about box\"."-    , ""-    , "  You should also get your employer (if you work as a programmer) or school,"-    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."-    , "For more information on this, and how to apply and follow the GNU GPL, see"-    , "<http://www.gnu.org/licenses/>."-    , ""-    , "  The GNU General Public License does not permit incorporating your program"-    , "into proprietary programs.  If your program is a subroutine library, you"-    , "may consider it more useful to permit linking proprietary applications with"-    , "the library.  If this is what you want to do, use the GNU Lesser General"-    , "Public License instead of this License.  But first, please read"-    , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."-    , ""-    ]--lgpl2 :: License-lgpl2 = unlines-    [ "           GNU LIBRARY GENERAL PUBLIC LICENSE"-    , "                 Version 2, June 1991"-    , ""-    , " Copyright (C) 1991 Free Software Foundation, Inc."-    , " 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"-    , " Everyone is permitted to copy and distribute verbatim copies"-    , " of this license document, but changing it is not allowed."-    , ""-    , "[This is the first released version of the library GPL.  It is"-    , " numbered 2 because it goes with version 2 of the ordinary GPL.]"-    , ""-    , "                     Preamble"-    , ""-    , "  The licenses for most software are designed to take away your"-    , "freedom to share and change it.  By contrast, the GNU General Public"-    , "Licenses are intended to guarantee your freedom to share and change"-    , "free software--to make sure the software is free for all its users."-    , ""-    , "  This license, the Library General Public License, applies to some"-    , "specially designated Free Software Foundation software, and to any"-    , "other libraries whose authors decide to use it.  You can use it for"-    , "your libraries, too."-    , ""-    , "  When we speak of free software, we are referring to freedom, not"-    , "price.  Our General Public Licenses are designed to make sure that you"-    , "have the freedom to distribute copies of free software (and charge for"-    , "this service if you wish), that you receive source code or can get it"-    , "if you want it, that you can change the software or use pieces of it"-    , "in new free programs; and that you know you can do these things."-    , ""-    , "  To protect your rights, we need to make restrictions that forbid"-    , "anyone to deny you these rights or to ask you to surrender the rights."-    , "These restrictions translate to certain responsibilities for you if"-    , "you distribute copies of the library, or if you modify it."-    , ""-    , "  For example, if you distribute copies of the library, whether gratis"-    , "or for a fee, you must give the recipients all the rights that we gave"-    , "you.  You must make sure that they, too, receive or can get the source"-    , "code.  If you link a program with the library, you must provide"-    , "complete object files to the recipients so that they can relink them"-    , "with the library, after making changes to the library and recompiling"-    , "it.  And you must show them these terms so they know their rights."-    , ""-    , "  Our method of protecting your rights has two steps: (1) copyright"-    , "the library, and (2) offer you this license which gives you legal"-    , "permission to copy, distribute and/or modify the library."-    , ""-    , "  Also, for each distributor's protection, we want to make certain"-    , "that everyone understands that there is no warranty for this free"-    , "library.  If the library is modified by someone else and passed on, we"-    , "want its recipients to know that what they have is not the original"-    , "version, so that any problems introduced by others will not reflect on"-    , "the original authors' reputations."-    , ""-    , "  Finally, any free program is threatened constantly by software"-    , "patents.  We wish to avoid the danger that companies distributing free"-    , "software will individually obtain patent licenses, thus in effect"-    , "transforming the program into proprietary software.  To prevent this,"-    , "we have made it clear that any patent must be licensed for everyone's"-    , "free use or not licensed at all."-    , ""-    , "  Most GNU software, including some libraries, is covered by the ordinary"-    , "GNU General Public License, which was designed for utility programs.  This"-    , "license, the GNU Library General Public License, applies to certain"-    , "designated libraries.  This license is quite different from the ordinary"-    , "one; be sure to read it in full, and don't assume that anything in it is"-    , "the same as in the ordinary license."-    , ""-    , "  The reason we have a separate public license for some libraries is that"-    , "they blur the distinction we usually make between modifying or adding to a"-    , "program and simply using it.  Linking a program with a library, without"-    , "changing the library, is in some sense simply using the library, and is"-    , "analogous to running a utility program or application program.  However, in"-    , "a textual and legal sense, the linked executable is a combined work, a"-    , "derivative of the original library, and the ordinary General Public License"-    , "treats it as such."-    , ""-    , "  Because of this blurred distinction, using the ordinary General"-    , "Public License for libraries did not effectively promote software"-    , "sharing, because most developers did not use the libraries.  We"-    , "concluded that weaker conditions might promote sharing better."-    , ""-    , "  However, unrestricted linking of non-free programs would deprive the"-    , "users of those programs of all benefit from the free status of the"-    , "libraries themselves.  This Library General Public License is intended to"-    , "permit developers of non-free programs to use free libraries, while"-    , "preserving your freedom as a user of such programs to change the free"-    , "libraries that are incorporated in them.  (We have not seen how to achieve"-    , "this as regards changes in header files, but we have achieved it as regards"-    , "changes in the actual functions of the Library.)  The hope is that this"-    , "will lead to faster development of free libraries."-    , ""-    , "  The precise terms and conditions for copying, distribution and"-    , "modification follow.  Pay close attention to the difference between a"-    , "\"work based on the library\" and a \"work that uses the library\".  The"-    , "former contains code derived from the library, while the latter only"-    , "works together with the library."-    , ""-    , "  Note that it is possible for a library to be covered by the ordinary"-    , "General Public License rather than by this special one."-    , ""-    , "              GNU LIBRARY GENERAL PUBLIC LICENSE"-    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"-    , ""-    , "  0. This License Agreement applies to any software library which"-    , "contains a notice placed by the copyright holder or other authorized"-    , "party saying it may be distributed under the terms of this Library"-    , "General Public License (also called \"this License\").  Each licensee is"-    , "addressed as \"you\"."-    , ""-    , "  A \"library\" means a collection of software functions and/or data"-    , "prepared so as to be conveniently linked with application programs"-    , "(which use some of those functions and data) to form executables."-    , ""-    , "  The \"Library\", below, refers to any such software library or work"-    , "which has been distributed under these terms.  A \"work based on the"-    , "Library\" means either the Library or any derivative work under"-    , "copyright law: that is to say, a work containing the Library or a"-    , "portion of it, either verbatim or with modifications and/or translated"-    , "straightforwardly into another language.  (Hereinafter, translation is"-    , "included without limitation in the term \"modification\".)"-    , ""-    , "  \"Source code\" for a work means the preferred form of the work for"-    , "making modifications to it.  For a library, complete source code means"-    , "all the source code for all modules it contains, plus any associated"-    , "interface definition files, plus the scripts used to control compilation"-    , "and installation of the library."-    , ""-    , "  Activities other than copying, distribution and modification are not"-    , "covered by this License; they are outside its scope.  The act of"-    , "running a program using the Library is not restricted, and output from"-    , "such a program is covered only if its contents constitute a work based"-    , "on the Library (independent of the use of the Library in a tool for"-    , "writing it).  Whether that is true depends on what the Library does"-    , "and what the program that uses the Library does."-    , "  "-    , "  1. You may copy and distribute verbatim copies of the Library's"-    , "complete source code as you receive it, in any medium, provided that"-    , "you conspicuously and appropriately publish on each copy an"-    , "appropriate copyright notice and disclaimer of warranty; keep intact"-    , "all the notices that refer to this License and to the absence of any"-    , "warranty; and distribute a copy of this License along with the"-    , "Library."-    , ""-    , "  You may charge a fee for the physical act of transferring a copy,"-    , "and you may at your option offer warranty protection in exchange for a"-    , "fee."-    , ""-    , "  2. You may modify your copy or copies of the Library or any portion"-    , "of it, thus forming a work based on the Library, and copy and"-    , "distribute such modifications or work under the terms of Section 1"-    , "above, provided that you also meet all of these conditions:"-    , ""-    , "    a) The modified work must itself be a software library."-    , ""-    , "    b) You must cause the files modified to carry prominent notices"-    , "    stating that you changed the files and the date of any change."-    , ""-    , "    c) You must cause the whole of the work to be licensed at no"-    , "    charge to all third parties under the terms of this License."-    , ""-    , "    d) If a facility in the modified Library refers to a function or a"-    , "    table of data to be supplied by an application program that uses"-    , "    the facility, other than as an argument passed when the facility"-    , "    is invoked, then you must make a good faith effort to ensure that,"-    , "    in the event an application does not supply such function or"-    , "    table, the facility still operates, and performs whatever part of"-    , "    its purpose remains meaningful."-    , ""-    , "    (For example, a function in a library to compute square roots has"-    , "    a purpose that is entirely well-defined independent of the"-    , "    application.  Therefore, Subsection 2d requires that any"-    , "    application-supplied function or table used by this function must"-    , "    be optional: if the application does not supply it, the square"-    , "    root function must still compute square roots.)"-    , ""-    , "These requirements apply to the modified work as a whole.  If"-    , "identifiable sections of that work are not derived from the Library,"-    , "and can be reasonably considered independent and separate works in"-    , "themselves, then this License, and its terms, do not apply to those"-    , "sections when you distribute them as separate works.  But when you"-    , "distribute the same sections as part of a whole which is a work based"-    , "on the Library, the distribution of the whole must be on the terms of"-    , "this License, whose permissions for other licensees extend to the"-    , "entire whole, and thus to each and every part regardless of who wrote"-    , "it."-    , ""-    , "Thus, it is not the intent of this section to claim rights or contest"-    , "your rights to work written entirely by you; rather, the intent is to"-    , "exercise the right to control the distribution of derivative or"-    , "collective works based on the Library."-    , ""-    , "In addition, mere aggregation of another work not based on the Library"-    , "with the Library (or with a work based on the Library) on a volume of"-    , "a storage or distribution medium does not bring the other work under"-    , "the scope of this License."-    , ""-    , "  3. You may opt to apply the terms of the ordinary GNU General Public"-    , "License instead of this License to a given copy of the Library.  To do"-    , "this, you must alter all the notices that refer to this License, so"-    , "that they refer to the ordinary GNU General Public License, version 2,"-    , "instead of to this License.  (If a newer version than version 2 of the"-    , "ordinary GNU General Public License has appeared, then you can specify"-    , "that version instead if you wish.)  Do not make any other change in"-    , "these notices."-    , ""-    , "  Once this change is made in a given copy, it is irreversible for"-    , "that copy, so the ordinary GNU General Public License applies to all"-    , "subsequent copies and derivative works made from that copy."-    , ""-    , "  This option is useful when you wish to copy part of the code of"-    , "the Library into a program that is not a library."-    , ""-    , "  4. You may copy and distribute the Library (or a portion or"-    , "derivative of it, under Section 2) in object code or executable form"-    , "under the terms of Sections 1 and 2 above provided that you accompany"-    , "it with the complete corresponding machine-readable source code, which"-    , "must be distributed under the terms of Sections 1 and 2 above on a"-    , "medium customarily used for software interchange."-    , ""-    , "  If distribution of object code is made by offering access to copy"-    , "from a designated place, then offering equivalent access to copy the"-    , "source code from the same place satisfies the requirement to"-    , "distribute the source code, even though third parties are not"-    , "compelled to copy the source along with the object code."-    , ""-    , "  5. A program that contains no derivative of any portion of the"-    , "Library, but is designed to work with the Library by being compiled or"-    , "linked with it, is called a \"work that uses the Library\".  Such a"-    , "work, in isolation, is not a derivative work of the Library, and"-    , "therefore falls outside the scope of this License."-    , ""-    , "  However, linking a \"work that uses the Library\" with the Library"-    , "creates an executable that is a derivative of the Library (because it"-    , "contains portions of the Library), rather than a \"work that uses the"-    , "library\".  The executable is therefore covered by this License."-    , "Section 6 states terms for distribution of such executables."-    , ""-    , "  When a \"work that uses the Library\" uses material from a header file"-    , "that is part of the Library, the object code for the work may be a"-    , "derivative work of the Library even though the source code is not."-    , "Whether this is true is especially significant if the work can be"-    , "linked without the Library, or if the work is itself a library.  The"-    , "threshold for this to be true is not precisely defined by law."-    , ""-    , "  If such an object file uses only numerical parameters, data"-    , "structure layouts and accessors, and small macros and small inline"-    , "functions (ten lines or less in length), then the use of the object"-    , "file is unrestricted, regardless of whether it is legally a derivative"-    , "work.  (Executables containing this object code plus portions of the"-    , "Library will still fall under Section 6.)"-    , ""-    , "  Otherwise, if the work is a derivative of the Library, you may"-    , "distribute the object code for the work under the terms of Section 6."-    , "Any executables containing that work also fall under Section 6,"-    , "whether or not they are linked directly with the Library itself."-    , ""-    , "  6. As an exception to the Sections above, you may also compile or"-    , "link a \"work that uses the Library\" with the Library to produce a"-    , "work containing portions of the Library, and distribute that work"-    , "under terms of your choice, provided that the terms permit"-    , "modification of the work for the customer's own use and reverse"-    , "engineering for debugging such modifications."-    , ""-    , "  You must give prominent notice with each copy of the work that the"-    , "Library is used in it and that the Library and its use are covered by"-    , "this License.  You must supply a copy of this License.  If the work"-    , "during execution displays copyright notices, you must include the"-    , "copyright notice for the Library among them, as well as a reference"-    , "directing the user to the copy of this License.  Also, you must do one"-    , "of these things:"-    , ""-    , "    a) Accompany the work with the complete corresponding"-    , "    machine-readable source code for the Library including whatever"-    , "    changes were used in the work (which must be distributed under"-    , "    Sections 1 and 2 above); and, if the work is an executable linked"-    , "    with the Library, with the complete machine-readable \"work that"-    , "    uses the Library\", as object code and/or source code, so that the"-    , "    user can modify the Library and then relink to produce a modified"-    , "    executable containing the modified Library.  (It is understood"-    , "    that the user who changes the contents of definitions files in the"-    , "    Library will not necessarily be able to recompile the application"-    , "    to use the modified definitions.)"-    , ""-    , "    b) Accompany the work with a written offer, valid for at"-    , "    least three years, to give the same user the materials"-    , "    specified in Subsection 6a, above, for a charge no more"-    , "    than the cost of performing this distribution."-    , ""-    , "    c) If distribution of the work is made by offering access to copy"-    , "    from a designated place, offer equivalent access to copy the above"-    , "    specified materials from the same place."-    , ""-    , "    d) Verify that the user has already received a copy of these"-    , "    materials or that you have already sent this user a copy."-    , ""-    , "  For an executable, the required form of the \"work that uses the"-    , "Library\" must include any data and utility programs needed for"-    , "reproducing the executable from it.  However, as a special exception,"-    , "the source code distributed need not include anything that is normally"-    , "distributed (in either source or binary form) with the major"-    , "components (compiler, kernel, and so on) of the operating system on"-    , "which the executable runs, unless that component itself accompanies"-    , "the executable."-    , ""-    , "  It may happen that this requirement contradicts the license"-    , "restrictions of other proprietary libraries that do not normally"-    , "accompany the operating system.  Such a contradiction means you cannot"-    , "use both them and the Library together in an executable that you"-    , "distribute."-    , ""-    , "  7. You may place library facilities that are a work based on the"-    , "Library side-by-side in a single library together with other library"-    , "facilities not covered by this License, and distribute such a combined"-    , "library, provided that the separate distribution of the work based on"-    , "the Library and of the other library facilities is otherwise"-    , "permitted, and provided that you do these two things:"-    , ""-    , "    a) Accompany the combined library with a copy of the same work"-    , "    based on the Library, uncombined with any other library"-    , "    facilities.  This must be distributed under the terms of the"-    , "    Sections above."-    , ""-    , "    b) Give prominent notice with the combined library of the fact"-    , "    that part of it is a work based on the Library, and explaining"-    , "    where to find the accompanying uncombined form of the same work."-    , ""-    , "  8. You may not copy, modify, sublicense, link with, or distribute"-    , "the Library except as expressly provided under this License.  Any"-    , "attempt otherwise to copy, modify, sublicense, link with, or"-    , "distribute the Library is void, and will automatically terminate your"-    , "rights under this License.  However, parties who have received copies,"-    , "or rights, from you under this License will not have their licenses"-    , "terminated so long as such parties remain in full compliance."-    , ""-    , "  9. You are not required to accept this License, since you have not"-    , "signed it.  However, nothing else grants you permission to modify or"-    , "distribute the Library or its derivative works.  These actions are"-    , "prohibited by law if you do not accept this License.  Therefore, by"-    , "modifying or distributing the Library (or any work based on the"-    , "Library), you indicate your acceptance of this License to do so, and"-    , "all its terms and conditions for copying, distributing or modifying"-    , "the Library or works based on it."-    , ""-    , "  10. Each time you redistribute the Library (or any work based on the"-    , "Library), the recipient automatically receives a license from the"-    , "original licensor to copy, distribute, link with or modify the Library"-    , "subject to these terms and conditions.  You may not impose any further"-    , "restrictions on the recipients' exercise of the rights granted herein."-    , "You are not responsible for enforcing compliance by third parties to"-    , "this License."-    , ""-    , "  11. If, as a consequence of a court judgment or allegation of patent"-    , "infringement or for any other reason (not limited to patent issues),"-    , "conditions are imposed on you (whether by court order, agreement or"-    , "otherwise) that contradict the conditions of this License, they do not"-    , "excuse you from the conditions of this License.  If you cannot"-    , "distribute so as to satisfy simultaneously your obligations under this"-    , "License and any other pertinent obligations, then as a consequence you"-    , "may not distribute the Library at all.  For example, if a patent"-    , "license would not permit royalty-free redistribution of the Library by"-    , "all those who receive copies directly or indirectly through you, then"-    , "the only way you could satisfy both it and this License would be to"-    , "refrain entirely from distribution of the Library."-    , ""-    , "If any portion of this section is held invalid or unenforceable under any"-    , "particular circumstance, the balance of the section is intended to apply,"-    , "and the section as a whole is intended to apply in other circumstances."-    , ""-    , "It is not the purpose of this section to induce you to infringe any"-    , "patents or other property right claims or to contest validity of any"-    , "such claims; this section has the sole purpose of protecting the"-    , "integrity of the free software distribution system which is"-    , "implemented by public license practices.  Many people have made"-    , "generous contributions to the wide range of software distributed"-    , "through that system in reliance on consistent application of that"-    , "system; it is up to the author/donor to decide if he or she is willing"-    , "to distribute software through any other system and a licensee cannot"-    , "impose that choice."-    , ""-    , "This section is intended to make thoroughly clear what is believed to"-    , "be a consequence of the rest of this License."-    , ""-    , "  12. If the distribution and/or use of the Library is restricted in"-    , "certain countries either by patents or by copyrighted interfaces, the"-    , "original copyright holder who places the Library under this License may add"-    , "an explicit geographical distribution limitation excluding those countries,"-    , "so that distribution is permitted only in or among countries not thus"-    , "excluded.  In such case, this License incorporates the limitation as if"-    , "written in the body of this License."-    , ""-    , "  13. The Free Software Foundation may publish revised and/or new"-    , "versions of the Library General Public License from time to time."-    , "Such new versions will be similar in spirit to the present version,"-    , "but may differ in detail to address new problems or concerns."-    , ""-    , "Each version is given a distinguishing version number.  If the Library"-    , "specifies a version number of this License which applies to it and"-    , "\"any later version\", you have the option of following the terms and"-    , "conditions either of that version or of any later version published by"-    , "the Free Software Foundation.  If the Library does not specify a"-    , "license version number, you may choose any version ever published by"-    , "the Free Software Foundation."-    , ""-    , "  14. If you wish to incorporate parts of the Library into other free"-    , "programs whose distribution conditions are incompatible with these,"-    , "write to the author to ask for permission.  For software which is"-    , "copyrighted by the Free Software Foundation, write to the Free"-    , "Software Foundation; we sometimes make exceptions for this.  Our"-    , "decision will be guided by the two goals of preserving the free status"-    , "of all derivatives of our free software and of promoting the sharing"-    , "and reuse of software generally."-    , ""-    , "                     NO WARRANTY"-    , ""-    , "  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO"-    , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW."-    , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR"-    , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY"-    , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE"-    , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"-    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE"-    , "LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME"-    , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION."-    , ""-    , "  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN"-    , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY"-    , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU"-    , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR"-    , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE"-    , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING"-    , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A"-    , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF"-    , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"-    , "DAMAGES."-    , ""-    , "              END OF TERMS AND CONDITIONS"-    , ""-    , "           How to Apply These Terms to Your New Libraries"-    , ""-    , "  If you develop a new library, and you want it to be of the greatest"-    , "possible use to the public, we recommend making it free software that"-    , "everyone can redistribute and change.  You can do so by permitting"-    , "redistribution under these terms (or, alternatively, under the terms of the"-    , "ordinary General Public License)."-    , ""-    , "  To apply these terms, attach the following notices to the library.  It is"-    , "safest to attach them to the start of each source file to most effectively"-    , "convey the exclusion of warranty; and each file should have at least the"-    , "\"copyright\" line and a pointer to where the full notice is found."-    , ""-    , "    <one line to give the library's name and a brief idea of what it does.>"-    , "    Copyright (C) <year>  <name of author>"-    , ""-    , "    This library is free software; you can redistribute it and/or"-    , "    modify it under the terms of the GNU Library General Public"-    , "    License as published by the Free Software Foundation; either"-    , "    version 2 of the License, or (at your option) any later version."-    , ""-    , "    This library is distributed in the hope that it will be useful,"-    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"-    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU"-    , "    Library General Public License for more details."-    , ""-    , "    You should have received a copy of the GNU Library General Public"-    , "    License along with this library; if not, write to the Free"-    , "    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"-    , ""-    , "Also add information on how to contact you by electronic and paper mail."-    , ""-    , "You should also get your employer (if you work as a programmer) or your"-    , "school, if any, to sign a \"copyright disclaimer\" for the library, if"-    , "necessary.  Here is a sample; alter the names:"-    , ""-    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the"-    , "  library `Frob' (a library for tweaking knobs) written by James Random Hacker."-    , ""-    , "  <signature of Ty Coon>, 1 April 1990"-    , "  Ty Coon, President of Vice"-    , ""-    , "That's all there is to it!"-    ]--lgpl3 :: License-lgpl3 = unlines-    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"-    , "                       Version 3, 29 June 2007"-    , ""-    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"-    , " Everyone is permitted to copy and distribute verbatim copies"-    , " of this license document, but changing it is not allowed."-    , ""-    , ""-    , "  This version of the GNU Lesser General Public License incorporates"-    , "the terms and conditions of version 3 of the GNU General Public"-    , "License, supplemented by the additional permissions listed below."-    , ""-    , "  0. Additional Definitions. "-    , ""-    , "  As used herein, \"this License\" refers to version 3 of the GNU Lesser"-    , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU"-    , "General Public License."-    , ""-    , "  \"The Library\" refers to a covered work governed by this License,"-    , "other than an Application or a Combined Work as defined below."-    , ""-    , "  An \"Application\" is any work that makes use of an interface provided"-    , "by the Library, but which is not otherwise based on the Library."-    , "Defining a subclass of a class defined by the Library is deemed a mode"-    , "of using an interface provided by the Library."-    , ""-    , "  A \"Combined Work\" is a work produced by combining or linking an"-    , "Application with the Library.  The particular version of the Library"-    , "with which the Combined Work was made is also called the \"Linked"-    , "Version\"."-    , ""-    , "  The \"Minimal Corresponding Source\" for a Combined Work means the"-    , "Corresponding Source for the Combined Work, excluding any source code"-    , "for portions of the Combined Work that, considered in isolation, are"-    , "based on the Application, and not on the Linked Version."-    , ""-    , "  The \"Corresponding Application Code\" for a Combined Work means the"-    , "object code and/or source code for the Application, including any data"-    , "and utility programs needed for reproducing the Combined Work from the"-    , "Application, but excluding the System Libraries of the Combined Work."-    , ""-    , "  1. Exception to Section 3 of the GNU GPL."-    , ""-    , "  You may convey a covered work under sections 3 and 4 of this License"-    , "without being bound by section 3 of the GNU GPL."-    , ""-    , "  2. Conveying Modified Versions."-    , ""-    , "  If you modify a copy of the Library, and, in your modifications, a"-    , "facility refers to a function or data to be supplied by an Application"-    , "that uses the facility (other than as an argument passed when the"-    , "facility is invoked), then you may convey a copy of the modified"-    , "version:"-    , ""-    , "   a) under this License, provided that you make a good faith effort to"-    , "   ensure that, in the event an Application does not supply the"-    , "   function or data, the facility still operates, and performs"-    , "   whatever part of its purpose remains meaningful, or"-    , ""-    , "   b) under the GNU GPL, with none of the additional permissions of"-    , "   this License applicable to that copy."-    , ""-    , "  3. Object Code Incorporating Material from Library Header Files."-    , ""-    , "  The object code form of an Application may incorporate material from"-    , "a header file that is part of the Library.  You may convey such object"-    , "code under terms of your choice, provided that, if the incorporated"-    , "material is not limited to numerical parameters, data structure"-    , "layouts and accessors, or small macros, inline functions and templates"-    , "(ten or fewer lines in length), you do both of the following:"-    , ""-    , "   a) Give prominent notice with each copy of the object code that the"-    , "   Library is used in it and that the Library and its use are"-    , "   covered by this License."-    , ""-    , "   b) Accompany the object code with a copy of the GNU GPL and this license"-    , "   document."-    , ""-    , "  4. Combined Works."-    , ""-    , "  You may convey a Combined Work under terms of your choice that,"-    , "taken together, effectively do not restrict modification of the"-    , "portions of the Library contained in the Combined Work and reverse"-    , "engineering for debugging such modifications, if you also do each of"-    , "the following:"-    , ""-    , "   a) Give prominent notice with each copy of the Combined Work that"-    , "   the Library is used in it and that the Library and its use are"-    , "   covered by this License."-    , ""-    , "   b) Accompany the Combined Work with a copy of the GNU GPL and this license"-    , "   document."-    , ""-    , "   c) For a Combined Work that displays copyright notices during"-    , "   execution, include the copyright notice for the Library among"-    , "   these notices, as well as a reference directing the user to the"-    , "   copies of the GNU GPL and this license document."-    , ""-    , "   d) Do one of the following:"-    , ""-    , "       0) Convey the Minimal Corresponding Source under the terms of this"-    , "       License, and the Corresponding Application Code in a form"-    , "       suitable for, and under terms that permit, the user to"-    , "       recombine or relink the Application with a modified version of"-    , "       the Linked Version to produce a modified Combined Work, in the"-    , "       manner specified by section 6 of the GNU GPL for conveying"-    , "       Corresponding Source."-    , ""-    , "       1) Use a suitable shared library mechanism for linking with the"-    , "       Library.  A suitable mechanism is one that (a) uses at run time"-    , "       a copy of the Library already present on the user's computer"-    , "       system, and (b) will operate properly with a modified version"-    , "       of the Library that is interface-compatible with the Linked"-    , "       Version. "-    , ""-    , "   e) Provide Installation Information, but only if you would otherwise"-    , "   be required to provide such information under section 6 of the"-    , "   GNU GPL, and only to the extent that such information is"-    , "   necessary to install and execute a modified version of the"-    , "   Combined Work produced by recombining or relinking the"-    , "   Application with a modified version of the Linked Version. (If"-    , "   you use option 4d0, the Installation Information must accompany"-    , "   the Minimal Corresponding Source and Corresponding Application"-    , "   Code. If you use option 4d1, you must provide the Installation"-    , "   Information in the manner specified by section 6 of the GNU GPL"-    , "   for conveying Corresponding Source.)"-    , ""-    , "  5. Combined Libraries."-    , ""-    , "  You may place library facilities that are a work based on the"-    , "Library side by side in a single library together with other library"-    , "facilities that are not Applications and are not covered by this"-    , "License, and convey such a combined library under terms of your"-    , "choice, if you do both of the following:"-    , ""-    , "   a) Accompany the combined library with a copy of the same work based"-    , "   on the Library, uncombined with any other library facilities,"-    , "   conveyed under the terms of this License."-    , ""-    , "   b) Give prominent notice with the combined library that part of it"-    , "   is a work based on the Library, and explaining where to find the"-    , "   accompanying uncombined form of the same work."-    , ""-    , "  6. Revised Versions of the GNU Lesser General Public License."-    , ""-    , "  The Free Software Foundation may publish revised and/or new versions"-    , "of the GNU Lesser General Public License from time to time. Such new"-    , "versions will be similar in spirit to the present version, but may"-    , "differ in detail to address new problems or concerns."-    , ""-    , "  Each version is given a distinguishing version number. If the"-    , "Library as you received it specifies that a certain numbered version"-    , "of the GNU Lesser General Public License \"or any later version\""-    , "applies to it, you have the option of following the terms and"-    , "conditions either of that published version or of any later version"-    , "published by the Free Software Foundation. If the Library as you"-    , "received it does not specify a version number of the GNU Lesser"-    , "General Public License, you may choose any version of the GNU Lesser"-    , "General Public License ever published by the Free Software Foundation."-    , ""-    , "  If the Library as you received it specifies that a proxy can decide"-    , "whether future versions of the GNU Lesser General Public License shall"-    , "apply, that proxy's public statement of acceptance of any version is"-    , "permanent authorization for you to choose that version for the"-    , "Library."-    ]-
− cabal-install-0.9.5_rc20101226/Distribution/Client/Init/Types.hs 
@@ -1,152 +0,0 @@-{-# LANGUAGE CPP #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Init.Types--- Copyright   :  (c) Brent Yorgey, Benedikt Huber 2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Some types used by the 'cabal init' command.----------------------------------------------------------------------------------module Distribution.Client.Init.Types where--import Distribution.Simple.Setup-  ( Flag(..) )--import Distribution.Version-import qualified Distribution.Package as P-import Distribution.License-import Distribution.ModuleName--import qualified Text.PrettyPrint as Disp-import qualified Distribution.Compat.ReadP as Parse-import Distribution.Text--import Data.Monoid---- | InitFlags is really just a simple type to represent certain---   portions of a .cabal file.  Rather than have a flag for EVERY---   possible field, we just have one for each field that the user is---   likely to want and/or that we are likely to be able to---   intelligently guess.-data InitFlags =-    InitFlags { nonInteractive :: Flag Bool-              , quiet          :: Flag Bool-              , packageDir     :: Flag FilePath-              , noComments     :: Flag Bool-              , minimal        :: Flag Bool--              , packageName  :: Flag String-              , version      :: Flag Version-              , cabalVersion :: Flag VersionRange-              , license      :: Flag License-              , author       :: Flag String-              , email        :: Flag String-              , homepage     :: Flag String--              , synopsis     :: Flag String-              , category     :: Flag (Either String Category)--              , packageType  :: Flag PackageType--              , exposedModules :: Maybe [ModuleName]-              , otherModules   :: Maybe [ModuleName]--              , dependencies :: Maybe [P.Dependency]-              , sourceDirs   :: Maybe [String]-              , buildTools   :: Maybe [String]-              }-  deriving (Show)--data PackageType = Library | Executable-  deriving (Show, Read, Eq)--instance Text PackageType where-  disp = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]--instance Monoid InitFlags where-  mempty = InitFlags-    { nonInteractive = mempty-    , quiet          = mempty-    , packageDir     = mempty-    , noComments     = mempty-    , minimal        = mempty-    , packageName    = mempty-    , version        = mempty-    , cabalVersion   = mempty-    , license        = mempty-    , author         = mempty-    , email          = mempty-    , homepage       = mempty-    , synopsis       = mempty-    , category       = mempty-    , packageType    = mempty-    , exposedModules = mempty-    , otherModules   = mempty-    , dependencies   = mempty-    , sourceDirs     = mempty-    , buildTools     = mempty-    }-  mappend  a b = InitFlags-    { nonInteractive = combine nonInteractive-    , quiet          = combine quiet-    , packageDir     = combine packageDir-    , noComments     = combine noComments-    , minimal        = combine minimal-    , packageName    = combine packageName-    , version        = combine version-    , cabalVersion   = combine cabalVersion-    , license        = combine license-    , author         = combine author-    , email          = combine email-    , homepage       = combine homepage-    , synopsis       = combine synopsis-    , category       = combine category-    , packageType    = combine packageType-    , exposedModules = combine exposedModules-    , otherModules   = combine otherModules-    , dependencies   = combine dependencies-    , sourceDirs     = combine sourceDirs-    , buildTools     = combine buildTools-    }-    where combine field = field a `mappend` field b---- | Some common package categories.-data Category-    = Codec-    | Concurrency-    | Control-    | Data-    | Database-    | Development-    | Distribution-    | Game-    | Graphics-    | Language-    | Math-    | Network-    | Sound-    | System-    | Testing-    | Text-    | Web-    deriving (Read, Show, Eq, Ord, Bounded, Enum)--instance Text Category where-  disp  = Disp.text . show-  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ]--#if MIN_VERSION_base(3,0,0)-#else--- Compat instance for ghc-6.6 era-instance Monoid a => Monoid (Maybe a) where-  mempty = Nothing-  Nothing `mappend` m = m-  m `mappend` Nothing = m-  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)-#endif
− cabal-install-0.9.5_rc20101226/Distribution/Client/Install.hs 
@@ -1,940 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Install--- Copyright   :  (c) 2005 David Himmelstrup---                    2007 Bjorn Bringert---                    2007-2010 Duncan Coutts--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ High level interface to package installation.-------------------------------------------------------------------------------module Distribution.Client.Install (-    install,-    upgrade,-  ) where--import Data.List-         ( unfoldr, find, nub, sort, partition )-import Data.Maybe-         ( isJust, fromMaybe )-import qualified Data.Map as Map-import Control.Exception as Exception-         ( handleJust )-#if MIN_VERSION_base(4,0,0)-import Control.Exception as Exception-         ( Exception(toException), catches, Handler(Handler), IOException )-import System.Exit-         ( ExitCode )-#else-import Control.Exception as Exception-         ( Exception(IOException, ExitException) )-#endif-import Distribution.Compat.Exception-         ( SomeException, catchIO, catchExit )-import Control.Monad-         ( when, unless )-import System.Directory-         ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )-import System.FilePath-         ( (</>), (<.>), takeDirectory )-import System.IO-         ( openFile, IOMode(AppendMode) )-import System.IO.Error-         ( isDoesNotExistError, ioeGetFileName )--import Distribution.Client.Dependency-         ( resolveDependenciesWithProgress-         , PackageConstraint(..), dependencyConstraints, dependencyTargets-         , PackagesPreference(..), PackagesPreferenceDefault(..)-         , PackagePreference(..)-         , Progress(..), foldProgress, )-import Distribution.Client.Fetch-         ( fetchPackage )-import Distribution.Client.HttpUtils-         ( downloadURI )-import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)--- import qualified Distribution.Client.Info as Info-import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, disambiguateDependencies-         , getInstalledPackages )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.Setup-         ( GlobalFlags(..)-         , ConfigFlags(..), configureCommand, filterConfigureFlags-         , ConfigExFlags(..), InstallFlags(..) )-import Distribution.Client.Config-         ( defaultCabalDir )-import Distribution.Client.Tar (extractTarGzFile)-import Distribution.Client.Types as Available-         ( UnresolvedDependency(..), AvailablePackage(..)-         , AvailablePackageSource(..), AvailablePackageDb(..)-         , Repo(..), ConfiguredPackage(..)-         , BuildResult, BuildFailure(..), BuildSuccess(..)-         , DocsResult(..), TestsResult(..), RemoteRepo(..)-         , InstalledPackage )-import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import Distribution.Client.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import qualified Distribution.Client.BuildReports.Anonymous as BuildReports-import qualified Distribution.Client.BuildReports.Storage as BuildReports-         ( storeAnonymous, storeLocal, fromInstallPlan )-import qualified Distribution.Client.InstallSymlink as InstallSymlink-         ( symlinkBinaries )-import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade-import qualified Distribution.Client.World as World-import Paths_cabal_install (getBinDir)--import Distribution.Simple.Compiler-         ( CompilerId(..), Compiler(compilerId), compilerFlavor-         , PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)-import qualified Distribution.Simple.InstallDirs as InstallDirs-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Simple.Setup-         ( haddockCommand, HaddockFlags(..), emptyHaddockFlags-         , buildCommand, BuildFlags(..), emptyBuildFlags-         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )-import qualified Distribution.Simple.Setup as Cabal-         ( installCommand, InstallFlags(..), emptyInstallFlags )-import Distribution.Simple.Utils-         ( defaultPackageDesc, rawSystemExit, comparing )-import Distribution.Simple.InstallDirs as InstallDirs-         ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate-         , initialPathTemplateEnv, installDirsTemplateEnv )-import Distribution.Package-         ( PackageName(..), PackageIdentifier, packageName, packageVersion-         , Package(..), PackageFixedDeps(..)-         , Dependency(..), thisPackageVersion )-import qualified Distribution.PackageDescription as PackageDescription-import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.PackageDescription.Parse-         ( readPackageDescription )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Version-         ( Version, VersionRange, anyVersion, thisVersion )-import Distribution.Simple.Utils as Utils-         ( notice, info, warn, die, intercalate, withTempDirectory )-import Distribution.Client.Utils-         ( inDir, mergeBy, MergeResult(..) )-import Distribution.System-         ( Platform, buildPlatform, OS(Windows), buildOS )-import Distribution.Text-         ( display )-import Distribution.Verbosity as Verbosity-         ( Verbosity, showForCabal, verbose )-import Distribution.Simple.BuildPaths ( exeExtension )----TODO:--- * add --upgrade-deps flag--- * add --only-deps flag--- * eliminate upgrade, replaced by --upgrade-deps and world target--- * assign flags to packages individually---   * complain about flags that do not apply to any package given as target---     so flags do not apply to dependencies, only listed, can use flag---     constraints for dependencies---   * only record applicable flags in world file--- * allow flag constraints--- * allow installed constraints--- * allow flag and installed preferences--- * change world file to use cabal section syntax---   * allow persistent configure flags for each package individually---- --------------------------------------------------------------- * Top level user actions--- ---------------------------------------------------------------- | An installation target given by the user. At the moment this--- is just a named package, possibly with a version constraint.--- It should be generalised to handle other targets like http or dirs.----type InstallTarget = UnresolvedDependency---- | Installs the packages needed to satisfy a list of dependencies.----install, upgrade-  :: Verbosity-  -> PackageDBStack-  -> [Repo]-  -> Compiler-  -> ProgramConfiguration-  -> GlobalFlags-  -> ConfigFlags-  -> ConfigExFlags-  -> InstallFlags-  -> [InstallTarget]-  -> IO ()-install verbosity packageDB repos comp conf-  globalFlags configFlags configExFlags installFlags targets =--    installWithPlanner verbosity context planner targets--  where-    context :: InstallContext-    context = (packageDB, repos, comp, conf,-               globalFlags, configFlags, configExFlags, installFlags)--    planner :: Planner-    planner-      | null targets = planLocalPackage verbosity-                         comp configFlags configExFlags--      | otherwise    = planRepoPackages defaultPref-                         comp globalFlags configFlags configExFlags-                         installFlags targets--    defaultPref-      | fromFlag (installUpgradeDeps installFlags) = PreferAllLatest-      | otherwise                                  = PreferLatestForSelected---upgrade _ _ _ _ _ _ _ _ _ _ = die $-    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"- ++ "You can install the latest version of a package using 'cabal install'. "- ++ "The 'cabal upgrade' command has been removed because people found it "- ++ "confusing and it often led to broken packages.\n"- ++ "If you want the old upgrade behaviour then use the install command "- ++ "with the --upgrade-dependencies flag (but check first with --dry-run "- ++ "to see what would happen). This will try to pick the latest versions "- ++ "of all dependencies, rather than the usual behaviour of trying to pick "- ++ "installed versions of all dependencies. If you do use "- ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "- ++ "packages (e.g. by using appropriate --constraint= flags)."---type Planner = PackageIndex InstalledPackage-            -> AvailablePackageDb-            -> IO (Progress String String InstallPlan)--type InstallContext = ( PackageDBStack-                      , [Repo]-                      , Compiler-                      , ProgramConfiguration-                      , GlobalFlags-                      , ConfigFlags-                      , ConfigExFlags-                      , InstallFlags )---- | Top-level orchestration. Installs the packages generated by a planner.----installWithPlanner :: Verbosity-                   -> InstallContext-                   -> Planner-                   -> [UnresolvedDependency]-                   -> IO ()-installWithPlanner verbosity-  context@(packageDBs, repos, comp, conf, _, _, _, installFlags)-  planner targets = do--  installed   <- getInstalledPackages verbosity comp packageDBs conf-  available   <- getAvailablePackages verbosity repos--  notice verbosity "Resolving dependencies..."-  installPlan <- foldProgress logMsg die return =<< planner installed available--  printPlanMessages verbosity installed installPlan dryRun--  unless dryRun $-        performInstallations verbosity context installed installPlan-    >>= postInstallActions verbosity context targets--  where-    dryRun = fromFlag (installDryRun installFlags)-    logMsg message rest = info verbosity message >> rest---- --------------------------------------------------------------- * Installation planning--- ---------------------------------------------------------------- | Make an 'InstallPlan' for the unpacked package in the current directory,--- and all its dependencies.----planLocalPackage :: Verbosity-                 -> Compiler-                 -> ConfigFlags-                 -> ConfigExFlags-                 -> Planner-planLocalPackage verbosity comp configFlags configExFlags installed-  (AvailablePackageDb available availablePrefs) = do-  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity-  let -- The trick is, we add the local package to the available index and-      -- remove it from the installed index. Then we ask to resolve a-      -- dependency on exactly that package. So the resolver ends up having-      -- to pick the local package.-      available' = PackageIndex.insert localPkg available-      installed' = PackageIndex.deletePackageId (packageId localPkg) installed-      localPkg = AvailablePackage {-        packageInfoId                = packageId pkg,-        Available.packageDescription = pkg,-        packageSource                = LocalUnpackedPackage Nothing-      }-      targets     = [packageName pkg]-      constraints = [PackageVersionConstraint (packageName pkg)-                       (thisVersion (packageVersion pkg))-                    ,PackageFlagsConstraint   (packageName pkg)-                       (configConfigurationsFlags configFlags)]-                 ++ [ PackageVersionConstraint name ver-                    | Dependency name ver <- configConstraints configFlags ]-      preferences = mergePackagePrefs PreferLatestForSelected-                                      availablePrefs configExFlags--  return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)-             installed' available' preferences constraints targets----- | Make an 'InstallPlan' for the given dependencies.----planRepoPackages :: PackagesPreferenceDefault-                 -> Compiler-                 -> GlobalFlags-                 -> ConfigFlags-                 -> ConfigExFlags-                 -> InstallFlags-                 -> [UnresolvedDependency]-                 -> Planner-planRepoPackages defaultPref comp-  globalFlags configFlags configExFlags installFlags-  deps installed (AvailablePackageDb available availablePrefs) = do--  deps' <- addWorldPackages deps-       >>= IndexUtils.disambiguateDependencies available--  let installed'-        | fromFlag (installReinstall installFlags)-                    = hideGivenDeps deps' installed-        | otherwise = installed-      targets     = dependencyTargets deps'-      constraints = dependencyConstraints deps'-                 ++ [ PackageVersionConstraint name ver-                    | Dependency name ver <- configConstraints configFlags ]-      preferences = mergePackagePrefs defaultPref availablePrefs configExFlags-  return $ resolveDependenciesWithProgress buildPlatform (compilerId comp)-             installed' available preferences constraints targets-  where-    hideGivenDeps pkgs index =-      foldr PackageIndex.deletePackageName index-        [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]--    addWorldPackages :: [UnresolvedDependency] -> IO [UnresolvedDependency]-    addWorldPackages targets = case partition World.isWorldTarget targets of-      ([], _)               -> return targets-      (world, otherTargets) -> do-        unless (all World.isGoodWorldTarget world) $-          die $ "The virtual package 'world' does not take any version "-             ++ "or configuration flags."-        worldTargets <- World.getContents worldFile-        --TODO: should we warn if there are no world targets?-        return (otherTargets ++ worldTargets)-      where-        worldFile = fromFlag $ globalWorldFile globalFlags---mergePackagePrefs :: PackagesPreferenceDefault-                  -> Map.Map PackageName VersionRange-                  -> ConfigExFlags-                  -> PackagesPreference-mergePackagePrefs defaultPref availablePrefs configExFlags =-  PackagesPreference defaultPref $-       -- The preferences that come from the hackage index-       [ PackageVersionPreference name ver-       | (name, ver) <- Map.toList availablePrefs ]-       -- additional preferences from the config file or command line-    ++ [ PackageVersionPreference name ver-       | Dependency name ver <- configPreferences configExFlags ]----- --------------------------------------------------------------- * Informational messages--- --------------------------------------------------------------printPlanMessages :: Verbosity-                  -> PackageIndex InstalledPackage-                  -> InstallPlan-                  -> Bool-                  -> IO ()-printPlanMessages verbosity installed installPlan dryRun = do--  when nothingToInstall $-    notice verbosity $-         "No packages to be installed. All the requested packages are "-      ++ "already installed.\n If you want to reinstall anyway then use "-      ++ "the --reinstall flag."--  when (dryRun || verbosity >= verbose) $-    printDryRun verbosity installed installPlan--  where-    nothingToInstall = null (InstallPlan.ready installPlan)---printDryRun :: Verbosity-            -> PackageIndex InstalledPackage-            -> InstallPlan-            -> IO ()-printDryRun verbosity installed plan = case unfoldr next plan of-  []   -> return ()-  pkgs-    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $-        "In order, the following would be installed:"-      : map showPkgAndReason pkgs-    | otherwise -> notice verbosity $ unlines $-        "In order, the following would be installed (use -v for more details):"-      : map (display . packageId) pkgs-  where-    next plan' = case InstallPlan.ready plan' of-      []      -> Nothing-      (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')-        where pkgid = packageId pkg-              result = BuildOk DocsNotTried TestsNotTried-              --FIXME: This is a bit of a hack,-              -- pretending that each package is installed--    showPkgAndReason pkg' = display (packageId pkg') ++ " " ++-          case PackageIndex.lookupPackageName installed (packageName pkg') of-            [] -> "(new package)"-            ps ->  case find ((==packageId pkg') . packageId) ps of-              Nothing  -> "(new version)"-              Just pkg -> "(reinstall)" ++ case changes pkg pkg' of-                []   -> ""-                diff -> " changes: "  ++ intercalate ", " diff-    changes pkg pkg' = map change . filter changed-                     $ mergeBy (comparing packageName)-                         (nub . sort . depends $ pkg)-                         (nub . sort . depends $ pkg')-    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"-    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "-                                    ++ display (packageVersion pkgid')-    change (OnlyInRight      pkgid') = display pkgid' ++ " added"-    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'-    changed _                        = True---- --------------------------------------------------------------- * Post installation stuff--- ---------------------------------------------------------------- | Various stuff we do after successful or unsuccessfully installing a bunch--- of packages. This includes:------  * build reporting, local and remote---  * symlinking binaries---  * updating indexes---  * updating world file---  * error reporting----postInstallActions :: Verbosity-                   -> InstallContext-                   -> [InstallTarget]-                   -> InstallPlan-                   -> IO ()-postInstallActions verbosity-  (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags)-  targets installPlan = do--  unless oneShot $-    World.insert verbosity worldFile targets'--  let buildReports = BuildReports.fromInstallPlan installPlan-  BuildReports.storeLocal (installSummaryFile installFlags) buildReports-  when (reportingLevel >= AnonymousReports) $-    BuildReports.storeAnonymous buildReports-  when (reportingLevel == DetailedReports) $-    storeDetailedBuildReports verbosity logsDir buildReports--  regenerateHaddockIndex verbosity packageDBs comp conf-                         configFlags installFlags installPlan--  symlinkBinaries verbosity configFlags installFlags installPlan--  printBuildFailures installPlan--  where-    reportingLevel = fromFlag (installBuildReports installFlags)-    logsDir        = fromFlag (globalLogsDir globalFlags)-    oneShot        = fromFlag (installOneShot installFlags)-    worldFile      = fromFlag $ globalWorldFile globalFlags-    targets'       = filter (not . World.isWorldTarget) targets--storeDetailedBuildReports :: Verbosity -> FilePath-                          -> [(BuildReports.BuildReport, Repo)] -> IO ()-storeDetailedBuildReports verbosity logsDir reports = sequence_-  [ do dotCabal <- defaultCabalDir-       let logFileName = display (BuildReports.package report) <.> "log"-           logFile     = logsDir </> logFileName-           reportsDir  = dotCabal </> "reports" </> remoteRepoName remoteRepo-           reportFile  = reportsDir </> logFileName--       handleMissingLogFile $ do-         buildLog <- readFile logFile-         createDirectoryIfMissing True reportsDir -- FIXME-         writeFile reportFile (show (BuildReports.show report, buildLog))--  | (report, Repo { repoKind = Left remoteRepo }) <- reports-  , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]--  where-    isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True-    isLikelyToHaveLogFile BuildReports.BuildFailed     {} = True-    isLikelyToHaveLogFile BuildReports.InstallFailed   {} = True-    isLikelyToHaveLogFile BuildReports.InstallOk       {} = True-    isLikelyToHaveLogFile _                               = False--    handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->-      warn verbosity $ "Missing log file for build report: "-                    ++ fromMaybe ""  (ioeGetFileName ioe)--#if MIN_VERSION_base(4,0,0)-    missingFile ioe-#else-    missingFile (IOException ioe)-#endif-      | isDoesNotExistError ioe  = Just ioe-    missingFile _                = Nothing---regenerateHaddockIndex :: Verbosity-                       -> [PackageDB]-                       -> Compiler-                       -> ProgramConfiguration-                       -> ConfigFlags-                       -> InstallFlags-                       -> InstallPlan-                       -> IO ()-regenerateHaddockIndex verbosity packageDBs comp conf-                       configFlags installFlags installPlan-  | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do--  defaultDirs <- InstallDirs.defaultInstallDirs-                   (compilerFlavor comp)-                   (fromFlag (configUserInstall configFlags))-                   True-  let indexFileTemplate = fromFlag (installHaddockIndex installFlags)-      indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate--  notice verbosity $-     "Updating documentation index " ++ indexFile--  --TODO: might be nice if the install plan gave us the new InstalledPackageInfo-  installed <- getInstalledPackages verbosity comp packageDBs conf-  Haddock.regenerateHaddockIndex verbosity installed conf indexFile--  | otherwise = return ()-  where-    haddockIndexFileIsRequested =-         fromFlag (installDocumentation installFlags)-      && isJust (flagToMaybe (installHaddockIndex installFlags))--    -- We want to regenerate the index if some new documentation was actually-    -- installed. Since the index is per-user, we don't do it for global-    -- installs or special cases where we're installing into a specific db.-    shouldRegenerateHaddockIndex = normalUserInstall-                                && someDocsWereInstalled installPlan-      where-        someDocsWereInstalled = any installedDocs . InstallPlan.toList-        normalUserInstall     = (UserPackageDB `elem` packageDBs)-                             && all (not . isSpecificPackageDB) packageDBs--        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True-        installedDocs _                                            = False-        isSpecificPackageDB (SpecificPackageDB _) = True-        isSpecificPackageDB _                     = False--    substHaddockIndexFileName defaultDirs = fromPathTemplate-                                          . substPathTemplate env-      where-        env  = env0 ++ installDirsTemplateEnv absoluteDirs-        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)-            ++ InstallDirs.platformTemplateEnv (buildPlatform)-        absoluteDirs = InstallDirs.substituteInstallDirTemplates-                         env0 templateDirs-        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault-                         defaultDirs (configInstallDirs configFlags)---symlinkBinaries :: Verbosity-                -> ConfigFlags-                -> InstallFlags-                -> InstallPlan -> IO ()-symlinkBinaries verbosity configFlags installFlags plan = do-  failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan-  case failed of-    [] -> return ()-    [(_, exe, path)] ->-      warn verbosity $-           "could not create a symlink in " ++ bindir ++ " for "-        ++ exe ++ " because the file exists there already but is not "-        ++ "managed by cabal. You can create a symlink for this executable "-        ++ "manually if you wish. The executable file has been installed at "-        ++ path-    exes ->-      warn verbosity $-           "could not create symlinks in " ++ bindir ++ " for "-        ++ intercalate ", " [ exe | (_, exe, _) <- exes ]-        ++ " because the files exist there already and are not "-        ++ "managed by cabal. You can create symlinks for these executables "-        ++ "manually if you wish. The executable files have been installed at "-        ++ intercalate ", " [ path | (_, _, path) <- exes ]-  where-    bindir = fromFlag (installSymlinkBinDir installFlags)---printBuildFailures :: InstallPlan -> IO ()-printBuildFailures plan =-  case [ (pkg, reason)-       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of-    []     -> return ()-    failed -> die . unlines-            $ "Error: some packages failed to install:"-            : [ display (packageId pkg) ++ printFailureReason reason-              | (pkg, reason) <- failed ]-  where-    printFailureReason reason = case reason of-      DependentFailed pkgid -> " depends on " ++ display pkgid-                            ++ " which failed to install."-      DownloadFailed  e -> " failed while downloading the package."-                        ++ " The exception was:\n  " ++ show e-      UnpackFailed    e -> " failed while unpacking the package."-                        ++ " The exception was:\n  " ++ show e-      ConfigureFailed e -> " failed during the configure step."-                        ++ " The exception was:\n  " ++ show e-      BuildFailed     e -> " failed during the building phase."-                        ++ " The exception was:\n  " ++ show e-      InstallFailed   e -> " failed during the final install step."-                        ++ " The exception was:\n  " ++ show e----- --------------------------------------------------------------- * Actually do the installations--- --------------------------------------------------------------data InstallMisc = InstallMisc {-    rootCmd    :: Maybe FilePath,-    libVersion :: Maybe Version-  }--performInstallations :: Verbosity-                     -> InstallContext-                     -> PackageIndex InstalledPackage-                     -> InstallPlan-                     -> IO InstallPlan-performInstallations verbosity-  (packageDBs, _, comp, conf,-   globalFlags, configFlags, configExFlags, installFlags)-  installed installPlan = do--  executeInstallPlan installPlan $ \cpkg ->-    installConfiguredPackage platform compid configFlags-                             cpkg $ \configFlags' src pkg ->-      installAvailablePackage verbosity (packageId pkg) src $ \mpath ->-        installUnpackedPackage verbosity (setupScriptOptions installed)-                               miscOptions configFlags' installFlags-                               compid pkg mpath useLogFile--  where-    platform = InstallPlan.planPlatform installPlan-    compid   = InstallPlan.planCompiler installPlan--    setupScriptOptions index = SetupScriptOptions {-      useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),-      useCompiler      = Just comp,-      -- Hack: we typically want to allow the UserPackageDB for finding the-      -- Cabal lib when compiling any Setup.hs even if we're doing a global-      -- install. However we also allow looking in a specific package db.-      usePackageDB     = if UserPackageDB `elem` packageDBs-                           then packageDBs-                           else let (db@GlobalPackageDB:dbs) = packageDBs-                                 in db : UserPackageDB : dbs,-                                --TODO: use Ord instance:-                                -- insert UserPackageDB packageDBs-      usePackageIndex  = if UserPackageDB `elem` packageDBs-                           then Just index-                           else Nothing,-      useProgramConfig = conf,-      useDistPref      = fromFlagOrDefault-                           (useDistPref defaultSetupScriptOptions)-                           (configDistPref configFlags),-      useLoggingHandle = Nothing,-      useWorkingDir    = Nothing-    }-    reportingLevel = fromFlag (installBuildReports installFlags)-    logsDir        = fromFlag (globalLogsDir globalFlags)-    useLogFile :: Maybe (PackageIdentifier -> FilePath)-    useLogFile = fmap substLogFileName logFileTemplate-      where-        logFileTemplate :: Maybe PathTemplate-        logFileTemplate --TODO: separate policy from mechanism-          | reportingLevel == DetailedReports-          = Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"-          | otherwise-          = flagToMaybe (installLogFile installFlags)-    substLogFileName template pkg = fromPathTemplate-                                  . substPathTemplate env-                                  $ template-      where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)-    miscOptions  = InstallMisc {-      rootCmd    = if fromFlag (configUserInstall configFlags)-                     then Nothing      -- ignore --root-cmd if --user.-                     else flagToMaybe (installRootCmd installFlags),-      libVersion = flagToMaybe (configCabalVersion configExFlags)-    }---executeInstallPlan :: Monad m-                   => InstallPlan-                   -> (ConfiguredPackage -> m BuildResult)-                   -> m InstallPlan-executeInstallPlan plan installPkg = case InstallPlan.ready plan of-  []       -> return plan-  (pkg: _) -> do buildResult <- installPkg pkg-                 let plan' = updatePlan (packageId pkg) buildResult plan-                 executeInstallPlan plan' installPkg-  where-    updatePlan pkgid (Right buildSuccess) =-      InstallPlan.completed pkgid buildSuccess--    updatePlan pkgid (Left buildFailure) =-      InstallPlan.failed    pkgid buildFailure depsFailure-      where-        depsFailure = DependentFailed pkgid-        -- So this first pkgid failed for whatever reason (buildFailure).-        -- All the other packages that depended on this pkgid, which we-        -- now cannot build, we mark as failing due to 'DependentFailed'-        -- which kind of means it was not their fault.----- | Call an installer for an 'AvailablePackage' but override the configure--- flags with the ones given by the 'ConfiguredPackage'. In particular the--- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly--- versioned package dependencies. So we ignore any previous partial flag--- assignment or dependency constraints and use the new ones.----installConfiguredPackage :: Platform -> CompilerId-                         ->  ConfigFlags -> ConfiguredPackage-                         -> (ConfigFlags -> AvailablePackageSource-                                         -> PackageDescription -> a)-                         -> a-installConfiguredPackage platform comp configFlags-  (ConfiguredPackage (AvailablePackage _ gpkg source) flags deps)-  installPkg = installPkg configFlags {-    configConfigurationsFlags = flags,-    configConstraints = map thisPackageVersion deps-  } source pkg-  where-    pkg = case finalizePackageDescription flags-           (const True)-           platform comp [] gpkg of-      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"-      Right (desc, _) -> desc---installAvailablePackage-  :: Verbosity -> PackageIdentifier -> AvailablePackageSource-  -> (Maybe FilePath -> IO BuildResult)-  -> IO BuildResult-installAvailablePackage _ _ (LocalUnpackedPackage dir) installPkg =-  installPkg dir--installAvailablePackage verbosity pkgid-                        (LocalTarballPackage tarballPath) installPkg = do-  tmp <- getTemporaryDirectory-  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->-    installLocalTarballPackage verbosity pkgid-                               tarballPath tmpDirPath installPkg--installAvailablePackage verbosity pkgid-                        (RemoteTarballPackage tarballURL) installPkg = do-  tmp <- getTemporaryDirectory-  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->-    onFailure DownloadFailed $ do-      let tarballPath = tmpDirPath </> display pkgid <.> "tar.gz"-      --TODO: perhaps we've already had to download this to a local cache-      --      so we even know what package version it is. So might be able-      --      to get it from the local cache rather than from remote.-      downloadURI verbosity tarballURL tarballPath-      installLocalTarballPackage verbosity pkgid-                                 tarballPath tmpDirPath installPkg--installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =-  onFailure DownloadFailed $ do-    tarballPath <- fetchPackage verbosity repo pkgid-    tmp <- getTemporaryDirectory-    withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->-      installLocalTarballPackage verbosity pkgid-                                 tarballPath tmpDirPath installPkg--installLocalTarballPackage-  :: Verbosity -> PackageIdentifier -> FilePath -> FilePath-  -> (Maybe FilePath -> IO BuildResult)-  -> IO BuildResult-installLocalTarballPackage verbosity pkgid tarballPath tmpDirPath installPkg =-  onFailure UnpackFailed $ do-    info verbosity $ "Extracting " ++ tarballPath-                  ++ " to " ++ tmpDirPath ++ "..."-    let relUnpackedPath = display pkgid-        absUnpackedPath = tmpDirPath </> relUnpackedPath-        descFilePath = absUnpackedPath-                   </> display (packageName pkgid) <.> "cabal"-    extractTarGzFile tmpDirPath relUnpackedPath tarballPath-    exists <- doesFileExist descFilePath-    when (not exists) $-      die $ "Package .cabal file not found: " ++ show descFilePath-    installPkg (Just absUnpackedPath)---installUnpackedPackage :: Verbosity-                   -> SetupScriptOptions-                   -> InstallMisc-                   -> ConfigFlags-                   -> InstallFlags-                   -> CompilerId-                   -> PackageDescription-                   -> Maybe FilePath -- ^ Directory to change to before starting the installation.-                   -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)-                   -> IO BuildResult-installUnpackedPackage verbosity scriptOptions miscOptions-                       configFlags installConfigFlags-                       compid pkg workingDir useLogFile =--  -- Configure phase-  onFailure ConfigureFailed $ do-    setup configureCommand configureFlags--  -- Build phase-    onFailure BuildFailed $ do-      setup buildCommand' buildFlags--  -- Doc generation phase-      docsResult <- if shouldHaddock-        then (do setup haddockCommand haddockFlags-                 return DocsOk)-               `catchIO`   (\_ -> return DocsFailed)-               `catchExit` (\_ -> return DocsFailed)-        else return DocsNotTried--  -- Tests phase-      testsResult <- return TestsNotTried  --TODO: add optional tests--  -- Install phase-      onFailure InstallFailed $-        withWin32SelfUpgrade verbosity configFlags compid pkg $ do-          case rootCmd miscOptions of-            (Just cmd) -> reexec cmd-            Nothing    -> setup Cabal.installCommand installFlags-          return (Right (BuildOk docsResult testsResult))--  where-    configureFlags   = filterConfigureFlags configFlags {-      configVerbosity = toFlag verbosity'-    }-    buildCommand'    = buildCommand defaultProgramConfiguration-    buildFlags   _   = emptyBuildFlags {-      buildDistPref  = configDistPref configFlags,-      buildVerbosity = toFlag verbosity'-    }-    shouldHaddock    = fromFlag (installDocumentation installConfigFlags)-    haddockFlags _   = emptyHaddockFlags {-      haddockDistPref  = configDistPref configFlags,-      haddockVerbosity = toFlag verbosity'-    }-    installFlags _   = Cabal.emptyInstallFlags {-      Cabal.installDistPref  = configDistPref configFlags,-      Cabal.installVerbosity = toFlag verbosity'-    }-    verbosity' | isJust useLogFile = max Verbosity.verbose verbosity-               | otherwise         = verbosity-    setup cmd flags  = do-      logFileHandle <- case useLogFile of-        Nothing          -> return Nothing-        Just mkLogFileName -> do-          let logFileName = mkLogFileName (packageId pkg)-              logDir      = takeDirectory logFileName-          unless (null logDir) $ createDirectoryIfMissing True logDir-          logFile <- openFile logFileName AppendMode-          return (Just logFile)--      setupWrapper verbosity-        scriptOptions { useLoggingHandle = logFileHandle-                      , useWorkingDir    = workingDir }-        (Just pkg)-        cmd flags []-    reexec cmd = do-      -- look for our on executable file and re-exec ourselves using-      -- a helper program like sudo to elevate priviledges:-      bindir <- getBinDir-      let self = bindir </> "cabal" <.> exeExtension-      weExist <- doesFileExist self-      if weExist-        then inDir workingDir $-               rawSystemExit verbosity cmd-                 [self, "install", "--only"-                 ,"--verbose=" ++ showForCabal verbosity]-        else die $ "Unable to find cabal executable at: " ++ self----- helper-onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult-onFailure result action =-#if MIN_VERSION_base(4,0,0)-  action `catches`-    [ Handler $ \ioe  -> handler (ioe  :: IOException)-    , Handler $ \exit -> handler (exit :: ExitCode)-    ]-  where-    handler :: Exception e => e -> IO BuildResult-    handler = return . Left . result . toException-#else-  action-    `catchIO`   (return . Left . result . IOException)-    `catchExit` (return . Left . result . ExitException)-#endif----- --------------------------------------------------------------- * Wierd windows hacks--- --------------------------------------------------------------withWin32SelfUpgrade :: Verbosity-                     -> ConfigFlags-                     -> CompilerId-                     -> PackageDescription-                     -> IO a -> IO a-withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity configFlags compid pkg action = do--  defaultDirs <- InstallDirs.defaultInstallDirs-                   compFlavor-                   (fromFlag (configUserInstall configFlags))-                   (PackageDescription.hasLibs pkg)--  Win32SelfUpgrade.possibleSelfUpgrade verbosity-    (exeInstallPaths defaultDirs) action--  where-    pkgid = packageId pkg-    (CompilerId compFlavor _) = compid--    exeInstallPaths defaultDirs =-      [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension-      | exe <- PackageDescription.executables pkg-      , PackageDescription.buildable (PackageDescription.buildInfo exe)-      , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix-            prefix  = substTemplate prefixTemplate-            suffix  = substTemplate suffixTemplate ]-      where-        fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")-        prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)-        suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)-        templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault-                           defaultDirs (configInstallDirs configFlags)-        absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid compid InstallDirs.NoCopyDest templateDirs-        substTemplate  = InstallDirs.fromPathTemplate-                       . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid compid
− cabal-install-0.9.5_rc20101226/Distribution/Client/InstallPlan.hs 
@@ -1,495 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.InstallPlan--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  duncan@haskell.org--- Stability   :  provisional--- Portability :  portable------ Package installation plan----------------------------------------------------------------------------------module Distribution.Client.InstallPlan (-  InstallPlan,-  ConfiguredPackage(..),-  PlanPackage(..),--  -- * Operations on 'InstallPlan's-  new,-  toList,-  ready,-  completed,-  failed,--  -- ** Query functions-  planPlatform,-  planCompiler,--  -- * Checking valididy of plans-  valid,-  closed,-  consistent,-  acyclic,-  configuredPackageValid,--  -- ** Details on invalid plans-  PlanProblem(..),-  showPlanProblem,-  PackageProblem(..),-  showPackageProblem,-  problems,-  configuredPackageProblems-  ) where--import Distribution.Client.Types-         ( AvailablePackage(packageDescription), ConfiguredPackage(..)-         , InstalledPackage-         , BuildFailure, BuildSuccess )-import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..), packageName-         , PackageFixedDeps(..), Dependency(..) )-import Distribution.Version-         ( Version, withinRange )-import Distribution.PackageDescription-         ( GenericPackageDescription(genPackageFlags)-         , Flag(flagName), FlagName(..) )-import Distribution.Client.PackageUtils-         ( externalBuildDepends )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Client.PackageIndex-         ( PackageIndex )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Text-         ( display )-import Distribution.System-         ( Platform )-import Distribution.Compiler-         ( CompilerId(..) )-import Distribution.Client.Utils-         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )-import Distribution.Simple.Utils-         ( comparing, intercalate )--import Data.List-         ( sort, sortBy )-import Data.Maybe-         ( fromMaybe )-import qualified Data.Graph as Graph-import Data.Graph (Graph)-import Control.Exception-         ( assert )---- When cabal tries to install a number of packages, including all their--- dependencies it has a non-trivial problem to solve.------ The Problem:------ In general we start with a set of installed packages and a set of available--- packages.------ Installed packages have fixed dependencies. They have already been built and--- we know exactly what packages they were built against, including their exact--- versions. ------ Available package have somewhat flexible dependencies. They are specified as--- version ranges, though really they're predicates. To make matters worse they--- have conditional flexible dependencies. Configuration flags can affect which--- packages are required and can place additional constraints on their--- versions.------ These two sets of package can and usually do overlap. There can be installed--- packages that are also available which means they could be re-installed if--- required, though there will also be packages which are not available and--- cannot be re-installed. Very often there will be extra versions available--- than are installed. Sometimes we may like to prefer installed packages over--- available ones or perhaps always prefer the latest available version whether--- installed or not.------ The goal is to calculate an installation plan that is closed, acyclic and--- consistent and where every configured package is valid.------ An installation plan is a set of packages that are going to be used--- together. It will consist of a mixture of installed packages and available--- packages along with their exact version dependencies. An installation plan--- is closed if for every package in the set, all of its dependencies are--- also in the set. It is consistent if for every package in the set, all--- dependencies which target that package have the same version.---- Note that plans do not necessarily compose. You might have a valid plan for--- package A and a valid plan for package B. That does not mean the composition--- is simultaniously valid for A and B. In particular you're most likely to--- have problems with inconsistent dependencies.--- On the other hand it is true that every closed sub plan is valid.--data PlanPackage = PreExisting InstalledPackage-                 | Configured  ConfiguredPackage-                 | Installed   ConfiguredPackage BuildSuccess-                 | Failed      ConfiguredPackage BuildFailure--instance Package PlanPackage where-  packageId (PreExisting pkg) = packageId pkg-  packageId (Configured  pkg) = packageId pkg-  packageId (Installed pkg _) = packageId pkg-  packageId (Failed    pkg _) = packageId pkg--instance PackageFixedDeps PlanPackage where-  depends (PreExisting pkg) = depends pkg-  depends (Configured  pkg) = depends pkg-  depends (Installed pkg _) = depends pkg-  depends (Failed    pkg _) = depends pkg--data InstallPlan = InstallPlan {-    planIndex    :: PackageIndex PlanPackage,-    planGraph    :: Graph,-    planGraphRev :: Graph,-    planPkgOf    :: Graph.Vertex -> PlanPackage,-    planVertexOf :: PackageIdentifier -> Graph.Vertex,-    planPlatform :: Platform,-    planCompiler :: CompilerId-  }--invariant :: InstallPlan -> Bool-invariant plan =-  valid (planPlatform plan) (planCompiler plan) (planIndex plan)--internalError :: String -> a-internalError msg = error $ "InstallPlan: internal error: " ++ msg---- | Build an installation plan from a valid set of resolved packages.----new :: Platform -> CompilerId -> PackageIndex PlanPackage-    -> Either [PlanProblem] InstallPlan-new platform compiler index =-  case problems platform compiler index of-    [] -> Right InstallPlan {-            planIndex    = index,-            planGraph    = graph,-            planGraphRev = Graph.transposeG graph,-            planPkgOf    = vertexToPkgId,-            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,-            planPlatform = platform,-            planCompiler = compiler-          }-      where (graph, vertexToPkgId, pkgIdToVertex) =-              PackageIndex.dependencyGraph index-            noSuchPkgId = internalError "package is not in the graph"-    probs -> Left probs--toList :: InstallPlan -> [PlanPackage]-toList = PackageIndex.allPackages . planIndex---- | The packages that are ready to be installed. That is they are in the--- configured state and have all their dependencies installed already.--- The plan is complete if the result is @[]@.----ready :: InstallPlan -> [ConfiguredPackage]-ready plan = assert check readyPackages-  where-    check = if null readyPackages then null configuredPackages else True-    configuredPackages =-      [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]-    readyPackages = filter (all isInstalled . depends) configuredPackages-    isInstalled pkg =-      case PackageIndex.lookupPackageId (planIndex plan) pkg of-        Just (Configured  _) -> False-        Just (Failed    _ _) -> internalError depOnFailed-        Just (PreExisting _) -> True-        Just (Installed _ _) -> True-        Nothing              -> internalError incomplete-    incomplete  = "install plan is not closed"-    depOnFailed = "configured package depends on failed package"---- | Marks a package in the graph as completed. Also saves the build result for--- the completed package in the plan.------ * The package must exist in the graph.--- * The package must have had no uninstalled dependent packages.----completed :: PackageIdentifier-          -> BuildSuccess-          -> InstallPlan -> InstallPlan-completed pkgid buildResult plan = assert (invariant plan') plan'-  where-    plan'     = plan {-                  planIndex = PackageIndex.insert installed (planIndex plan)-                }-    installed = Installed (lookupConfiguredPackage plan pkgid) buildResult---- | Marks a package in the graph as having failed. It also marks all the--- packages that depended on it as having failed.------ * The package must exist in the graph and be in the configured state.----failed :: PackageIdentifier -- ^ The id of the package that failed to install-       -> BuildFailure      -- ^ The build result to use for the failed package-       -> BuildFailure      -- ^ The build result to use for its dependencies-       -> InstallPlan-       -> InstallPlan-failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'-  where-    plan'    = plan {-                 planIndex = PackageIndex.merge (planIndex plan) failures-               }-    pkg      = lookupConfiguredPackage plan pkgid-    failures = PackageIndex.fromList-             $ Failed pkg buildResult-             : [ Failed pkg' buildResult'-               | Just pkg' <- map checkConfiguredPackage-                            $ packagesThatDependOn plan pkgid ]---- | lookup the reachable packages in the reverse dependency graph----packagesThatDependOn :: InstallPlan-                     -> PackageIdentifier -> [PlanPackage]-packagesThatDependOn plan = map (planPkgOf plan)-                          . tail-                          . Graph.reachable (planGraphRev plan)-                          . planVertexOf plan---- | lookup a package that we expect to be in the configured state----lookupConfiguredPackage :: InstallPlan-                        -> PackageIdentifier -> ConfiguredPackage-lookupConfiguredPackage plan pkgid =-  case PackageIndex.lookupPackageId (planIndex plan) pkgid of-    Just (Configured pkg) -> pkg-    _  -> internalError $ "not configured or no such pkg " ++ display pkgid---- | check a package that we expect to be in the configured or failed state----checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage-checkConfiguredPackage (Configured pkg) = Just pkg-checkConfiguredPackage (Failed     _ _) = Nothing-checkConfiguredPackage pkg                =-  internalError $ "not configured or no such pkg " ++ display (packageId pkg)---- --------------------------------------------------------------- * Checking valididy of plans--- ---------------------------------------------------------------- | A valid installation plan is a set of packages that is 'acyclic',--- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the--- plan has to have a valid configuration (see 'configuredPackageValid').------ * if the result is @False@ use 'problems' to get a detailed list.----valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool-valid platform comp index = null (problems platform comp index)--data PlanProblem =-     PackageInvalid       ConfiguredPackage [PackageProblem]-   | PackageMissingDeps   PlanPackage [PackageIdentifier]-   | PackageCycle         [PlanPackage]-   | PackageInconsistency PackageName [(PackageIdentifier, Version)]-   | PackageStateInvalid  PlanPackage PlanPackage--showPlanProblem :: PlanProblem -> String-showPlanProblem (PackageInvalid pkg packageProblems) =-     "Package " ++ display (packageId pkg)-  ++ " has an invalid configuration, in particular:\n"-  ++ unlines [ "  " ++ showPackageProblem problem-             | problem <- packageProblems ]--showPlanProblem (PackageMissingDeps pkg missingDeps) =-     "Package " ++ display (packageId pkg)-  ++ " depends on the following packages which are missing from the plan "-  ++ intercalate ", " (map display missingDeps)--showPlanProblem (PackageCycle cycleGroup) =-     "The following packages are involved in a dependency cycle "-  ++ intercalate ", " (map (display.packageId) cycleGroup)--showPlanProblem (PackageInconsistency name inconsistencies) =-     "Package " ++ display name-  ++ " is required by several packages,"-  ++ " but they require inconsistent versions:\n"-  ++ unlines [ "  package " ++ display pkg ++ " requires "-                            ++ display (PackageIdentifier name ver)-             | (pkg, ver) <- inconsistencies ]--showPlanProblem (PackageStateInvalid pkg pkg') =-     "Package " ++ display (packageId pkg)-  ++ " is in the " ++ showPlanState pkg-  ++ " state but it depends on package " ++ display (packageId pkg')-  ++ " which is in the " ++ showPlanState pkg'-  ++ " state"-  where-    showPlanState (PreExisting _) = "pre-existing"-    showPlanState (Configured  _) = "configured"-    showPlanState (Installed _ _) = "installed"-    showPlanState (Failed    _ _) = "failed"---- | For an invalid plan, produce a detailed list of problems as human readable--- error messages. This is mainly intended for debugging purposes.--- Use 'showPlanProblem' for a human readable explanation.----problems :: Platform -> CompilerId-         -> PackageIndex PlanPackage -> [PlanProblem]-problems platform comp index =-     [ PackageInvalid pkg packageProblems-     | Configured pkg <- PackageIndex.allPackages index-     , let packageProblems = configuredPackageProblems platform comp pkg-     , not (null packageProblems) ]--  ++ [ PackageMissingDeps pkg missingDeps-     | (pkg, missingDeps) <- PackageIndex.brokenPackages index ]--  ++ [ PackageCycle cycleGroup-     | cycleGroup <- PackageIndex.dependencyCycles index ]--  ++ [ PackageInconsistency name inconsistencies-     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ]--  ++ [ PackageStateInvalid pkg pkg'-     | pkg <- PackageIndex.allPackages index-     , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg)-     , not (stateDependencyRelation pkg pkg') ]---- | The graph of packages (nodes) and dependencies (edges) must be acyclic.------ * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out---   which packages are involved in dependency cycles.----acyclic :: PackageIndex PlanPackage -> Bool-acyclic = null . PackageIndex.dependencyCycles---- | An installation plan is closed if for every package in the set, all of--- its dependencies are also in the set. That is, the set is closed under the--- dependency relation.------ * if the result is @False@ use 'PackageIndex.brokenPackages' to find out---   which packages depend on packages not in the index.----closed :: PackageIndex PlanPackage -> Bool-closed = null . PackageIndex.brokenPackages---- | An installation plan is consistent if all dependencies that target a--- single package name, target the same version.------ This is slightly subtle. It is not the same as requiring that there be at--- most one version of any package in the set. It only requires that of--- packages which have more than one other package depending on them. We could--- actually make the condition even more precise and say that different--- versions are ok so long as they are not both in the transative closure of--- any other package (or equivalently that their inverse closures do not--- intersect). The point is we do not want to have any packages depending--- directly or indirectly on two different versions of the same package. The--- current definition is just a safe aproximation of that.------ * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to---   find out which packages are.----consistent :: PackageIndex PlanPackage -> Bool-consistent = null . PackageIndex.dependencyInconsistencies---- | The states of packages have that depend on each other must respect--- this relation. That is for very case where package @a@ depends on--- package @b@ we require that @dependencyStatesOk a b = True@.----stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool-stateDependencyRelation (PreExisting _) (PreExisting _) = True--stateDependencyRelation (Configured  _) (PreExisting _) = True-stateDependencyRelation (Configured  _) (Configured  _) = True-stateDependencyRelation (Configured  _) (Installed _ _) = True--stateDependencyRelation (Installed _ _) (PreExisting _) = True-stateDependencyRelation (Installed _ _) (Installed _ _) = True--stateDependencyRelation (Failed    _ _) (PreExisting _) = True--- failed can depends on configured because a package can depend on--- several other packages and if one of the deps fail then we fail--- but we still depend on the other ones that did not fail:-stateDependencyRelation (Failed    _ _) (Configured  _) = True-stateDependencyRelation (Failed    _ _) (Installed _ _) = True-stateDependencyRelation (Failed    _ _) (Failed    _ _) = True--stateDependencyRelation _               _               = False---- | A 'ConfiguredPackage' is valid if the flag assignment is total and if--- in the configuration given by the flag assignment, all the package--- dependencies are satisfied by the specified packages.----configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool-configuredPackageValid platform comp pkg =-  null (configuredPackageProblems platform comp pkg)--data PackageProblem = DuplicateFlag FlagName-                    | MissingFlag   FlagName-                    | ExtraFlag     FlagName-                    | DuplicateDeps [PackageIdentifier]-                    | MissingDep    Dependency-                    | ExtraDep      PackageIdentifier-                    | InvalidDep    Dependency PackageIdentifier--showPackageProblem :: PackageProblem -> String-showPackageProblem (DuplicateFlag (FlagName flag)) =-  "duplicate flag in the flag assignment: " ++ flag--showPackageProblem (MissingFlag (FlagName flag)) =-  "missing an assignment for the flag: " ++ flag--showPackageProblem (ExtraFlag (FlagName flag)) =-  "extra flag given that is not used by the package: " ++ flag--showPackageProblem (DuplicateDeps pkgids) =-     "duplicate packages specified as selected dependencies: "-  ++ intercalate ", " (map display pkgids)--showPackageProblem (MissingDep dep) =-     "the package has a dependency " ++ display dep-  ++ " but no package has been selected to satisfy it."--showPackageProblem (ExtraDep pkgid) =-     "the package configuration specifies " ++ display pkgid-  ++ " but (with the given flag assignment) the package does not actually"-  ++ " depend on any version of that package."--showPackageProblem (InvalidDep dep pkgid) =-     "the package depends on " ++ display dep-  ++ " but the configuration specifies " ++ display pkgid-  ++ " which does not satisfy the dependency."--configuredPackageProblems :: Platform -> CompilerId-                          -> ConfiguredPackage -> [PackageProblem]-configuredPackageProblems platform comp-  (ConfiguredPackage pkg specifiedFlags specifiedDeps) =-     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]-  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]-  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]-  ++ [ DuplicateDeps pkgs-     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]-  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]-  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]-  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps-                            , not (packageSatisfiesDependency pkgid dep) ]-  where-    mergedFlags = mergeBy compare-      (sort $ map flagName (genPackageFlags (packageDescription pkg)))-      (sort $ map fst specifiedFlags)--    mergedDeps = mergeBy-      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)-      (sortBy (comparing dependencyName) requiredDeps)-      (sortBy (comparing packageName)    specifiedDeps)--    packageSatisfiesDependency-      (PackageIdentifier name  version)-      (Dependency        name' versionRange) = assert (name == name') $-        version `withinRange` versionRange--    dependencyName (Dependency name _) = name--    requiredDeps :: [Dependency]-    requiredDeps =-      --TODO: use something lower level than finalizePackageDescription-      case finalizePackageDescription specifiedFlags-         (const True)-         platform comp-         []-         (packageDescription pkg) of-        Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg-        Left  _ -> error "configuredPackageInvalidDeps internal error"
− cabal-install-0.9.5_rc20101226/Distribution/Client/InstallSymlink.hs 
@@ -1,238 +0,0 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp  #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.InstallSymlink--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Managing installing binaries with symlinks.-------------------------------------------------------------------------------module Distribution.Client.InstallSymlink (-    symlinkBinaries,-    symlinkBinary,-  ) where--#if mingw32_HOST_OS || mingw32_TARGET_OS--import Distribution.Package (PackageIdentifier)-import Distribution.Client.InstallPlan (InstallPlan)-import Distribution.Client.Setup (InstallFlags)-import Distribution.Simple.Setup (ConfigFlags)--symlinkBinaries :: ConfigFlags-                -> InstallFlags-                -> InstallPlan-                -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries _ _ _ = return []--symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool-symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"--#else--import Distribution.Client.Types-         ( AvailablePackage(..), ConfiguredPackage(..) )-import Distribution.Client.Setup-         ( InstallFlags(installSymlinkBinDir) )-import qualified Distribution.Client.InstallPlan as InstallPlan-import Distribution.Client.InstallPlan (InstallPlan)--import Distribution.Package-         ( PackageIdentifier, Package(packageId) )-import Distribution.Compiler-         ( CompilerId(..) )-import qualified Distribution.PackageDescription as PackageDescription-import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription )-import Distribution.Simple.Setup-         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )-import qualified Distribution.Simple.InstallDirs as InstallDirs--import System.Posix.Files-         ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink-         , removeLink )-import System.Directory-         ( canonicalizePath )-import System.FilePath-         ( (</>), splitPath, joinPath, isAbsolute )--import Prelude hiding (catch, ioError)-import System.IO.Error-         ( catch, isDoesNotExistError, ioError )-import Control.Exception-         ( assert )-import Data.Maybe-         ( catMaybes )---- | We would like by default to install binaries into some location that is on--- the user's PATH. For per-user installations on Unix systems that basically--- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@--- directory will be on the user's PATH. However some people are a bit nervous--- about letting a package manager install programs into @~/bin/@.------ A comprimise solution is that instead of installing binaries directly into--- @~/bin/@, we could install them in a private location under @~/.cabal/bin@--- and then create symlinks in @~/bin/@. We can be careful when setting up the--- symlinks that we do not overwrite any binary that the user installed. We can--- check if it was a symlink we made because it would point to the private dir--- where we install our binaries. This means we can install normally without--- worrying and in a later phase set up symlinks, and if that fails then we--- report it to the user, but even in this case the package is still in an ok--- installed state.------ This is an optional feature that users can choose to use or not. It is--- controlled from the config file. Of course it only works on posix systems--- with symlinks so is not available to Windows users.----symlinkBinaries :: ConfigFlags-                -> InstallFlags-                -> InstallPlan-                -> IO [(PackageIdentifier, String, FilePath)]-symlinkBinaries configFlags installFlags plan =-  case flagToMaybe (installSymlinkBinDir installFlags) of-    Nothing            -> return []-    Just symlinkBinDir-           | null exes -> return []-           | otherwise -> do-      publicBinDir  <- canonicalizePath symlinkBinDir---    TODO: do we want to do this here? :---      createDirectoryIfMissing True publicBinDir-      fmap catMaybes $ sequence-        [ do privateBinDir <- pkgBinDir pkg-             ok <- symlinkBinary-                     publicBinDir  privateBinDir-                     publicExeName privateExeName-             if ok-               then return Nothing-               else return (Just (pkgid, publicExeName,-                                  privateBinDir </> privateExeName))-        | (pkg, exe) <- exes-        , let publicExeName  = PackageDescription.exeName exe-              privateExeName = prefix ++ publicExeName ++ suffix-              pkgid  = packageId pkg-              prefix = substTemplate pkgid prefixTemplate-              suffix = substTemplate pkgid suffixTemplate ]-  where-    exes =-      [ (pkg, exe)-      | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan-      , let pkg   = pkgDescription cpkg-      , exe <- PackageDescription.executables pkg-      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]--    pkgDescription :: ConfiguredPackage -> PackageDescription-    pkgDescription (ConfiguredPackage (AvailablePackage _ pkg _) flags _) =-      case finalizePackageDescription flags-             (const True)-             platform compilerId [] pkg of-        Left _ -> error "finalizePackageDescription ConfiguredPackage failed"-        Right (desc, _) -> desc--    -- This is sadly rather complicated. We're kind of re-doing part of the-    -- configuration for the package. :-(-    pkgBinDir :: PackageDescription -> IO FilePath-    pkgBinDir pkg = do-      defaultDirs <- InstallDirs.defaultInstallDirs-                       compilerFlavor-                       (fromFlag (configUserInstall configFlags))-                       (PackageDescription.hasLibs pkg)-      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault-                           defaultDirs (configInstallDirs configFlags)-          absoluteDirs = InstallDirs.absoluteInstallDirs-                           (packageId pkg) compilerId InstallDirs.NoCopyDest-                           templateDirs-      canonicalizePath (InstallDirs.bindir absoluteDirs)--    substTemplate pkgid = InstallDirs.fromPathTemplate-                        . InstallDirs.substPathTemplate env-      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId--    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")-    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)-    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)-    platform         = InstallPlan.planPlatform plan-    compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan--symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir-                          --   eg @/home/user/bin@-              -> FilePath -- ^ The canonical path of the private bin dir-                          --   eg @/home/user/.cabal/bin@-              -> String   -- ^ The name of the executable to go in the public-                          --   bin dir, eg @foo@-              -> String   -- ^ The name of the executable to in the private bin-                          --   dir, eg @foo-1.0@-              -> IO Bool  -- ^ If creating the symlink was sucessful. @False@-                          --   if there was another file there already that we-                          --   did not own. Other errors like permission errors-                          --   just propagate as exceptions.-symlinkBinary publicBindir privateBindir publicName privateName = do-  ok <- targetOkToOverwrite (publicBindir </> publicName)-                            (privateBindir </> privateName)-  case ok of-    NotOurFile    ->                     return False-    NotExists     ->           mkLink >> return True-    OkToOverwrite -> rmLink >> mkLink >> return True-  where-    relativeBindir = makeRelative publicBindir privateBindir-    mkLink = createSymbolicLink (relativeBindir </> privateName)-                                (publicBindir   </> publicName)-    rmLink = removeLink (publicBindir </> publicName)---- | Check a filepath of a symlink that we would like to create to see if it--- is ok. For it to be ok to overwrite it must either not already exist yet or--- be a symlink to our target (in which case we can assume ownership).----targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private-                                -- binary that we would like to create-                    -> FilePath -- ^ The canonical path of the private binary.-                                -- Use 'canonicalizePath' to make this.-                    -> IO SymlinkStatus-targetOkToOverwrite symlink target = handleNotExist $ do-  status <- getSymbolicLinkStatus symlink-  if not (isSymbolicLink status)-    then return NotOurFile-    else do target' <- canonicalizePath symlink-            -- This relies on canonicalizePath handling symlinks-            if target == target'-              then return OkToOverwrite-              else return NotOurFile--  where-    handleNotExist action = catch action $ \ioexception ->-      -- If the target doesn't exist then there's no problem overwriting it!-      if isDoesNotExistError ioexception-        then return NotExists-        else ioError ioexception--data SymlinkStatus-   = NotExists     -- ^ The file doesn't exist so we can make a symlink.-   | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll-                   -- have to delete it first bemore we make a new symlink.-   | NotOurFile    -- ^ A file already exists and it is not one of our existing-                   -- symlinks (either because it is not a symlink or because-                   -- it points somewhere other than our managed space).-  deriving Show---- | Take two canonical paths and produce a relative path to get from the first--- to the second, even if it means adding @..@ path components.----makeRelative :: FilePath -> FilePath -> FilePath-makeRelative a b = assert (isAbsolute a && isAbsolute b) $-  let as = splitPath a-      bs = splitPath b-      commonLen = length $ takeWhile id $ zipWith (==) as bs-   in joinPath $ [ ".." | _  <- drop commonLen as ]-              ++ [  b'  | b' <- drop commonLen bs ]--#endif
− cabal-install-0.9.5_rc20101226/Distribution/Client/List.hs 
@@ -1,368 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.List--- Copyright   :  (c) David Himmelstrup 2005---                    Duncan Coutts 2008-2009--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org------ Search for and print information about packages-------------------------------------------------------------------------------module Distribution.Client.List (-  list, info-  ) where--import Distribution.Package-         ( PackageName(..), packageName, packageVersion-         , Dependency(..), thisPackageVersion, depends )-import Distribution.ModuleName (ModuleName)-import Distribution.License (License)-import qualified Distribution.InstalledPackageInfo as Installed-import qualified Distribution.PackageDescription   as Available-import Distribution.PackageDescription-         ( Flag(..), FlagName(..) )-import Distribution.PackageDescription.Configuration-         ( flattenPackageDescription )--import Distribution.Simple.Compiler-        ( Compiler, PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration)-import Distribution.Simple.Utils (equating, comparing, notice)-import Distribution.Simple.Setup (fromFlag)-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Version   (Version)-import Distribution.Verbosity (Verbosity)-import Distribution.Text-         ( Text(disp), display )--import Distribution.Client.Types-         ( AvailablePackage(..), Repo, AvailablePackageDb(..)-         , UnresolvedDependency(..), InstalledPackage(..) )-import Distribution.Client.Setup-         ( ListFlags(..), InfoFlags(..) )-import Distribution.Client.Utils-         ( mergeBy, MergeResult(..) )-import Distribution.Client.IndexUtils as IndexUtils-         ( getAvailablePackages, disambiguateDependencies-         , getInstalledPackages )-import Distribution.Client.Fetch-         ( isFetched )--import Data.List-         ( sortBy, groupBy, sort, nub, intersperse, maximumBy )-import Data.Maybe-         ( listToMaybe, fromJust, fromMaybe, isJust, isNothing )-import Control.Monad-         ( MonadPlus(mplus), join )-import Control.Exception-         ( assert )-import Text.PrettyPrint.HughesPJ as Disp-import System.Directory-         ( doesDirectoryExist )----- |Show information about packages-list :: Verbosity-     -> PackageDBStack-     -> [Repo]-     -> Compiler-     -> ProgramConfiguration-     -> ListFlags-     -> [String]-     -> IO ()-list verbosity packageDBs repos comp conf listFlags pats = do-    installed <- getInstalledPackages verbosity comp packageDBs conf-    AvailablePackageDb available _ <- getAvailablePackages verbosity repos-    let pkgs | null pats = (PackageIndex.allPackages installed-                           ,PackageIndex.allPackages available)-             | otherwise =-                 (concatMap (PackageIndex.searchByNameSubstring installed) pats-                 ,concatMap (PackageIndex.searchByNameSubstring available) pats)-        matches = installedFilter-                . map (uncurry mergePackageInfo)-                $ uncurry mergePackages pkgs--    if simpleOutput-      then putStr $ unlines-             [ display (pkgname pkg) ++ " " ++ display version-             | pkg <- matches-             , version <- if onlyInstalled-                            then              installedVersions pkg-                            else nub . sort $ installedVersions pkg-                                           ++ availableVersions pkg ]-      else-        if null matches-            then notice verbosity "No matches found."-            else putStr $ unlines (map showPackageSummaryInfo matches)-  where-    installedFilter-      | onlyInstalled = filter (not . null . installedVersions)-      | otherwise     = id-    onlyInstalled = fromFlag (listInstalled listFlags)-    simpleOutput  = fromFlag (listSimpleOutput listFlags)--info :: Verbosity-     -> PackageDBStack-     -> [Repo]-     -> Compiler-     -> ProgramConfiguration-     -> InfoFlags-     -> [UnresolvedDependency] --FIXME: just package names? or actually use the constraint-     -> IO ()-info verbosity packageDBs repos comp conf _listFlags deps = do-  AvailablePackageDb available _ <- getAvailablePackages verbosity repos-  deps' <- IndexUtils.disambiguateDependencies available deps-  installed <- getInstalledPackages verbosity comp packageDBs conf-  let deps'' = [ name | UnresolvedDependency (Dependency name _) _ <- deps' ]-  let pkgs = (concatMap (PackageIndex.lookupPackageName installed) deps''-             ,concatMap (PackageIndex.lookupPackageName available) deps'')-      pkgsinfo = map (uncurry mergePackageInfo)-               $ uncurry mergePackages pkgs--  pkgsinfo' <- mapM updateFileSystemPackageDetails pkgsinfo-  putStr $ unlines (map showPackageDetailedInfo pkgsinfo')---- | The info that we can display for each package. It is information per--- package name and covers all installed and avilable versions.----data PackageDisplayInfo = PackageDisplayInfo {-    pkgname           :: PackageName,-    allInstalled      :: [InstalledPackage],-    allAvailable      :: [AvailablePackage],-    latestInstalled   :: Maybe InstalledPackage,-    latestAvailable   :: Maybe AvailablePackage,-    homepage          :: String,-    bugReports        :: String,-    sourceRepo        :: String,-    synopsis          :: String,-    description       :: String,-    category          :: String,-    license           :: License,---    copyright         :: String, --TODO: is this useful?-    author            :: String,-    maintainer        :: String,-    dependencies      :: [Dependency],-    flags             :: [Flag],-    hasLib            :: Bool,-    hasExe            :: Bool,-    executables       :: [String],-    modules           :: [ModuleName],-    haddockHtml       :: FilePath,-    haveTarball       :: Bool-  }--installedVersions :: PackageDisplayInfo -> [Version]-installedVersions = map packageVersion . allInstalled--availableVersions :: PackageDisplayInfo -> [Version]-availableVersions = map packageVersion . allAvailable--showPackageSummaryInfo :: PackageDisplayInfo -> String-showPackageSummaryInfo pkginfo =-  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $-     char '*' <+> disp (pkgname pkginfo)-     $+$-     (nest 4 $ vcat [-       maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs-     , text "Latest version available:" <+>-       case latestAvailable pkginfo of-         Nothing  -> text "[ Not available from server ]"-         Just pkg -> disp (packageVersion pkg)-     , text "Latest version installed:" <+>-       case latestInstalled pkginfo of-         Nothing  | hasLib pkginfo -> text "[ Not installed ]"-                  | otherwise      -> text "[ Unknown ]"-         Just pkg -> disp (packageVersion pkg)-     , maybeShow (homepage pkginfo) "Homepage:" text-     , text "License: " <+> text (display (license pkginfo))-     ])-     $+$ text ""-  where-    maybeShow [] _ _ = empty-    maybeShow l  s f = text s <+> (f l)--showPackageDetailedInfo :: PackageDisplayInfo -> String-showPackageDetailedInfo pkginfo =-  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $-   char '*' <+> disp (pkgname pkginfo)-            <+> text (replicate (16 - length (display (pkgname pkginfo))) ' ')-            <>  parens pkgkind-   $+$-   (nest 4 $ vcat [-     entry "Synopsis"      synopsis     alwaysShow     reflowParagraphs-   , entry "Latest version available" latestAvailable-           (altText isNothing "[ Not available from server ]")-           (disp . packageVersion . fromJust)-   , entry "Latest version installed" latestInstalled-           (altText isNothing (if hasLib pkginfo then "[ Not installed ]"-                                                 else "[ Unknown ]"))-           (disp . packageVersion . fromJust)-   , entry "Homepage"      homepage     orNotSpecified text-   , entry "Bug reports"   bugReports   orNotSpecified text-   , entry "Description"   description  alwaysShow     reflowParagraphs-   , entry "Category"      category     hideIfNull     text-   , entry "License"       license      alwaysShow     disp-   , entry "Author"        author       hideIfNull     reflowLines-   , entry "Maintainer"    maintainer   hideIfNull     reflowLines-   , entry "Source repo"   sourceRepo   orNotSpecified text-   , entry "Executables"   executables  hideIfNull     (commaSep text)-   , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)-   , entry "Dependencies"  dependencies hideIfNull     (commaSep disp)-   , entry "Documentation" haddockHtml  showIfInstalled text-   , entry "Cached"        haveTarball  alwaysShow     dispYesNo-   , if not (hasLib pkginfo) then empty else-     text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))-   ])-   $+$ text ""-  where-    entry fname field cond format = case cond (field pkginfo) of-      Nothing           -> label <+> format (field pkginfo)-      Just Nothing      -> empty-      Just (Just other) -> label <+> text other-      where-        label   = text fname <> char ':' <> padding-        padding = text (replicate (13 - length fname ) ' ')--    normal      = Nothing-    hide        = Just Nothing-    replace msg = Just (Just msg)--    alwaysShow = const normal-    hideIfNull v = if null v then hide else normal-    showIfInstalled v-      | not isInstalled = hide-      | null v          = replace "[ Not installed ]"-      | otherwise       = normal-    altText nul msg v = if nul v then replace msg else normal-    orNotSpecified = altText null "[ Not specified ]"--    commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f-    dispFlag f = case flagName f of FlagName n -> text n-    dispYesNo True  = text "Yes"-    dispYesNo False = text "No"--    isInstalled = not (null (installedVersions pkginfo))-    hasExes = length (executables pkginfo) >= 2-    --TODO: exclude non-buildable exes-    pkgkind | hasLib pkginfo && hasExes        = text "programs and library"-            | hasLib pkginfo && hasExe pkginfo = text "program and library"-            | hasLib pkginfo                   = text "library"-            | hasExes                          = text "programs"-            | hasExe pkginfo                   = text "program"-            | otherwise                        = empty--reflowParagraphs :: String -> Doc-reflowParagraphs =-    vcat-  . intersperse (text "")                    -- re-insert blank lines-  . map (fsep . map text . concatMap words)  -- reflow paragraphs-  . filter (/= [""])-  . groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines-  . lines--reflowLines :: String -> Doc-reflowLines = vcat . map text . lines---- | We get the 'PackageDisplayInfo' by combining the info for the installed--- and available versions of a package.------ * We're building info about a various versions of a single named package so--- the input package info records are all supposed to refer to the same--- package name.----mergePackageInfo :: [InstalledPackage]-                 -> [AvailablePackage]-                 -> PackageDisplayInfo-mergePackageInfo installedPkgs availablePkgs =-  assert (length installedPkgs + length availablePkgs > 0) $-  PackageDisplayInfo {-    pkgname      = combine packageName available-                           packageName installed,-    allInstalled = installedPkgs,-    allAvailable = availablePkgs,-    latestInstalled = latest installedPkgs,-    latestAvailable = latest availablePkgs,-    license      = combine Available.license    available-                           Installed.license    installed,-    maintainer   = combine Available.maintainer available-                           Installed.maintainer installed,-    author       = combine Available.author     available-                           Installed.author     installed,-    homepage     = combine Available.homepage   available-                           Installed.homepage   installed,-    bugReports   = maybe "" Available.bugReports available,-    sourceRepo   = fromMaybe "" . join-                 . fmap (uncons Nothing Available.repoLocation-                       . sortBy (comparing Available.repoKind)-                       . Available.sourceRepos)-                 $ available,-    synopsis     = combine Available.synopsis    available-                           Installed.description installed,-    description  = combine Available.description available-                           Installed.description installed,-    category     = combine Available.category    available-                           Installed.category    installed,-    flags        = maybe [] Available.genPackageFlags availableGeneric,-    hasLib       = isJust installed-                || fromMaybe False-                   (fmap (isJust . Available.condLibrary) availableGeneric),-    hasExe       = fromMaybe False-                   (fmap (not . null . Available.condExecutables) availableGeneric),-    executables  = map fst (maybe [] Available.condExecutables availableGeneric),-    modules      = combine Installed.exposedModules installed-                           (maybe [] Available.exposedModules-                                   . Available.library) available,-    dependencies = combine Available.buildDepends available-                           (map thisPackageVersion . depends) installed',-    haddockHtml  = fromMaybe "" . join-                 . fmap (listToMaybe . Installed.haddockHTMLs)-                 $ installed,-    haveTarball  = False-  }-  where-    combine f x g y  = fromJust (fmap f x `mplus` fmap g y)-    installed'       = latest installedPkgs-    installed        = fmap (\(InstalledPackage p _) -> p) installed'-    availableGeneric = fmap packageDescription (latest availablePkgs)-    available        = fmap flattenPackageDescription availableGeneric-    latest []        = Nothing-    latest pkgs      = Just (maximumBy (comparing packageVersion) pkgs)--    uncons :: b -> (a -> b) -> [a] -> b-    uncons z _ []    = z-    uncons _ f (x:_) = f x---- | Not all the info is pure. We have to check if the docs really are--- installed, because the registered package info lies. Similarly we have to--- check if the tarball has indeed been fetched.----updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo-updateFileSystemPackageDetails pkginfo = do-  fetched   <- maybe (return False) isFetched (latestAvailable pkginfo)-  docsExist <- doesDirectoryExist (haddockHtml pkginfo)-  return pkginfo {-    haveTarball = fetched,-    haddockHtml = if docsExist then haddockHtml pkginfo else ""-  }---- | Rearrange installed and available packages into groups referring to the--- same package by name. In the result pairs, the lists are guaranteed to not--- both be empty.----mergePackages ::   [InstalledPackage] -> [AvailablePackage]-              -> [([InstalledPackage],   [AvailablePackage])]-mergePackages installed available =-    map collect-  $ mergeBy (\i a -> fst i `compare` fst a)-            (groupOn packageName installed)-            (groupOn packageName available)-  where-    collect (OnlyInLeft  (_,is)       ) = (is, [])-    collect (    InBoth  (_,is) (_,as)) = (is, as)-    collect (OnlyInRight        (_,as)) = ([], as)--groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]-groupOn key = map (\xs -> (key (head xs), xs))-            . groupBy (equating key)-            . sortBy (comparing key)
− cabal-install-0.9.5_rc20101226/Distribution/Client/PackageIndex.hs 
@@ -1,479 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.PackageIndex--- Copyright   :  (c) David Himmelstrup 2005,---                    Bjorn Bringert 2007,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ An index of packages.----module Distribution.Client.PackageIndex (-  -- * Package index data type-  PackageIndex,--  -- * Creating an index-  fromList,--  -- * Updates-  merge,-  insert,-  deletePackageName,-  deletePackageId,-  deleteDependency,--  -- * Queries--  -- ** Precise lookups-  lookupPackageName,-  lookupPackageId,-  lookupDependency,--  -- ** Case-insensitive searches-  searchByName,-  SearchResult(..),-  searchByNameSubstring,--  -- ** Bulk queries-  allPackages,-  allPackagesByName,--  -- ** Special queries-  brokenPackages,-  dependencyClosure,-  reverseDependencyClosure,-  topologicalOrder,-  reverseTopologicalOrder,-  dependencyInconsistencies,-  dependencyCycles,-  dependencyGraph,-  ) where--import Prelude hiding (lookup)-import Control.Exception (assert)-import qualified Data.Map as Map-import Data.Map (Map)-import qualified Data.Tree  as Tree-import qualified Data.Graph as Graph-import qualified Data.Array as Array-import Data.Array ((!))-import Data.List (groupBy, sortBy, nub, find, isInfixOf)-import Data.Monoid (Monoid(..))-import Data.Maybe (isNothing, fromMaybe)--import Distribution.Package-         ( PackageName(..), PackageIdentifier(..)-         , Package(..), packageName, packageVersion-         , Dependency(Dependency), PackageFixedDeps(..) )-import Distribution.Version-         ( Version, withinRange )-import Distribution.Simple.Utils (lowercase, equating, comparing)----- | The collection of information about packages from one or more 'PackageDB's.------ It can be searched effeciently by package name and version.----newtype Package pkg => PackageIndex pkg = PackageIndex-  -- This index package names to all the package records matching that package-  -- name case-sensitively. It includes all versions.-  ---  -- This allows us to find all versions satisfying a dependency.-  -- Most queries are a map lookup followed by a linear scan of the bucket.-  ---  (Map PackageName [pkg])--  deriving (Show, Read)--instance Package pkg => Monoid (PackageIndex pkg) where-  mempty  = PackageIndex (Map.empty)-  mappend = merge-  --save one mappend with empty in the common case:-  mconcat [] = mempty-  mconcat xs = foldr1 mappend xs--invariant :: Package pkg => PackageIndex pkg -> Bool-invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)-  where-    goodBucket _    [] = False-    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0-      where-        check pkgid []          = packageName pkgid == name-        check pkgid (pkg':pkgs) = packageName pkgid == name-                               && pkgid < pkgid'-                               && check pkgid' pkgs-          where pkgid' = packageId pkg'------- * Internal helpers-----mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg-mkPackageIndex index = assert (invariant (PackageIndex index))-                                         (PackageIndex index)--internalError :: String -> a-internalError name = error ("PackageIndex." ++ name ++ ": internal error")---- | Lookup a name in the index to get all packages that match that name--- case-sensitively.----lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]-lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m------- * Construction------- | Build an index out of a bunch of packages.------ If there are duplicates, later ones mask earlier ones.----fromList :: Package pkg => [pkg] -> PackageIndex pkg-fromList pkgs = mkPackageIndex-              . Map.map fixBucket-              . Map.fromListWith (++)-              $ [ (packageName pkg, [pkg])-                | pkg <- pkgs ]-  where-    fixBucket = -- out of groups of duplicates, later ones mask earlier ones-                -- but Map.fromListWith (++) constructs groups in reverse order-                map head-                -- Eq instance for PackageIdentifier is wrong, so use Ord:-              . groupBy (\a b -> EQ == comparing packageId a b)-                -- relies on sortBy being a stable sort so we-                -- can pick consistently among duplicates-              . sortBy (comparing packageId)------- * Updates------- | Merge two indexes.------ Packages from the second mask packages of the same exact name--- (case-sensitively) from the first.----merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg-merge i1@(PackageIndex m1) i2@(PackageIndex m2) =-  assert (invariant i1 && invariant i2) $-    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)---- | Elements in the second list mask those in the first.-mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]-mergeBuckets []     ys     = ys-mergeBuckets xs     []     = xs-mergeBuckets xs@(x:xs') ys@(y:ys') =-      case packageId x `compare` packageId y of-        GT -> y : mergeBuckets xs  ys'-        EQ -> y : mergeBuckets xs' ys'-        LT -> x : mergeBuckets xs' ys---- | Inserts a single package into the index.------ This is equivalent to (but slightly quicker than) using 'mappend' or--- 'merge' with a singleton index.----insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg-insert pkg (PackageIndex index) = mkPackageIndex $-  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index-  where-    pkgid = packageId pkg-    insertNoDup []                = [pkg]-    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of-      LT -> pkg  : pkgs-      EQ -> pkg  : pkgs'-      GT -> pkg' : insertNoDup pkgs'---- | Internal delete helper.----delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg-delete name p (PackageIndex index) = mkPackageIndex $-  Map.update filterBucket name index-  where-    filterBucket = deleteEmptyBucket-                 . filter (not . p)-    deleteEmptyBucket []        = Nothing-    deleteEmptyBucket remaining = Just remaining---- | Removes a single package from the index.----deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg-deletePackageId pkgid =-  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)---- | Removes all packages with this (case-sensitive) name from the index.----deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg-deletePackageName name =-  delete name (\pkg -> packageName pkg == name)---- | Removes all packages satisfying this dependency from the index.----deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg-deleteDependency (Dependency name verstionRange) =-  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)------- * Bulk queries------- | Get all the packages from the index.----allPackages :: Package pkg => PackageIndex pkg -> [pkg]-allPackages (PackageIndex m) = concat (Map.elems m)---- | Get all the packages from the index.------ They are grouped by package name, case-sensitively.----allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]-allPackagesByName (PackageIndex m) = Map.elems m------- * Lookups------- | Does a lookup by package id (name & version).------ Since multiple package DBs mask each other case-sensitively by package name,--- then we get back at most one package.----lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg-lookupPackageId index pkgid =-  case [ pkg | pkg <- lookup index (packageName pkgid)-             , packageId pkg == pkgid ] of-    []    -> Nothing-    [pkg] -> Just pkg-    _     -> internalError "lookupPackageIdentifier"---- | Does a case-sensitive search by package name.----lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]-lookupPackageName index name =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name ]---- | Does a case-sensitive search by 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 :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]-lookupDependency index (Dependency name versionRange) =-  [ pkg | pkg <- lookup index name-        , packageName pkg == name-        , packageVersion pkg `withinRange` versionRange ]------- * Case insensitive name lookups------- | Does a case-insensitive search by package name.------ If there is only one package that compares case-insentiviely to this name--- then the search is unambiguous and we get back all versions of that package.--- If several match case-insentiviely but one matches exactly then it is also--- unambiguous.------ If however several match case-insentiviely 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 :: Package pkg => PackageIndex pkg -> String -> SearchResult [pkg]-searchByName (PackageIndex m) name =-  case [ pkgs | pkgs@(PackageName name',_) <- Map.toList m-              , lowercase name' == lname ] of-    []              -> None-    [(_,pkgs)]      -> Unambiguous pkgs-    pkgss           -> case find ((PackageName name==) . fst) pkgss of-      Just (_,pkgs) -> Unambiguous pkgs-      Nothing       -> Ambiguous (map 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 :: Package pkg => PackageIndex pkg -> String -> [pkg]-searchByNameSubstring (PackageIndex m) searchterm =-  [ pkg-  | (PackageName name, pkgs) <- Map.toList m-  , lsearchterm `isInfixOf` lowercase name-  , pkg <- pkgs ]-  where lsearchterm = lowercase searchterm------- * Special queries------- | All packages that have dependencies that are not in the index.------ Returns such packages along with the dependencies that they're missing.----brokenPackages :: PackageFixedDeps pkg-               => PackageIndex pkg-               -> [(pkg, [PackageIdentifier])]-brokenPackages index =-  [ (pkg, missing)-  | pkg  <- allPackages index-  , let missing = [ pkg' | pkg' <- depends pkg-                         , isNothing (lookupPackageId index pkg') ]-  , not (null missing) ]---- | Tries to take the transative closure of the package dependencies.------ If the transative 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 'PackageIdentifier's do not occur in the index.----dependencyClosure :: PackageFixedDeps pkg-                  => PackageIndex pkg-                  -> [PackageIdentifier]-                  -> Either (PackageIndex pkg)-                            [(pkg, [PackageIdentifier])]-dependencyClosure 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 lookupPackageId index pkgid of-      Nothing   -> closure completed (pkgid:failed) pkgids-      Just pkg  -> case lookupPackageId completed (packageId pkg) of-        Just _  -> closure completed  failed pkgids-        Nothing -> closure completed' failed pkgids'-          where completed' = insert pkg completed-                pkgids'    = depends pkg ++ pkgids---- | Takes the transative closure of the packages reverse dependencies.------ * The given 'PackageIdentifier's must be in the index.----reverseDependencyClosure :: PackageFixedDeps pkg-                         => PackageIndex pkg-                         -> [PackageIdentifier]-                         -> [pkg]-reverseDependencyClosure index =-    map vertexToPkg-  . concatMap Tree.flatten-  . Graph.dfs reverseDepGraph-  . map (fromMaybe noSuchPkgId . pkgIdToVertex)--  where-    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index-    reverseDepGraph = Graph.transposeG depGraph-    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"--topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]-topologicalOrder index = map toPkgId-                       . Graph.topSort-                       $ graph-  where (graph, toPkgId, _) = dependencyGraph index--reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]-reverseTopologicalOrder index = map toPkgId-                              . Graph.topSort-                              . Graph.transposeG-                              $ graph-  where (graph, toPkgId, _) = dependencyGraph index---- | 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 :: PackageFixedDeps pkg-                          => PackageIndex pkg-                          -> [(PackageName, [(PackageIdentifier, Version)])]-dependencyInconsistencies index =-  [ (name, inconsistencies)-  | (name, uses) <- Map.toList inverseIndex-  , let inconsistencies = duplicatesBy uses-        versions = map snd inconsistencies-  , reallyIsInconsistent name (nub versions) ]--  where inverseIndex = Map.fromListWith (++)-          [ (packageName dep, [(packageId pkg, packageVersion dep)])-          | pkg <- allPackages index-          , dep <- depends pkg ]--        duplicatesBy = (\groups -> if length groups == 1-                                     then []-                                     else concat groups)-                     . groupBy (equating snd)-                     . sortBy (comparing snd)--        reallyIsInconsistent :: PackageName -> [Version] -> Bool-        reallyIsInconsistent _    []       = False-        reallyIsInconsistent name [v1, v2] =-          case (mpkg1, mpkg2) of-            (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2-                                   && pkgid2 `notElem` depends pkg1-            _ -> True-          where-            pkgid1 = PackageIdentifier name v1-            pkgid2 = PackageIdentifier name v2-            mpkg1 = lookupPackageId index pkgid1-            mpkg2 = lookupPackageId index pkgid2--        reallyIsInconsistent _ _ = True---- | 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 :: PackageFixedDeps pkg-                 => PackageIndex pkg-                 -> [[pkg]]-dependencyCycles index =-  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]-  where-    adjacencyList = [ (pkg, packageId pkg, depends pkg)-                    | pkg <- allPackages 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 :: PackageFixedDeps pkg-                => PackageIndex pkg-                -> (Graph.Graph,-                    Graph.Vertex -> pkg,-                    PackageIdentifier -> Maybe Graph.Vertex)-dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)-  where-    graph = Array.listArray bounds-              [ [ v | Just v <- map pkgIdToVertex (depends pkg) ]-              | pkg <- pkgs ]-    vertexToPkg vertex = pkgTable ! vertex-    pkgIdToVertex = binarySearch 0 topBound--    pkgTable   = Array.listArray bounds pkgs-    pkgIdTable = Array.listArray bounds (map packageId pkgs)-    pkgs = sortBy (comparing packageId) (allPackages index)-    topBound = length pkgs - 1-    bounds = (0, topBound)--    binarySearch a b key-      | a > b     = Nothing-      | otherwise = case compare key (pkgIdTable ! mid) of-          LT -> binarySearch a (mid-1) key-          EQ -> Just mid-          GT -> binarySearch (mid+1) b key-      where mid = (a + b) `div` 2
− cabal-install-0.9.5_rc20101226/Distribution/Client/PackageUtils.hs 
@@ -1,34 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.PackageUtils--- Copyright   :  (c) Duncan Coutts 2010--- License     :  BSD-like------ Maintainer  :  cabal-devel@gmail.com--- Stability   :  provisional--- Portability :  portable------ Various package description utils that should be in the Cabal lib-------------------------------------------------------------------------------module Distribution.Client.PackageUtils (-    externalBuildDepends,-  ) where--import Distribution.Package-         ( packageVersion, packageName, Dependency(..) )-import Distribution.PackageDescription-         ( PackageDescription(..) )-import Distribution.Version-         ( withinRange )---- | The list of dependencies that refer to external packages--- rather than internal package components.----externalBuildDepends :: PackageDescription -> [Dependency]-externalBuildDepends pkg = filter (not . internal) (buildDepends pkg)-  where-    -- True if this dependency is an internal one (depends on a library-    -- defined in the same package).-    internal (Dependency depName versionRange) =-            depName == packageName pkg &&-            packageVersion pkg `withinRange` versionRange
− cabal-install-0.9.5_rc20101226/Distribution/Client/Setup.hs 
@@ -1,952 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Setup--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Distribution.Client.Setup-    ( globalCommand, GlobalFlags(..), globalRepos-    , configureCommand, ConfigFlags(..), filterConfigureFlags-    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags-                        , configureExOptions-    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags-    , listCommand, ListFlags(..)-    , updateCommand-    , upgradeCommand-    , infoCommand, InfoFlags(..)-    , fetchCommand, FetchFlags(..)-    , checkCommand-    , uploadCommand, UploadFlags(..)-    , reportCommand-    , unpackCommand, UnpackFlags(..)-    , initCommand, IT.InitFlags(..)--    , parsePackageArgs-    --TODO: stop exporting these:-    , showRepo-    , parseRepo-    ) where--import Distribution.Client.Types-         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )-import Distribution.Client.BuildReports.Types-         ( ReportLevel(..) )-import qualified Distribution.Client.Init.Types as IT-         ( InitFlags(..), PackageType(..) )--import Distribution.Simple.Program-         ( defaultProgramConfiguration )-import Distribution.Simple.Command hiding (boolOpt)-import qualified Distribution.Simple.Command as Command-import qualified Distribution.Simple.Setup as Cabal-         ( configureCommand )-import Distribution.Simple.Setup-         ( ConfigFlags(..) )-import Distribution.Simple.Setup-         ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe-         , optionVerbosity, trueArg, falseArg )-import Distribution.Simple.InstallDirs-         ( PathTemplate, toPathTemplate, fromPathTemplate )-import Distribution.Version-         ( Version(Version), anyVersion, thisVersion )-import Distribution.Package-         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )-import Distribution.Text-         ( Text(parse), display )-import Distribution.ReadE-         ( readP_to_E, succeedReadE )-import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, readP_to_S, char, munch1, pfail, (+++) )-import Distribution.Verbosity-         ( Verbosity, normal )-import Distribution.Simple.Utils-         ( wrapText )--import Data.Char-         ( isSpace, isAlphaNum )-import Data.Maybe-         ( listToMaybe, maybeToList, fromMaybe )-import Data.Monoid-         ( Monoid(..) )-import Control.Monad-         ( liftM )-import System.FilePath-         ( (</>) )-import Network.URI-         ( parseAbsoluteURI, uriToString )---- --------------------------------------------------------------- * Global flags--- ---------------------------------------------------------------- | Flags that apply at the top level, not to any sub-command.-data GlobalFlags = GlobalFlags {-    globalVersion        :: Flag Bool,-    globalNumericVersion :: Flag Bool,-    globalConfigFile     :: Flag FilePath,-    globalRemoteRepos    :: [RemoteRepo],     -- ^Available Hackage servers.-    globalCacheDir       :: Flag FilePath,-    globalLocalRepos     :: [FilePath],-    globalLogsDir        :: Flag FilePath,-    globalWorldFile      :: Flag FilePath-  }--defaultGlobalFlags :: GlobalFlags-defaultGlobalFlags  = GlobalFlags {-    globalVersion        = Flag False,-    globalNumericVersion = Flag False,-    globalConfigFile     = mempty,-    globalRemoteRepos    = [],-    globalCacheDir       = mempty,-    globalLocalRepos     = mempty,-    globalLogsDir        = mempty,-    globalWorldFile      = mempty-  }--globalCommand :: CommandUI GlobalFlags-globalCommand = CommandUI {-    commandName         = "",-    commandSynopsis     = "",-    commandUsage        = \_ ->-         "This program is the command line interface "-           ++ "to the Haskell Cabal infrastructure.\n"-      ++ "See http://www.haskell.org/cabal/ for more information.\n",-    commandDescription  = Just $ \pname ->-         "For more information about a command use:\n"-      ++ "  " ++ pname ++ " COMMAND --help\n\n"-      ++ "To install Cabal packages from hackage use:\n"-      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"-      ++ "Occasionally you need to update the list of available packages:\n"-      ++ "  " ++ pname ++ " update\n",-    commandDefaultFlags = defaultGlobalFlags,-    commandOptions      = \showOrParseArgs ->-      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)-      [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--      ,option [] ["config-file"]-         "Set an alternate location for the config file"-         globalConfigFile (\v flags -> flags { globalConfigFile = v })-         (reqArgFlag "FILE")--      ,option [] ["remote-repo"]-         "The name and url for a remote repository"-         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })-         (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo))--      ,option [] ["remote-repo-cache"]-         "The location where downloads from all remote repos are cached"-         globalCacheDir (\v flags -> flags { globalCacheDir = v })-         (reqArgFlag "DIR")--      ,option [] ["local-repo"]-         "The location of a local repository"-         globalLocalRepos (\v flags -> flags { globalLocalRepos = v })-         (reqArg' "DIR" (\x -> [x]) id)--      ,option [] ["logs-dir"]-         "The location to put log files"-         globalLogsDir (\v flags -> flags { globalLogsDir = v })-         (reqArgFlag "DIR")--      ,option [] ["world-file"]-         "The location of the world file"-         globalWorldFile (\v flags -> flags { globalWorldFile = v })-         (reqArgFlag "FILE")-      ]-  }--instance Monoid GlobalFlags where-  mempty = GlobalFlags {-    globalVersion        = mempty,-    globalNumericVersion = mempty,-    globalConfigFile     = mempty,-    globalRemoteRepos    = mempty,-    globalCacheDir       = mempty,-    globalLocalRepos     = mempty,-    globalLogsDir        = mempty,-    globalWorldFile      = mempty-  }-  mappend a b = GlobalFlags {-    globalVersion        = combine globalVersion,-    globalNumericVersion = combine globalNumericVersion,-    globalConfigFile     = combine globalConfigFile,-    globalRemoteRepos    = combine globalRemoteRepos,-    globalCacheDir       = combine globalCacheDir,-    globalLocalRepos     = combine globalLocalRepos,-    globalLogsDir        = combine globalLogsDir,-    globalWorldFile      = combine globalWorldFile-  }-    where combine field = field a `mappend` field b--globalRepos :: GlobalFlags -> [Repo]-globalRepos globalFlags = remoteRepos ++ localRepos-  where-    remoteRepos =-      [ Repo (Left remote) cacheDir-      | remote <- globalRemoteRepos globalFlags-      , let cacheDir = fromFlag (globalCacheDir globalFlags)-                   </> remoteRepoName remote ]-    localRepos =-      [ Repo (Right LocalRepo) local-      | local <- globalLocalRepos globalFlags ]---- --------------------------------------------------------------- * Config flags--- --------------------------------------------------------------configureCommand :: CommandUI ConfigFlags-configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {-    commandDefaultFlags = mempty-  }--configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]-configureOptions = commandOptions configureCommand--filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags-filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,3,10] [] = flags-    -- older Cabal does not grok the constraints flag:-  | otherwise = flags { configConstraints = [] }----- --------------------------------------------------------------- * Config extra flags--- ---------------------------------------------------------------- | cabal configure takes some extra flags beyond runghc Setup configure----data ConfigExFlags = ConfigExFlags {-    configCabalVersion :: Flag Version,-    configPreferences  :: [Dependency]-  }--defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty--configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)-configureExCommand = configureCommand {-    commandDefaultFlags = (mempty, defaultConfigExFlags),-    commandOptions      = \showOrParseArgs ->-         liftOptions fst setFst (configureOptions   showOrParseArgs)-      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)-  }-  where-    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)--configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]-configureExOptions _showOrParseArgs =-  [ option [] ["cabal-lib-version"]-      ("Select which version of the Cabal lib to use to build packages "-      ++ "(useful for testing).")-      configCabalVersion (\v flags -> flags { configCabalVersion = v })-      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)-                                    (fmap toFlag parse))-                        (map display . flagToList))--  , option [] ["preference"]-      "Specify preferences (soft constraints) on the version of a package"-      configPreferences (\v flags -> flags { configPreferences = v })-      (reqArg "DEPENDENCY"-        (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))-                                        (map (\x -> display x)))-  ]--instance Monoid ConfigExFlags where-  mempty = ConfigExFlags {-    configCabalVersion = mempty,-    configPreferences  = mempty-  }-  mappend a b = ConfigExFlags {-    configCabalVersion = combine configCabalVersion,-    configPreferences  = combine configPreferences-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Fetch command--- --------------------------------------------------------------data FetchFlags = FetchFlags {---    fetchOutput    :: Flag FilePath,-      fetchDeps      :: Flag Bool,-      fetchDryRun    :: Flag Bool,-      fetchVerbosity :: Flag Verbosity-    }--defaultFetchFlags :: FetchFlags-defaultFetchFlags = FetchFlags {---  fetchOutput    = mempty,-    fetchDeps      = toFlag True,-    fetchDryRun    = toFlag False,-    fetchVerbosity = toFlag normal-   }--fetchCommand :: CommandUI FetchFlags-fetchCommand = CommandUI {-    commandName         = "fetch",-    commandSynopsis     = "Downloads packages for later installation.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "fetch",-    commandDefaultFlags = defaultFetchFlags,-    commandOptions      = \_ -> [-         optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })----     , option "o" ["output"]---         "Put the package(s) somewhere specific rather than the usual cache."---         fetchOutput (\v flags -> flags { fetchOutput = v })---         (reqArgFlag "PATH")--       , option [] ["dependencies", "deps"]-           "Resolve and fetch dependencies (default)"-           fetchDeps (\v flags -> flags { fetchDeps = v })-           trueArg--       , option [] ["no-dependencies", "no-deps"]-           "Ignore dependencies"-           fetchDeps (\v flags -> flags { fetchDeps = v })-           falseArg--       , option [] ["dry-run"]-           "Do not install anything, only print what would be installed."-           fetchDryRun (\v flags -> flags { fetchDryRun = v })-           trueArg-       ]-  }---- --------------------------------------------------------------- * Other commands--- --------------------------------------------------------------updateCommand  :: CommandUI (Flag Verbosity)-updateCommand = CommandUI {-    commandName         = "update",-    commandSynopsis     = "Updates list of known packages",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "update",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]-  }--upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)-upgradeCommand = configureCommand {-    commandName         = "upgrade",-    commandSynopsis     = "(command disabled, use install instead)",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "upgrade",-    commandDefaultFlags = (mempty, mempty, mempty),-    commandOptions      = commandOptions installCommand-  }--{--cleanCommand  :: CommandUI ()-cleanCommand = makeCommand name shortDesc longDesc emptyFlags options-  where-    name       = "clean"-    shortDesc  = "Removes downloaded files"-    longDesc   = Nothing-    emptyFlags = ()-    options _  = []--}--checkCommand  :: CommandUI (Flag Verbosity)-checkCommand = CommandUI {-    commandName         = "check",-    commandSynopsis     = "Check the package for common mistakes",-    commandDescription  = Nothing,-    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> []-  }--reportCommand :: CommandUI (Flag Verbosity)-reportCommand = CommandUI {-    commandName         = "report",-    commandSynopsis     = "Upload build reports to a remote server.",-    commandDescription  = Nothing,-    commandUsage        = \pname -> "Usage: " ++ pname ++ " report\n",-    commandDefaultFlags = toFlag normal,-    commandOptions      = \_ -> [optionVerbosity id const]-  }---- --------------------------------------------------------------- * Unpack flags--- --------------------------------------------------------------data UnpackFlags = UnpackFlags {-      unpackDestDir :: Flag FilePath,-      unpackVerbosity :: Flag Verbosity-    }--defaultUnpackFlags :: UnpackFlags-defaultUnpackFlags = UnpackFlags {-    unpackDestDir = mempty,-    unpackVerbosity = toFlag normal-   }--unpackCommand :: CommandUI UnpackFlags-unpackCommand = CommandUI {-    commandName         = "unpack",-    commandSynopsis     = "Unpacks packages for user inspection.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "unpack",-    commandDefaultFlags = mempty,-    commandOptions      = \_ -> [-        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })--       ,option "d" ["destdir"]-         "where to unpack the packages, defaults to the current directory."-         unpackDestDir (\v flags -> flags { unpackDestDir = v })-         (reqArgFlag "PATH")-       ]-  }--instance Monoid UnpackFlags where-  mempty = defaultUnpackFlags-  mappend a b = UnpackFlags {-     unpackDestDir = combine unpackDestDir-    ,unpackVerbosity = combine unpackVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * List flags--- --------------------------------------------------------------data ListFlags = ListFlags {-    listInstalled :: Flag Bool,-    listSimpleOutput :: Flag Bool,-    listVerbosity :: Flag Verbosity-  }--defaultListFlags :: ListFlags-defaultListFlags = ListFlags {-    listInstalled = Flag False,-    listSimpleOutput = Flag False,-    listVerbosity = toFlag normal-  }--listCommand  :: CommandUI ListFlags-listCommand = CommandUI {-    commandName         = "list",-    commandSynopsis     = "List packages matching a search string.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "list",-    commandDefaultFlags = defaultListFlags,-    commandOptions      = \_ -> [-        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })--        , option [] ["installed"]-            "Only print installed packages"-            listInstalled (\v flags -> flags { listInstalled = v })-            trueArg--        , option [] ["simple-output"]-            "Print in a easy-to-parse format"-            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })-            trueArg--        ]-  }--instance Monoid ListFlags where-  mempty = defaultListFlags-  mappend a b = ListFlags {-    listInstalled = combine listInstalled,-    listSimpleOutput = combine listSimpleOutput,-    listVerbosity = combine listVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Info flags--- --------------------------------------------------------------data InfoFlags = InfoFlags {-    infoVerbosity :: Flag Verbosity-  }--defaultInfoFlags :: InfoFlags-defaultInfoFlags = InfoFlags {-    infoVerbosity = toFlag normal-  }--infoCommand  :: CommandUI InfoFlags-infoCommand = CommandUI {-    commandName         = "info",-    commandSynopsis     = "Display detailed information about a particular package.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "info",-    commandDefaultFlags = defaultInfoFlags,-    commandOptions      = \_ -> [-        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })-        ]-  }--instance Monoid InfoFlags where-  mempty = defaultInfoFlags-  mappend a b = InfoFlags {-    infoVerbosity = combine infoVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Install flags--- ---------------------------------------------------------------- | Install takes the same flags as configure along with a few extras.----data InstallFlags = InstallFlags {-    installDocumentation:: Flag Bool,-    installHaddockIndex :: Flag PathTemplate,-    installDryRun       :: Flag Bool,-    installReinstall    :: Flag Bool,-    installUpgradeDeps  :: Flag Bool,-    installOnly         :: Flag Bool,-    installRootCmd      :: Flag String,-    installSummaryFile  :: [PathTemplate],-    installLogFile      :: Flag PathTemplate,-    installBuildReports :: Flag ReportLevel,-    installSymlinkBinDir:: Flag FilePath,-    installOneShot      :: Flag Bool-  }--defaultInstallFlags :: InstallFlags-defaultInstallFlags = InstallFlags {-    installDocumentation= Flag False,-    installHaddockIndex = Flag docIndexFile,-    installDryRun       = Flag False,-    installReinstall    = Flag False,-    installUpgradeDeps  = Flag False,-    installOnly         = Flag False,-    installRootCmd      = mempty,-    installSummaryFile  = mempty,-    installLogFile      = mempty,-    installBuildReports = Flag NoReports,-    installSymlinkBinDir= mempty,-    installOneShot      = Flag False-  }-  where-    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")--installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)-installCommand = CommandUI {-  commandName         = "install",-  commandSynopsis     = "Installs a list of packages.",-  commandUsage        = usagePackages "install",-  commandDescription  = Just $ \pname ->-    let original = case commandDescription configureCommand of-          Just desc -> desc pname ++ "\n"-          Nothing   -> ""-     in original-     ++ "Examples:\n"-     ++ "  " ++ pname ++ " install                 "-     ++ "    Package in the current directory\n"-     ++ "  " ++ pname ++ " install foo             "-     ++ "    Package from the hackage server\n"-     ++ "  " ++ pname ++ " install foo-1.0         "-     ++ "    Specific version of a package\n"-     ++ "  " ++ pname ++ " install 'foo < 2'       "-     ++ "    Constrained package version\n",-  commandDefaultFlags = (mempty, mempty, mempty),-  commandOptions      = \showOrParseArgs ->-       liftOptions get1 set1 (configureOptions   showOrParseArgs)-    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)-    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)-  }-  where-    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)-    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)-    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)--installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]-installOptions showOrParseArgs =-      [ option "" ["documentation"]-          "building of documentation"-          installDocumentation (\v flags -> flags { installDocumentation = v })-          (boolOpt [] [])--      , option [] ["doc-index-file"]-          "A central index of haddock API documentation (template cannot use $pkgid)"-          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })-          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)-                              (flagToList . fmap fromPathTemplate))--      , option [] ["dry-run"]-          "Do not install anything, only print what would be installed."-          installDryRun (\v flags -> flags { installDryRun = v })-          trueArg--      , option [] ["reinstall"]-          "Install even if it means installing the same version again."-          installReinstall (\v flags -> flags { installReinstall = v })-          trueArg--      , option [] ["upgrade-dependencies"]-          "Pick the latest version for all dependencies, rather than trying to pick an installed version."-          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })-          trueArg--      , option [] ["root-cmd"]-          "Command used to gain root privileges, when installing with --global."-          installRootCmd (\v flags -> flags { installRootCmd = v })-          (reqArg' "COMMAND" toFlag flagToList)--      , option [] ["symlink-bindir"]-          "Add symlinks to installed executables into this directory."-           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })-           (reqArgFlag "DIR")--      , option [] ["build-summary"]-          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"-          installSummaryFile (\v flags -> flags { installSummaryFile = v })-          (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate))--      , option [] ["build-log"]-          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"-          installLogFile (\v flags -> flags { installLogFile = v })-          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)-                              (flagToList . fmap fromPathTemplate))--      , option [] ["remote-build-reporting"]-          "Generate build reports to send to a remote server (none, anonymous or detailed)."-          installBuildReports (\v flags -> flags { installBuildReports = v })-          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "-                                            ++ "'anonymous' or 'detailed'")-                                      (toFlag `fmap` parse))-                          (flagToList . fmap display))--      , option [] ["one-shot"]-          "Do not record the packages in the world file."-          installOneShot (\v flags -> flags { installOneShot = v })-          trueArg-      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids-          ParseArgs ->-            option [] ["only"]-              "Only installs the package in the current directory."-              installOnly (\v flags -> flags { installOnly = v })-              trueArg-             : []-          _ -> []--instance Monoid InstallFlags where-  mempty = InstallFlags {-    installDocumentation= mempty,-    installHaddockIndex = mempty,-    installDryRun       = mempty,-    installReinstall    = mempty,-    installUpgradeDeps  = mempty,-    installOnly         = mempty,-    installRootCmd      = mempty,-    installSummaryFile  = mempty,-    installLogFile      = mempty,-    installBuildReports = mempty,-    installSymlinkBinDir= mempty,-    installOneShot      = mempty-  }-  mappend a b = InstallFlags {-    installDocumentation= combine installDocumentation,-    installHaddockIndex = combine installHaddockIndex,-    installDryRun       = combine installDryRun,-    installReinstall    = combine installReinstall,-    installUpgradeDeps  = combine installUpgradeDeps,-    installOnly         = combine installOnly,-    installRootCmd      = combine installRootCmd,-    installSummaryFile  = combine installSummaryFile,-    installLogFile      = combine installLogFile,-    installBuildReports = combine installBuildReports,-    installSymlinkBinDir= combine installSymlinkBinDir,-    installOneShot      = combine installOneShot-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Upload flags--- --------------------------------------------------------------data UploadFlags = UploadFlags {-    uploadCheck     :: Flag Bool,-    uploadUsername  :: Flag Username,-    uploadPassword  :: Flag Password,-    uploadVerbosity :: Flag Verbosity-  }--defaultUploadFlags :: UploadFlags-defaultUploadFlags = UploadFlags {-    uploadCheck     = toFlag False,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = toFlag normal-  }--uploadCommand :: CommandUI UploadFlags-uploadCommand = CommandUI {-    commandName         = "upload",-    commandSynopsis     = "Uploads source packages to Hackage",-    commandDescription  = Just $ \_ ->-         "You can store your Hackage login in the ~/.cabal/config file\n",-    commandUsage        = \pname ->-         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"-      ++ "Flags for upload:",-    commandDefaultFlags = defaultUploadFlags,-    commandOptions      = \_ ->-      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })--      ,option ['c'] ["check"]-         "Do not upload, just do QA checks."-        uploadCheck (\v flags -> flags { uploadCheck = v })-        trueArg--      ,option ['u'] ["username"]-        "Hackage username."-        uploadUsername (\v flags -> flags { uploadUsername = v })-        (reqArg' "USERNAME" (toFlag . Username)-                            (flagToList . fmap unUsername))--      ,option ['p'] ["password"]-        "Hackage password."-        uploadPassword (\v flags -> flags { uploadPassword = v })-        (reqArg' "PASSWORD" (toFlag . Password)-                            (flagToList . fmap unPassword))-      ]-  }--instance Monoid UploadFlags where-  mempty = UploadFlags {-    uploadCheck     = mempty,-    uploadUsername  = mempty,-    uploadPassword  = mempty,-    uploadVerbosity = mempty-  }-  mappend a b = UploadFlags {-    uploadCheck     = combine uploadCheck,-    uploadUsername  = combine uploadUsername,-    uploadPassword  = combine uploadPassword,-    uploadVerbosity = combine uploadVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Init flags--- --------------------------------------------------------------emptyInitFlags :: IT.InitFlags-emptyInitFlags  = mempty--defaultInitFlags :: IT.InitFlags-defaultInitFlags  = emptyInitFlags--initCommand :: CommandUI IT.InitFlags-initCommand = CommandUI {-    commandName = "init",-    commandSynopsis = "Interactively create a .cabal file.",-    commandDescription = Just $ \_ -> wrapText $-         "Cabalise a project by creating a .cabal, Setup.hs, and "-      ++ "optionally a LICENSE file.\n\n"-      ++ "Calling init with no arguments (recommended) uses an "-      ++ "interactive mode, which will try to guess as much as "-      ++ "possible and prompt you for the rest.  Command-line "-      ++ "arguments are provided for scripting purposes. "-      ++ "If you don't want interactive mode, be sure to pass "-      ++ "the -n flag.\n",-    commandUsage = \pname ->-         "Usage: " ++ pname ++ " init [FLAGS]\n\n"-      ++ "Flags for init:",-    commandDefaultFlags = defaultInitFlags,-    commandOptions = \_ ->-      [ option ['n'] ["non-interactive"]-        "Non-interactive mode."-        IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v })-        trueArg--      , option ['q'] ["quiet"]-        "Do not generate log messages to stdout."-        IT.quiet (\v flags -> flags { IT.quiet = v })-        trueArg--      , option [] ["no-comments"]-        "Do not generate explanatory comments in the .cabal file."-        IT.noComments (\v flags -> flags { IT.noComments = v })-        trueArg--      , option ['m'] ["minimal"]-        "Generate a minimal .cabal file, that is, do not include extra empty fields.  Also implies --no-comments."-        IT.minimal (\v flags -> flags { IT.minimal = v })-        trueArg--      , option [] ["package-dir"]-        "Root directory of the package (default = current directory)."-        IT.packageDir (\v flags -> flags { IT.packageDir = v })-        (reqArgFlag "DIRECTORY")--      , option ['p'] ["package-name"]-        "Name of the Cabal package to create."-        IT.packageName (\v flags -> flags { IT.packageName = v })-        (reqArgFlag "PACKAGE")--      , option [] ["version"]-        "Initial version of the package."-        IT.version (\v flags -> flags { IT.version = v })-        (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++)-                                      (toFlag `fmap` parse))-                          (flagToList . fmap display))--      , option [] ["cabal-version"]-        "Required version of the Cabal library."-        IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })-        (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++)-                                            (toFlag `fmap` parse))-                                (flagToList . fmap display))--      , option ['l'] ["license"]-        "Project license."-        IT.license (\v flags -> flags { IT.license = v })-        (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++)-                                      (toFlag `fmap` parse))-                          (flagToList . fmap display))--      , option ['a'] ["author"]-        "Name of the project's author."-        IT.author (\v flags -> flags { IT.author = v })-        (reqArgFlag "NAME")--      , option ['e'] ["email"]-        "Email address of the maintainer."-        IT.email (\v flags -> flags { IT.email = v })-        (reqArgFlag "EMAIL")--      , option ['u'] ["homepage"]-        "Project homepage and/or repository."-        IT.homepage (\v flags -> flags { IT.homepage = v })-        (reqArgFlag "URL")--      , option ['s'] ["synopsis"]-        "Short project synopsis."-        IT.synopsis (\v flags -> flags { IT.synopsis = v })-        (reqArgFlag "TEXT")--      , option ['c'] ["category"]-        "Project category."-        IT.category (\v flags -> flags { IT.category = v })-        (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))-                            (flagToList . fmap (either id show)))--      , option [] ["is-library"]-        "Build a library."-        IT.packageType (\v flags -> flags { IT.packageType = v })-        (noArg (Flag IT.Library))--      , option [] ["is-executable"]-        "Build an executable."-        IT.packageType-        (\v flags -> flags { IT.packageType = v })-        (noArg (Flag IT.Executable))--      , option ['o'] ["expose-module"]-        "Export a module from the package."-        IT.exposedModules-        (\v flags -> flags { IT.exposedModules = v })-        (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++)-                                     ((Just . (:[])) `fmap` parse))-                         (fromMaybe [] . fmap (fmap display)))--      , option ['d'] ["dependency"]-        "Package dependency."-        IT.dependencies (\v flags -> flags { IT.dependencies = v })-        (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++)-                                      ((Just . (:[])) `fmap` parse))-                          (fromMaybe [] . fmap (fmap display)))--      , option [] ["source-dir"]-        "Directory containing package source."-        IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })-        (reqArg' "DIR" (Just . (:[]))-                       (fromMaybe []))--      , option [] ["build-tool"]-        "Required external build tool."-        IT.buildTools (\v flags -> flags { IT.buildTools = v })-        (reqArg' "TOOL" (Just . (:[]))-                        (fromMaybe []))-      ]-  }-  where readMaybe s = case reads s of-                        [(x,"")]  -> Just x-                        _         -> Nothing---- --------------------------------------------------------------- * GetOpt Utils--- --------------------------------------------------------------boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a-boolOpt  = Command.boolOpt  flagToMaybe Flag--reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->-              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b-reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList--liftOptions :: (b -> a) -> (a -> b -> b)-            -> [OptionField a] -> [OptionField b]-liftOptions get set = map (liftOption get set)--usagePackages :: String -> String -> String-usagePackages name pname =-     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"-  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"-  ++ "Flags for " ++ name ++ ":"----TODO: do we want to allow per-package flags?-parsePackageArgs :: [String] -> Either String [Dependency]-parsePackageArgs = parsePkgArgs []-  where-    parsePkgArgs ds [] = Right (reverse ds)-    parsePkgArgs ds (arg:args) =-      case readPToMaybe parseDependencyOrPackageId arg of-        Just dep -> parsePkgArgs (dep:ds) args-        Nothing  -> Left $-         show arg ++ " is not valid syntax for a package name or"-                  ++ " package dependency."--readPToMaybe :: Parse.ReadP a a -> String -> Maybe a-readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str-                                     , all isSpace s ]--parseDependencyOrPackageId :: Parse.ReadP r Dependency-parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse-  where-    pkgidToDependency :: PackageIdentifier -> Dependency-    pkgidToDependency p = case packageVersion p of-      Version [] _ -> Dependency (packageName p) anyVersion-      version      -> Dependency (packageName p) (thisVersion version)--showRepo :: RemoteRepo -> String-showRepo repo = remoteRepoName repo ++ ":"-             ++ uriToString id (remoteRepoURI repo) []--readRepo :: String -> Maybe RemoteRepo-readRepo = readPToMaybe parseRepo--parseRepo :: Parse.ReadP r RemoteRepo-parseRepo = do-  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")-  _ <- Parse.char ':'-  uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")-  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)-  return $ RemoteRepo {-    remoteRepoName = name,-    remoteRepoURI  = uri-  }
− cabal-install-0.9.5_rc20101226/Distribution/Client/SetupWrapper.hs 
@@ -1,320 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.SetupWrapper--- Copyright   :  (c) The University of Glasgow 2006,---                    Duncan Coutts 2008------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  alpha--- Portability :  portable------ An interface to building and installing Cabal packages.--- If the @Built-Type@ field is specified as something other than--- 'Custom', and the current version of Cabal is acceptable, this performs--- setup actions directly.  Otherwise it builds the setup script and--- runs it with the given arguments.--module Distribution.Client.SetupWrapper (-    setupWrapper,-    SetupScriptOptions(..),-    defaultSetupScriptOptions,-  ) where--import Distribution.Client.Types-         ( InstalledPackage )--import qualified Distribution.Make as Make-import qualified Distribution.Simple as Simple-import Distribution.Version-         ( Version(..), VersionRange, anyVersion-         , intersectVersionRanges, orLaterVersion-         , withinRange )-import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..), packageName-         , packageVersion, Dependency(..) )-import Distribution.PackageDescription-         ( GenericPackageDescription(packageDescription)-         , PackageDescription(..), specVersion, BuildType(..) )-import Distribution.PackageDescription.Parse-         ( readPackageDescription )-import Distribution.Simple.Configure-         ( configCompiler )-import Distribution.Simple.Compiler-         ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack )-import Distribution.Simple.Program-         ( ProgramConfiguration, emptyProgramConfiguration-         , rawSystemProgramConf, ghcProgram )-import Distribution.Simple.BuildPaths-         ( defaultDistPref, exeExtension )-import Distribution.Simple.Command-         ( CommandUI(..), commandShowOptions )-import Distribution.Simple.GHC-         ( ghcVerbosityOptions )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.PackageIndex (PackageIndex)-import Distribution.Client.IndexUtils-         ( getInstalledPackages )-import Distribution.Simple.Utils-         ( die, debug, info, cabalVersion, findPackageDesc, comparing-         , createDirectoryIfMissingVerbose, rewriteFile )-import Distribution.Client.Utils-         ( moreRecentFile, inDir )-import Distribution.Text-         ( display )-import Distribution.Verbosity-         ( Verbosity )--import System.Directory  ( doesFileExist, getCurrentDirectory )-import System.FilePath   ( (</>), (<.>) )-import System.IO         ( Handle )-import System.Exit       ( ExitCode(..), exitWith )-import System.Process    ( runProcess, waitForProcess )-import Control.Monad     ( when, unless )-import Data.List         ( maximumBy )-import Data.Maybe        ( fromMaybe, isJust )-import Data.Char         ( isSpace )--data SetupScriptOptions = SetupScriptOptions {-    useCabalVersion  :: VersionRange,-    useCompiler      :: Maybe Compiler,-    usePackageDB     :: PackageDBStack,-    usePackageIndex  :: Maybe (PackageIndex InstalledPackage),-    useProgramConfig :: ProgramConfiguration,-    useDistPref      :: FilePath,-    useLoggingHandle :: Maybe Handle,-    useWorkingDir    :: Maybe FilePath-  }--defaultSetupScriptOptions :: SetupScriptOptions-defaultSetupScriptOptions = SetupScriptOptions {-    useCabalVersion  = anyVersion,-    useCompiler      = Nothing,-    usePackageDB     = [GlobalPackageDB, UserPackageDB],-    usePackageIndex  = Nothing,-    useProgramConfig = emptyProgramConfiguration,-    useDistPref      = defaultDistPref,-    useLoggingHandle = Nothing,-    useWorkingDir    = Nothing-  }--setupWrapper :: Verbosity-             -> SetupScriptOptions-             -> Maybe PackageDescription-             -> CommandUI flags-             -> (Version -> flags)-             -> [String]-             -> IO ()-setupWrapper verbosity options mpkg cmd flags extraArgs = do-  pkg <- maybe getPkg return mpkg-  let setupMethod = determineSetupMethod options' buildType'-      options'    = options {-                      useCabalVersion = intersectVersionRanges-                                          (useCabalVersion options)-                                          (orLaterVersion (specVersion pkg))-                    }-      buildType'  = fromMaybe Custom (buildType pkg)-      mkArgs cabalLibVersion = commandName cmd-                             : commandShowOptions cmd (flags cabalLibVersion)-                            ++ extraArgs-  setupMethod verbosity options' (packageId pkg) buildType' mkArgs-  where-    getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options))-         >>= readPackageDescription verbosity-         >>= return . packageDescription---- | Decide if we're going to be able to do a direct internal call to the--- entry point in the Cabal library or if we're going to have to compile--- and execute an external Setup.hs script.----determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod-determineSetupMethod options buildType'-  | isJust (useLoggingHandle options)- || buildType' == Custom      = externalSetupMethod-  | cabalVersion `withinRange`-      useCabalVersion options = internalSetupMethod-  | otherwise                 = externalSetupMethod--type SetupMethod = Verbosity-                -> SetupScriptOptions-                -> PackageIdentifier-                -> BuildType-                -> (Version -> [String]) -> IO ()---- --------------------------------------------------------------- * Internal SetupMethod--- --------------------------------------------------------------internalSetupMethod :: SetupMethod-internalSetupMethod verbosity options _ bt mkargs = do-  let args = mkargs cabalVersion-  debug verbosity $ "Using internal setup method with build-type " ++ show bt-                 ++ " and args:\n  " ++ show args-  inDir (useWorkingDir options) $-    buildTypeAction bt args--buildTypeAction :: BuildType -> ([String] -> IO ())-buildTypeAction Simple    = Simple.defaultMainArgs-buildTypeAction Configure = Simple.defaultMainWithHooksArgs-                              Simple.autoconfUserHooks-buildTypeAction Make      = Make.defaultMainArgs-buildTypeAction Custom               = error "buildTypeAction Custom"-buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"---- --------------------------------------------------------------- * External SetupMethod--- --------------------------------------------------------------externalSetupMethod :: SetupMethod-externalSetupMethod verbosity options pkg bt mkargs = do-  debug verbosity $ "Using external setup method with build-type " ++ show bt-  createDirectoryIfMissingVerbose verbosity True setupDir-  (cabalLibVersion, options') <- cabalLibVersionToUse-  debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion-  setupHs <- updateSetupScript cabalLibVersion bt-  debug verbosity $ "Using " ++ setupHs ++ " as setup script."-  compileSetupExecutable options' cabalLibVersion setupHs-  invokeSetupScript (mkargs cabalLibVersion)--  where-  workingDir       = case fromMaybe "" (useWorkingDir options) of-                       []  -> "."-                       dir -> dir-  setupDir         = workingDir </> useDistPref options </> "setup"-  setupVersionFile = setupDir </> "setup" <.> "version"-  setupProgFile    = setupDir </> "setup" <.> exeExtension--  cabalLibVersionToUse :: IO (Version, SetupScriptOptions)-  cabalLibVersionToUse = do-    savedVersion <- savedCabalVersion-    case savedVersion of-      Just version | version `withinRange` useCabalVersion options-        -> return (version, options)-      _ -> do (comp, conf, options') <- configureCompiler options-              version <- installedCabalVersion options comp conf-              writeFile setupVersionFile (show version ++ "\n")-              return (version, options')--  savedCabalVersion = do-    versionString <- readFile setupVersionFile `catch` \_ -> return ""-    case reads versionString of-      [(version,s)] | all isSpace s -> return (Just version)-      _                             -> return Nothing--  installedCabalVersion :: SetupScriptOptions -> Compiler-                        -> ProgramConfiguration -> IO Version-  installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" =-    return (packageVersion pkg)-  installedCabalVersion options' comp conf = do-    index <- case usePackageIndex options' of-      Just index -> return index-      Nothing    -> getInstalledPackages verbosity-                      comp (usePackageDB options') conf--    let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)-    case PackageIndex.lookupDependency index cabalDep of-      []   -> die $ "The package requires Cabal library version "-                 ++ display (useCabalVersion options)-                 ++ " but no suitable version is installed."-      pkgs -> return $ bestVersion (map packageVersion pkgs)-    where-      bestVersion          = maximumBy (comparing preference)-      preference version   = (sameVersion, sameMajorVersion-                             ,stableVersion, latestVersion)-        where-          sameVersion      = version == cabalVersion-          sameMajorVersion = majorVersion version == majorVersion cabalVersion-          majorVersion     = take 2 . versionBranch-          stableVersion    = case versionBranch version of-                               (_:x:_) -> even x-                               _       -> False-          latestVersion    = version--  configureCompiler :: SetupScriptOptions-                    -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)-  configureCompiler options' = do-    (comp, conf) <- case useCompiler options' of-      Just comp -> return (comp, useProgramConfig options')-      Nothing   -> configCompiler (Just GHC) Nothing Nothing-                     (useProgramConfig options') verbosity-    return (comp, conf, options' { useCompiler = Just comp,-                                   useProgramConfig = conf })--  -- | Decide which Setup.hs script to use, creating it if necessary.-  ---  updateSetupScript :: Version -> BuildType -> IO FilePath-  updateSetupScript _ Custom = do-    useHs  <- doesFileExist setupHs-    useLhs <- doesFileExist setupLhs-    unless (useHs || useLhs) $ die-      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."-    return (if useHs then setupHs else setupLhs)-    where-      setupHs  = workingDir </> "Setup.hs"-      setupLhs = workingDir </> "Setup.lhs"--  updateSetupScript cabalLibVersion _ = do-    rewriteFile setupHs (buildTypeScript cabalLibVersion)-    return setupHs-    where-      setupHs  = setupDir </> "setup.hs"--  buildTypeScript :: Version -> String-  buildTypeScript cabalLibVersion = case bt of-    Simple    -> "import Distribution.Simple; main = defaultMain\n"-    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "-              ++ if cabalLibVersion >= Version [1,3,10] []-                   then "autoconfUserHooks\n"-                   else "defaultUserHooks\n"-    Make      -> "import Distribution.Make; main = defaultMain\n"-    Custom             -> error "buildTypeScript Custom"-    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"--  -- | If the Setup.hs is out of date wrt the executable then recompile it.-  -- Currently this is GHC only. It should really be generalised.-  ---  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO ()-  compileSetupExecutable options' cabalLibVersion setupHsFile = do-    setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile-    cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile-    let outOfDate = setupHsNewer || cabalVersionNewer-    when outOfDate $ do-      debug verbosity "Setup script is out of date, compiling..."-      (_, conf, _) <- configureCompiler options'-      --TODO: get Cabal's GHC module to export a GhcOptions type and render func-      rawSystemProgramConf verbosity ghcProgram conf $-          ghcVerbosityOptions verbosity-       ++ ["--make", setupHsFile, "-o", setupProgFile-          ,"-odir", setupDir, "-hidir", setupDir-          ,"-i", "-i" ++ workingDir ]-       ++ ghcPackageDbOptions (usePackageDB options')-       ++ if packageName pkg == PackageName "Cabal"-            then []-            else ["-package", display cabalPkgid]-    where-      cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion--      ghcPackageDbOptions :: PackageDBStack -> [String]-      ghcPackageDbOptions dbstack = case dbstack of-        (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-        (GlobalPackageDB:dbs)               -> "-no-user-package-conf"-                                             : concatMap specific dbs-        _                                   -> ierror-        where-          specific (SpecificPackageDB db) = [ "-package-conf", db ]-          specific _ = ierror-          ierror     = error "internal error: unexpected package db stack"---  invokeSetupScript :: [String] -> IO ()-  invokeSetupScript args = do-    info verbosity $ unwords (setupProgFile : args)-    case useLoggingHandle options of-      Nothing        -> return ()-      Just logHandle -> info verbosity $ "Redirecting build log to "-                                      ++ show logHandle-    currentDir <- getCurrentDirectory-    process <- runProcess (currentDir </> setupProgFile) args-                 (useWorkingDir options) Nothing-                 Nothing (useLoggingHandle options) (useLoggingHandle options)-    exitCode <- waitForProcess process-    unless (exitCode == ExitSuccess) $ exitWith exitCode
− cabal-install-0.9.5_rc20101226/Distribution/Client/SrcDist.hs 
@@ -1,80 +0,0 @@--- Implements the \"@.\/cabal sdist@\" command, which creates a source--- distribution for this package.  That is, packs up the source code--- into a tarball, making use of the corresponding Cabal module.-module Distribution.Client.SrcDist (-         sdist-  )  where-import Distribution.Simple.SrcDist-         ( printPackageProblems, prepareTree-         , prepareSnapshotTree, snapshotPackage )-import Distribution.Client.Tar (createTarGzFile)--import Distribution.Package-         ( Package(..) )-import Distribution.PackageDescription-         ( PackageDescription )-import Distribution.PackageDescription.Parse-         ( readPackageDescription )-import Distribution.Simple.Utils-         ( defaultPackageDesc, warn, notice, setupMessage-         , createDirectoryIfMissingVerbose, withTempDirectory )-import Distribution.Simple.Setup (SDistFlags(..), fromFlag)-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.PreProcess (knownSuffixHandlers)-import Distribution.Simple.BuildPaths ( srcPref)-import Distribution.Simple.Configure(maybeGetPersistBuildConfig)-import Distribution.PackageDescription.Configuration ( flattenPackageDescription )-import Distribution.Text-         ( display )--import System.Time (getClockTime, toCalendarTime)-import System.FilePath ((</>), (<.>))-import Control.Monad (when)-import Data.Maybe (isNothing)---- |Create a source distribution.-sdist :: SDistFlags -> IO ()-sdist flags = do-  pkg <- return . flattenPackageDescription-     =<< readPackageDescription verbosity-     =<< defaultPackageDesc verbosity-  mb_lbi <- maybeGetPersistBuildConfig distPref-  let tmpTargetDir = srcPref distPref--  -- do some QA-  printPackageProblems verbosity pkg--  when (isNothing mb_lbi) $-    warn verbosity "Cannot run preprocessors. Run 'configure' command first."--  createDirectoryIfMissingVerbose verbosity True tmpTargetDir-  withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do--    date <- toCalendarTime =<< getClockTime-    let pkg' | snapshot  = snapshotPackage date pkg-             | otherwise = pkg-    setupMessage verbosity "Building source dist for" (packageId pkg')--    _ <- if snapshot-      then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps-      else prepareTree         verbosity pkg' mb_lbi distPref tmpDir pps-    targzFile <- createArchive verbosity pkg' tmpDir distPref-    notice verbosity $ "Source tarball created: " ++ targzFile--  where-    verbosity = fromFlag (sDistVerbosity flags)-    snapshot  = fromFlag (sDistSnapshot flags)-    distPref  = fromFlag (sDistDistPref flags)-    pps       = knownSuffixHandlers---- |Create an archive from a tree of source files, and clean up the tree.-createArchive :: Verbosity-              -> PackageDescription-              -> FilePath-              -> FilePath-              -> IO FilePath-createArchive _verbosity pkg tmpDir targetPref = do-  let tarBallName     = display (packageId pkg)-      tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"-  createTarGzFile tarBallFilePath tmpDir tarBallName-  return tarBallFilePath
− cabal-install-0.9.5_rc20101226/Distribution/Client/Tar.hs 
@@ -1,871 +0,0 @@-{-# OPTIONS_GHC -fno-warn-unused-imports #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Tar--- Copyright   :  (c) 2007 Bjorn Bringert,---                    2008 Andrea Vezzosi,---                    2008-2009 Duncan Coutts--- License     :  BSD3------ Maintainer  :  duncan@haskell.org--- Portability :  portable------ Reading, writing and manipulating \"@.tar@\" archive files.----------------------------------------------------------------------------------module Distribution.Client.Tar (-  -- * High level \"all in one\" operations-  createTarGzFile,-  extractTarGzFile,--  -- * Converting between internal and external representation-  read,-  write,--  -- * Packing and unpacking files to\/from internal representation-  pack,-  unpack,--  -- * Tar entry and associated types-  Entry(..),-  entryPath,-  EntryContent(..),-  Ownership(..),-  FileSize,-  Permissions,-  EpochTime,-  DevMajor,-  DevMinor,-  TypeCode,-  Format(..),--  -- * Constructing simple entry values-  simpleEntry,-  fileEntry,-  directoryEntry,--  -- * TarPath type-  TarPath,-  toTarPath,-  fromTarPath,--  -- ** Sequences of tar entries-  Entries(..),-  foldEntries,-  unfoldEntries,-  mapEntries,--  ) where--import Data.Char     (ord)-import Data.Int      (Int64)-import Data.Bits     (Bits, shiftL)-import Data.List     (foldl')-import Numeric       (readOct, showOct)-import Control.Monad (MonadPlus(mplus))--import qualified Data.ByteString.Lazy as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Data.ByteString.Lazy (ByteString)-import qualified Codec.Compression.GZip as GZip-import qualified Distribution.Client.GZipUtils as GZipUtils--import System.FilePath-         ( (</>) )-import qualified System.FilePath         as FilePath.Native-import qualified System.FilePath.Windows as FilePath.Windows-import qualified System.FilePath.Posix   as FilePath.Posix-import System.Directory-         ( getDirectoryContents, doesDirectoryExist, getModificationTime-         , getPermissions, createDirectoryIfMissing, copyFile )-import qualified System.Directory as Permissions-         ( Permissions(executable) )-import System.Posix.Types-         ( FileMode )-import System.Time-         ( ClockTime(..) )-import System.IO-         ( IOMode(ReadMode), openBinaryFile, hFileSize )-import System.IO.Unsafe (unsafeInterleaveIO)--import Prelude hiding (read)-------- * High level operations-----createTarGzFile :: FilePath  -- ^ Full Tarball path-                -> FilePath  -- ^ Base directory-                -> FilePath  -- ^ Directory to archive, relative to base dir-                -> IO ()-createTarGzFile tar base dir =-  BS.writeFile tar . GZip.compress . write =<< pack base [dir]--extractTarGzFile :: FilePath -- ^ Destination directory-                 -> FilePath -- ^ Expected subdir (to check for tarbombs)-                 -> FilePath -- ^ Tarball-                -> IO ()-extractTarGzFile dir expected tar = do-  unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar------- * Entry type-----type FileSize  = Int64--- | The number of seconds since the UNIX epoch-type EpochTime = Int64-type DevMajor  = Int-type DevMinor  = Int-type TypeCode  = Char-type Permissions = FileMode---- | Tar archive entry.----data Entry = Entry {--    -- | The path of the file or directory within the archive. This is in a-    -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.-    entryTarPath :: !TarPath,--    -- | The real content of the entry. For 'NormalFile' this includes the-    -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.-    entryContent :: !EntryContent,--    -- | File permissions (Unix style file mode).-    entryPermissions :: !Permissions,--    -- | The user and group to which this file belongs.-    entryOwnership :: !Ownership,--    -- | The time the file was last modified.-    entryTime :: !EpochTime,--    -- | The tar format the archive is using.-    entryFormat :: !Format-  }---- | Native 'FilePath' of the file or directory within the archive.----entryPath :: Entry -> FilePath-entryPath = fromTarPath . entryTarPath---- | The content of a tar archive entry, which depends on the type of entry.------ Portable archives should contain only 'NormalFile' and 'Directory'.----data EntryContent = NormalFile      ByteString !FileSize-                  | Directory-                  | SymbolicLink    !LinkTarget-                  | HardLink        !LinkTarget-                  | CharacterDevice !DevMajor !DevMinor-                  | BlockDevice     !DevMajor !DevMinor-                  | NamedPipe-                  | OtherEntryType  !TypeCode ByteString !FileSize--data Ownership = Ownership {-    -- | The owner user name. Should be set to @\"\"@ if unknown.-    ownerName :: String,--    -- | The owner group name. Should be set to @\"\"@ if unknown.-    groupName :: String,--    -- | Numeric owner user id. Should be set to @0@ if unknown.-    ownerId :: !Int,--    -- | Numeric owner group id. Should be set to @0@ if unknown.-    groupId :: !Int-  }---- | There have been a number of extensions to the tar file format over the--- years. They all share the basic entry fields and put more meta-data in--- different extended headers.----data Format =--     -- | This is the classic Unix V7 tar format. It does not support owner and-     -- group names, just numeric Ids. It also does not support device numbers.-     V7Format--     -- | The \"USTAR\" format is an extension of the classic V7 format. It was-     -- later standardised by POSIX. It has some restructions but is the most-     -- portable format.-     ---   | UstarFormat--     -- | The GNU tar implementation also extends the classic V7 format, though-     -- in a slightly different way from the USTAR format. In general for new-     -- archives the standard USTAR/POSIX should be used.-     ---   | GnuFormat-  deriving Eq---- | @rw-r--r--@ for normal files-ordinaryFilePermissions :: Permissions-ordinaryFilePermissions   = 0o0644---- | @rwxr-xr-x@ for executable files-executableFilePermissions :: Permissions-executableFilePermissions = 0o0755---- | @rwxr-xr-x@ for directories-directoryPermissions :: Permissions-directoryPermissions  = 0o0755---- | An 'Entry' with all default values except for the file name and type. It--- uses the portable USTAR/POSIX format (see 'UstarHeader').------ You can use this as a basis and override specific fields, eg:------ > (emptyEntry name HardLink) { linkTarget = target }----simpleEntry :: TarPath -> EntryContent -> Entry-simpleEntry tarpath content = Entry {-    entryTarPath     = tarpath,-    entryContent     = content,-    entryPermissions = case content of-                         Directory -> directoryPermissions-                         _         -> ordinaryFilePermissions,-    entryOwnership   = Ownership "" "" 0 0,-    entryTime        = 0,-    entryFormat      = UstarFormat-  }---- | A tar 'Entry' for a file.------ Entry  fields such as file permissions and ownership have default values.------ You can use this as a basis and override specific fields. For example if you--- need an executable file you could use:------ > (fileEntry name content) { fileMode = executableFileMode }----fileEntry :: TarPath -> ByteString -> Entry-fileEntry name fileContent =-  simpleEntry name (NormalFile fileContent (BS.length fileContent))---- | A tar 'Entry' for a directory.------ Entry fields such as file permissions and ownership have default values.----directoryEntry :: TarPath -> Entry-directoryEntry name = simpleEntry name Directory------- * Tar paths------- | The classic tar format allowed just 100 charcters for the file name. The--- USTAR format extended this with an extra 155 characters, however it uses a--- complex method of splitting the name between the two sections.------ Instead of just putting any overflow into the extended area, it uses the--- extended area as a prefix. The agrevating insane bit however is that the--- prefix (if any) must only contain a directory prefix. That is the split--- between the two areas must be on a directory separator boundary. So there is--- no simple calculation to work out if a file name is too long. Instead we--- have to try to find a valid split that makes the name fit in the two areas.------ The rationale presumably was to make it a bit more compatible with old tar--- programs that only understand the classic format. A classic tar would be--- able to extract the file name and possibly some dir prefix, but not the--- full dir prefix. So the files would end up in the wrong place, but that's--- probably better than ending up with the wrong names too.------ So it's understandable but rather annoying.------ * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective---   of the local path conventions.------ * The directory separator between the prefix and name is /not/ stored.----data TarPath = TarPath FilePath -- path name, 100 characters max.-                       FilePath -- path prefix, 155 characters max.-  deriving (Eq, Ord)---- | Convert a 'TarPath' to a native 'FilePath'.------ The native 'FilePath' will use the native directory separator but it is not--- otherwise checked for validity or sanity. In particular:------ * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is---   not valid on Windows.------ * The tar path may be an absolute path or may contain @\"..\"@ components.---   For security reasons this should not usually be allowed, but it is your---   responsibility to check for these conditions (eg using 'checkSecurity').----fromTarPath :: TarPath -> FilePath-fromTarPath (TarPath name prefix) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix-                          ++ FilePath.Posix.splitDirectories name-  where-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id---- | Convert a native 'FilePath' to a 'TarPath'.------ The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a--- description of the problem with splitting long 'FilePath's.----toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for-                  -- directories a 'TarPath' must always use a trailing @\/@.-          -> FilePath -> Either String TarPath-toTarPath isDir = splitLongPath-                . addTrailingSep-                . FilePath.Posix.joinPath-                . FilePath.Native.splitDirectories-  where-    addTrailingSep | isDir     = FilePath.Posix.addTrailingPathSeparator-                   | otherwise = id---- | Take a sanitized path, split on directory separators and try to pack it--- into the 155 + 100 tar file name format.------ The stragey is this: take the name-directory components in reverse order--- and try to fit as many components into the 100 long name area as possible.--- If all the remaining components fit in the 155 name area then we win.----splitLongPath :: FilePath -> Either String TarPath-splitLongPath path =-  case packName nameMax (reverse (FilePath.Posix.splitPath path)) of-    Left err                 -> Left err-    Right (name, [])         -> Right (TarPath name "")-    Right (name, first:rest) -> case packName prefixMax remainder of-      Left err               -> Left err-      Right (_     , (_:_))  -> Left "File name too long (cannot split)"-      Right (prefix, [])     -> Right (TarPath name prefix)-      where-        -- drop the '/' between the name and prefix:-        remainder = init first : rest--  where-    nameMax, prefixMax :: Int-    nameMax   = 100-    prefixMax = 155--    packName _      []     = Left "File name empty"-    packName maxLen (c:cs)-      | n > maxLen         = Left "File name too long"-      | otherwise          = Right (packName' maxLen n [c] cs)-      where n = length c--    packName' maxLen n ok (c:cs)-      | n' <= maxLen             = packName' maxLen n' (c:ok) cs-                                     where n' = n + length c-    packName' _      _ ok    cs  = (FilePath.Posix.joinPath ok, cs)---- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and--- 'HardLink' entry types.----newtype LinkTarget = LinkTarget FilePath-  deriving (Eq, Ord)---- | Convert a tar 'LinkTarget' to a native 'FilePath'.----fromLinkTarget :: LinkTarget -> FilePath-fromLinkTarget (LinkTarget path) = adjustDirectory $-  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path-  where-    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path-                    = FilePath.Native.addTrailingPathSeparator-                    | otherwise = id------- * Entries type------- | A tar archive is a sequence of entries.-data Entries = Next Entry Entries-             | Done-             | Fail String--unfoldEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries-unfoldEntries f = unfold-  where-    unfold x = case f x of-      Left err             -> Fail err-      Right Nothing        -> Done-      Right (Just (e, x')) -> Next e (unfold x')--foldEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a-foldEntries next done fail' = fold-  where-    fold (Next e es) = next e (fold es)-    fold Done        = done-    fold (Fail err)  = fail' err--mapEntries :: (Entry -> Either String Entry) -> Entries -> Entries-mapEntries f =-  foldEntries (\entry rest -> either Fail (flip Next rest) (f entry)) Done Fail------- * Checking------- | This function checks a sequence of tar entries for file name security--- problems. It checks that:------ * file paths are not absolute------ * file paths do not contain any path components that are \"@..@\"------ * file names are valid------ These checks are from the perspective of the current OS. That means we check--- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive--- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the--- link target. A failure in any entry terminates the sequence of entries with--- an error.----checkSecurity :: Entries -> Entries-checkSecurity = checkEntries checkEntrySecurity--checkTarbomb :: FilePath -> Entries -> Entries-checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir)--checkEntrySecurity :: Entry -> Maybe String-checkEntrySecurity entry = case entryContent entry of-    HardLink     link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    SymbolicLink link -> check (entryPath entry)-                 `mplus` check (fromLinkTarget link)-    _                 -> check (entryPath entry)--  where-    check name-      | not (FilePath.Native.isRelative name)-      = Just $ "Absolute file name in tar archive: " ++ show name--      | not (FilePath.Native.isValid name)-      = Just $ "Invalid file name in tar archive: " ++ show name--      | any (=="..") (FilePath.Native.splitDirectories name)-      = Just $ "Invalid file name in tar archive: " ++ show name--      | otherwise = Nothing--checkEntryTarbomb :: FilePath -> Entry -> Maybe String-checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing-  where-    -- Ignore some special entries we will not unpack anyway-    nonFilesystemEntry =-      case entryContent entry of-        OtherEntryType 'g' _ _ -> True --PAX global header-        OtherEntryType 'x' _ _ -> True --PAX individual header-        _                      -> False--checkEntryTarbomb expectedTopDir entry =-  case FilePath.Native.splitDirectories (entryPath entry) of-    (topDir:_) | topDir == expectedTopDir -> Nothing-    _ -> Just $ "File in tar archive is not in the expected directory "-             ++ show expectedTopDir--checkEntries :: (Entry -> Maybe String) -> Entries -> Entries-checkEntries checkEntry =-  mapEntries (\entry -> maybe (Right entry) Left (checkEntry entry))------- * Reading-----read :: ByteString -> Entries-read = unfoldEntries getEntry--getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))-getEntry bs-  | BS.length header < 512 = Left "truncated tar archive"--  -- Tar files end with at least two blocks of all '0'. Checking this serves-  -- two purposes. It checks the format but also forces the tail of the data-  -- which is necessary to close the file if it came from a lazily read file.-  | BS.head bs == 0 = case BS.splitAt 1024 bs of-      (end, trailing)-        | BS.length end /= 1024        -> Left "short tar trailer"-        | not (BS.all (== 0) end)      -> Left "bad tar trailer"-        | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk"-        | otherwise                    -> Right Nothing--  | otherwise  = partial $ do--  case (chksum_, format_) of-    (Ok chksum, _   ) | correctChecksum header chksum -> return ()-    (Ok _,      Ok _) -> fail "tar checksum error"-    _                 -> fail "data is not in tar format"--  -- These fields are partial, have to check them-  format   <- format_;   mode     <- mode_;-  uid      <- uid_;      gid      <- gid_;-  size     <- size_;     mtime    <- mtime_;-  devmajor <- devmajor_; devminor <- devminor_;--  let content = BS.take size (BS.drop 512 bs)-      padding = (512 - size) `mod` 512-      bs'     = BS.drop (512 + size + padding) bs--      entry = Entry {-        entryTarPath     = TarPath name prefix,-        entryContent     = case typecode of-                   '\0' -> NormalFile      content size-                   '0'  -> NormalFile      content size-                   '1'  -> HardLink        (LinkTarget linkname)-                   '2'  -> SymbolicLink    (LinkTarget linkname)-                   '3'  -> CharacterDevice devmajor devminor-                   '4'  -> BlockDevice     devmajor devminor-                   '5'  -> Directory-                   '6'  -> NamedPipe-                   '7'  -> NormalFile      content size-                   _    -> OtherEntryType  typecode content size,-        entryPermissions = mode,-        entryOwnership   = Ownership uname gname uid gid,-        entryTime        = mtime,-        entryFormat      = format-    }--  return (Just (entry, bs'))--  where-   header = BS.take 512 bs--   name       = getString   0 100 header-   mode_      = getOct    100   8 header-   uid_       = getOct    108   8 header-   gid_       = getOct    116   8 header-   size_      = getOct    124  12 header-   mtime_     = getOct    136  12 header-   chksum_    = getOct    148   8 header-   typecode   = getByte   156     header-   linkname   = getString 157 100 header-   magic      = getChars  257   8 header-   uname      = getString 265  32 header-   gname      = getString 297  32 header-   devmajor_  = getOct    329   8 header-   devminor_  = getOct    337   8 header-   prefix     = getString 345 155 header--- trailing   = getBytes  500  12 header--   format_ = case magic of-    "\0\0\0\0\0\0\0\0" -> return V7Format-    "ustar\NUL00"      -> return UstarFormat-    "ustar  \NUL"      -> return GnuFormat-    _                  -> fail "tar entry not in a recognised format"--correctChecksum :: ByteString -> Int -> Bool-correctChecksum header checksum = checksum == checksum'-  where-    -- sum of all 512 bytes in the header block,-    -- treating each byte as an 8-bit unsigned value-    checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'-    -- treating the 8 bytes of chksum as blank characters.-    header'   = BS.concat [BS.take 148 header,-                           BS.Char8.replicate 8 ' ',-                           BS.drop 156 header]---- * TAR format primitive input--getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a-getOct off len header-  | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes))-  | null octstr          = return 0-  | otherwise            = case readOct octstr of-               [(x,[])] -> return x-               _        -> fail "tar header is malformed (bad numeric encoding)"-  where-    bytes  = getBytes off len header-    octstr = BS.Char8.unpack-           . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')-           . BS.Char8.dropWhile (== ' ')-           $ bytes--    -- Some tar programs switch into a binary format when they try to represent-    -- field values that will not fit in the required width when using the text-    -- octal format. In particular, the UID/GID fields can only hold up to 2^21-    -- while in the binary format can hold up to 2^32. The binary format uses-    -- '\128' as the header which leaves 7 bytes. Only the last 4 are used.-    parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] =-      return $! shiftL (fromIntegral byte3) 24-              + shiftL (fromIntegral byte2) 16-              + shiftL (fromIntegral byte1) 8-              + shiftL (fromIntegral byte0) 0-    parseBinInt _ = fail "tar header uses non-standard number encoding"--getBytes :: Int64 -> Int64 -> ByteString -> ByteString-getBytes off len = BS.take len . BS.drop off--getByte :: Int64 -> ByteString -> Char-getByte off bs = BS.Char8.index bs off--getChars :: Int64 -> Int64 -> ByteString -> String-getChars off len = BS.Char8.unpack . getBytes off len--getString :: Int64 -> Int64 -> ByteString -> String-getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len--data Partial a = Error String | Ok a--partial :: Partial a -> Either String a-partial (Error msg) = Left msg-partial (Ok x)      = Right x--instance Monad Partial where-    return        = Ok-    Error m >>= _ = Error m-    Ok    x >>= k = k x-    fail          = Error------- * Writing------- | Create the external representation of a tar archive by serialising a list--- of tar entries.------ * The conversion is done lazily.----write :: [Entry] -> ByteString-write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]--putEntry :: Entry -> ByteString-putEntry entry = case entryContent entry of-  NormalFile       content size -> BS.concat [ header, content, padding size ]-  OtherEntryType _ content size -> BS.concat [ header, content, padding size ]-  _                             -> header-  where-    header       = putHeader entry-    padding size = BS.replicate paddingSize 0-      where paddingSize = fromIntegral (negate size `mod` 512)--putHeader :: Entry -> ByteString-putHeader entry =-     BS.Char8.pack $ take 148 block-  ++ putOct 7 checksum-  ++ ' ' : drop 156 block-  where-    block    = putHeaderNoChkSum entry-    checksum = foldl' (\x y -> x + ord y) 0 block--putHeaderNoChkSum :: Entry -> String-putHeaderNoChkSum Entry {-    entryTarPath     = TarPath name prefix,-    entryContent     = content,-    entryPermissions = permissions,-    entryOwnership   = ownership,-    entryTime        = modTime,-    entryFormat      = format-  } =--  concat-    [ putString  100 $ name-    , putOct       8 $ permissions-    , putOct       8 $ ownerId ownership-    , putOct       8 $ groupId ownership-    , putOct      12 $ contentSize-    , putOct      12 $ modTime-    , fill         8 $ ' ' -- dummy checksum-    , putChar8       $ typeCode-    , putString  100 $ linkTarget-    ] ++-  case format of-  V7Format    ->-      fill 255 '\NUL'-  UstarFormat -> concat-    [ putString    8 $ "ustar\NUL00"-    , putString   32 $ ownerName ownership-    , putString   32 $ groupName ownership-    , putOct       8 $ deviceMajor-    , putOct       8 $ deviceMinor-    , putString  155 $ prefix-    , fill        12 $ '\NUL'-    ]-  GnuFormat -> concat-    [ putString    8 $ "ustar  \NUL"-    , putString   32 $ ownerName ownership-    , putString   32 $ groupName ownership-    , putGnuDev    8 $ deviceMajor-    , putGnuDev    8 $ deviceMinor-    , putString  155 $ prefix-    , fill        12 $ '\NUL'-    ]-  where-    (typeCode, contentSize, linkTarget,-     deviceMajor, deviceMinor) = case content of-       NormalFile      _ size            -> ('0' , size, [],   0,     0)-       Directory                         -> ('5' , 0,    [],   0,     0)-       SymbolicLink    (LinkTarget link) -> ('2' , 0,    link, 0,     0)-       HardLink        (LinkTarget link) -> ('1' , 0,    link, 0,     0)-       CharacterDevice major minor       -> ('3' , 0,    [],   major, minor)-       BlockDevice     major minor       -> ('4' , 0,    [],   major, minor)-       NamedPipe                         -> ('6' , 0,    [],   0,     0)-       OtherEntryType  code _ size       -> (code, size, [],   0,     0)--    putGnuDev w n = case content of-      CharacterDevice _ _ -> putOct w n-      BlockDevice     _ _ -> putOct w n-      _                   -> replicate w '\NUL'---- * TAR format primitive output--type FieldWidth = Int--putString :: FieldWidth -> String -> String-putString n s = take n s ++ fill (n - length s) '\NUL'----TODO: check integer widths, eg for large file sizes-putOct :: Integral a => FieldWidth -> a -> String-putOct n x =-  let octStr = take (n-1) $ showOct x ""-   in fill (n - length octStr - 1) '0'-   ++ octStr-   ++ putChar8 '\NUL'--putChar8 :: Char -> String-putChar8 c = [c]--fill :: FieldWidth -> Char -> String-fill n c = replicate n c------- * Unpacking-----unpack :: FilePath -> Entries -> IO ()-unpack baseDir entries = unpackEntries [] (checkSecurity entries)-                     >>= emulateLinks--  where-    -- We're relying here on 'checkSecurity' to make sure we're not scribbling-    -- files all over the place.--    unpackEntries _     (Fail err)      = fail err-    unpackEntries links Done            = return links-    unpackEntries links (Next entry es) = case entryContent entry of-      NormalFile file _ -> extractFile path file-                        >> unpackEntries links es-      Directory         -> extractDir path-                        >> unpackEntries links es-      HardLink     link -> (unpackEntries $! saveLink path link links) es-      SymbolicLink link -> (unpackEntries $! saveLink path link links) es-      _                 -> unpackEntries links es --ignore other file types-      where-        path = entryPath entry--    extractFile path content = do-      -- Note that tar archives do not make sure each directory is created-      -- before files they contain, indeed we may have to create several-      -- levels of directory.-      createDirectoryIfMissing True absDir-      BS.writeFile absPath content-      where-        absDir  = baseDir </> FilePath.Native.takeDirectory path-        absPath = baseDir </> path--    extractDir path = createDirectoryIfMissing True (baseDir </> path)--    saveLink path link links = seq (length path)-                             $ seq (length link')-                             $ (path, link'):links-      where link' = fromLinkTarget link--    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->-      let absPath   = baseDir </> relPath-          absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget-       in copyFile absTarget absPath------- * Packing-----pack :: FilePath   -- ^ Base directory-     -> [FilePath] -- ^ Files and directories to pack, relative to the base dir-     -> IO [Entry]-pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir--preparePaths :: FilePath -> [FilePath] -> IO [FilePath]-preparePaths baseDir paths =-  fmap concat $ interleave-    [ do isDir  <- doesDirectoryExist (baseDir </> path)-         if isDir-           then do entries <- getDirectoryContentsRecursive (baseDir </> path)-                   return (FilePath.Native.addTrailingPathSeparator path-                         : map (path </>) entries)-           else return [path]-    | path <- paths ]--packPaths :: FilePath -> [FilePath] -> IO [Entry]-packPaths baseDir paths =-  interleave-    [ do tarpath <- either fail return (toTarPath isDir relpath)-         if isDir then packDirectoryEntry filepath tarpath-                  else packFileEntry      filepath tarpath-    | relpath <- paths-    , let isDir    = FilePath.Native.hasTrailingPathSeparator filepath-          filepath = baseDir </> relpath ]--interleave :: [IO a] -> IO [a]-interleave = unsafeInterleaveIO . go-  where-    go []     = return []-    go (x:xs) = do-      x'  <- x-      xs' <- interleave xs-      return (x':xs')--packFileEntry :: FilePath -- ^ Full path to find the file on the local disk-              -> TarPath  -- ^ Path to use for the tar Entry in the archive-              -> IO Entry-packFileEntry filepath tarpath = do-  mtime   <- getModTime filepath-  perms   <- getPermissions filepath-  file    <- openBinaryFile filepath ReadMode-  size    <- hFileSize file-  content <- BS.hGetContents file-  return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {-    entryPermissions = if Permissions.executable perms-                         then executableFilePermissions-                         else ordinaryFilePermissions,-    entryTime = mtime-  }--packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk-                   -> TarPath  -- ^ Path to use for the tar Entry in the archive-                   -> IO Entry-packDirectoryEntry filepath tarpath = do-  mtime   <- getModTime filepath-  return (directoryEntry tarpath) {-    entryTime = mtime-  }--getDirectoryContentsRecursive :: FilePath -> IO [FilePath]-getDirectoryContentsRecursive dir0 =-  fmap tail (recurseDirectories dir0 [""])--recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]-recurseDirectories _    []         = return []-recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do-  (files, dirs') <- collect [] [] =<< getDirectoryContents (base </> dir)--  files' <- recurseDirectories base (dirs' ++ dirs)-  return (dir : 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-          dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry-      isDirectory <- doesDirectoryExist (base </> dirEntry)-      if isDirectory-        then collect files (dirEntry':dirs') entries-        else collect (dirEntry:files) dirs' entries--    ignore ['.']      = True-    ignore ['.', '.'] = True-    ignore _          = False--getModTime :: FilePath -> IO EpochTime-getModTime path = do-  (TOD s _) <- getModificationTime path-  return $! fromIntegral s
− cabal-install-0.9.5_rc20101226/Distribution/Client/Types.hs 
@@ -1,211 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Types--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ All data types for the entire cabal-install system gathered here to avoid some .hs-boot files.-------------------------------------------------------------------------------module Distribution.Client.Types where--import Distribution.Package-         ( PackageName, PackageId, Package(..)-         , PackageFixedDeps(..), Dependency )-import Distribution.InstalledPackageInfo-         ( InstalledPackageInfo )-import Distribution.PackageDescription-         ( GenericPackageDescription, FlagAssignment, FlagName(FlagName) )-import Distribution.Client.PackageIndex-         ( PackageIndex )-import Distribution.Version-         ( VersionRange )-import Distribution.Text-          ( Text(disp,parse) )-import qualified Distribution.Compat.ReadP as Parse-import qualified Text.PrettyPrint as Disp-         --import Data.Char as Char-import Data.Map (Map)-import Network.URI (URI)-import Distribution.Compat.Exception-         ( SomeException )--newtype Username = Username { unUsername :: String }-newtype Password = Password { unPassword :: String }---- | This is the information we get from a @00-index.tar.gz@ hackage index.----data AvailablePackageDb = AvailablePackageDb {-  packageIndex       :: PackageIndex AvailablePackage,-  packagePreferences :: Map PackageName VersionRange-}---- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8.--- What is new in 1.8 is that installed packages and dependencies between--- installed packages are now identified by an opaque InstalledPackageId--- rather than a source PackageId.------ We should use simply an 'InstalledPackageInfo' here but to ease the--- transition we are temporarily using this variant where we pretend that--- installed packages still specify their deps in terms of PackageIds.------ Crucially this means that 'InstalledPackage' can be an instance of--- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance--- of that class. This means we can make 'PackageIndex'es of InstalledPackage--- where as the InstalledPackageInfo now has its own monomorphic index type.----data InstalledPackage = InstalledPackage-       InstalledPackageInfo-       [PackageId]--instance Package InstalledPackage where-  packageId (InstalledPackage pkg _) = packageId pkg-instance PackageFixedDeps InstalledPackage where-  depends (InstalledPackage _ deps) = deps---- | A 'ConfiguredPackage' is a not-yet-installed package along with the--- total configuration information. The configuration information is total in--- the sense that it provides all the configuration information and so the--- final configure process will be independent of the environment.----data ConfiguredPackage = ConfiguredPackage-       AvailablePackage    -- package info, including repo-       FlagAssignment      -- complete flag assignment for the package-       [PackageId]         -- set of exact dependencies. These must be-                           -- consistent with the 'buildDepends' in the-                           -- 'PackageDescrption' that you'd get by applying-                           -- the flag assignment.-  deriving Show--instance Package ConfiguredPackage where-  packageId (ConfiguredPackage pkg _ _) = packageId pkg--instance PackageFixedDeps ConfiguredPackage where-  depends (ConfiguredPackage _ _ deps) = deps----- | We re-use @GenericPackageDescription@ and use the @package-url@--- field to store the tarball URI.-data AvailablePackage = AvailablePackage {-    packageInfoId      :: PackageId,-    packageDescription :: GenericPackageDescription,-    packageSource      :: AvailablePackageSource-  }-  deriving Show--instance Package AvailablePackage where packageId = packageInfoId--data AvailablePackageSource =--    -- | An unpacked package in the given dir, or current dir-    LocalUnpackedPackage (Maybe FilePath)--    -- | A package as a tarball that's available as a local tarball-  | LocalTarballPackage FilePath--    -- | A package as a tarball from a remote URI-  | RemoteTarballPackage URI--    -- | A package available as a tarball from a repository.-    ---    -- It may be from a local repository or from a remote repository, with a-    -- locally cached copy. ie a package available from hackage-  | RepoTarballPackage Repo----  | ScmPackage-  deriving Show----TODO:---  * add support for darcs and other SCM style remote repos with a local cache--data LocalRepo = LocalRepo-  deriving (Show,Eq)--data RemoteRepo = RemoteRepo {-    remoteRepoName :: String,-    remoteRepoURI  :: URI-  }-  deriving (Show,Eq)--data Repo = Repo {-    repoKind     :: Either RemoteRepo LocalRepo,-    repoLocalDir :: FilePath-  }-  deriving (Show,Eq)--data UnresolvedDependency-    = UnresolvedDependency-    { dependency :: Dependency-    , depFlags   :: FlagAssignment-    }-  deriving (Show,Eq)---instance Text UnresolvedDependency where-  disp udep = disp (dependency udep) Disp.<+> dispFlags (depFlags udep)-    where -      dispFlags [] = Disp.empty-      dispFlags fs = Disp.text "--flags=" -                     Disp.<> -                     (Disp.doubleQuotes $ flagAssToDoc fs)-      flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc -> -                             (if not val then Disp.char '-' -                                         else Disp.empty)-                             Disp.<> Disp.text fname -                             Disp.<+> flagAssDoc)-                           Disp.empty -  parse = do-    dep <- parse -    Parse.skipSpaces-    flagAss <- Parse.option [] parseFlagAssignment-    return $ UnresolvedDependency dep flagAss -    where-      parseFlagAssignment :: Parse.ReadP r FlagAssignment-      parseFlagAssignment = do -        Parse.string "--flags"-        Parse.skipSpaces-        Parse.char '='-        Parse.skipSpaces-        inDoubleQuotes $ Parse.many1 flag-        where-          inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a-          inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"') --          flag = do-            Parse.skipSpaces-            val <- negative Parse.+++ positive-            name <- ident-            Parse.skipSpaces-            return (FlagName name,val)-          negative = do-            Parse.char '-'-            return False-          positive = return True--          ident :: Parse.ReadP r String-          ident = do -            -- First character must be a letter/digit to avoid flags-            -- like "+-debug":-            c  <- Parse.satisfy Char.isAlphaNum-            cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_' -                                                         || ch == '-')-            return (c:cs)-        ---type BuildResult  = Either BuildFailure BuildSuccess-data BuildFailure = DependentFailed PackageId-                  | DownloadFailed  SomeException-                  | UnpackFailed    SomeException-                  | ConfigureFailed SomeException-                  | BuildFailed     SomeException-                  | InstallFailed   SomeException-data BuildSuccess = BuildOk         DocsResult TestsResult--data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk-data TestsResult = TestsNotTried | TestsFailed | TestsOk
− cabal-install-0.9.5_rc20101226/Distribution/Client/Unpack.hs 
@@ -1,138 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Unpack--- Copyright   :  (c) Andrea Vezzosi 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Distribution.Client.Unpack (--    -- * Commands-    unpack,--  ) where--import Distribution.Package-         ( PackageId, Dependency(..) )-import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault)-import Distribution.Simple.Utils-         ( notice, die )-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Text(display)--import Distribution.Client.Setup(UnpackFlags(unpackVerbosity,-                                             unpackDestDir))-import Distribution.Client.Types(UnresolvedDependency(..),-                                 Repo, AvailablePackageSource(..),-                                 AvailablePackage(AvailablePackage),-                                 AvailablePackageDb(AvailablePackageDb))-import Distribution.Client.Dependency as Dependency-         ( resolveAvailablePackages-         , dependencyConstraints, dependencyTargets-         , PackagesPreference(..), PackagesPreferenceDefault(..)-         , PackagePreference(..) )-import Distribution.Client.Fetch-        ( fetchPackage )-import Distribution.Client.HttpUtils-        ( downloadURI )-import qualified Distribution.Client.Tar as Tar (extractTarGzFile)-import Distribution.Client.IndexUtils as IndexUtils-    (getAvailablePackages, disambiguateDependencies)--import System.Directory-         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist-         , getTemporaryDirectory )-import System.IO-         ( openTempFile, hClose )-import Control.Monad-         ( unless, when )-import Data.Monoid-         ( mempty )-import System.FilePath-         ( (</>), addTrailingPathSeparator )-import qualified Data.Map as Map--unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO ()-unpack flags _ [] =-    notice verbosity "No packages requested. Nothing to do."-  where-    verbosity = fromFlag (unpackVerbosity flags)--unpack flags repos deps = do-  db@(AvailablePackageDb available _)-            <- getAvailablePackages verbosity repos-  deps' <- IndexUtils.disambiguateDependencies available-         . map toUnresolved $ deps--  pkgs <- resolvePackages db deps'--  unless (null prefix) $-         createDirectoryIfMissing True prefix--  flip mapM_ pkgs $ \pkg -> case pkg of--    AvailablePackage pkgid _ (LocalTarballPackage tarballPath) ->-      unpackPackage verbosity prefix pkgid tarballPath--    AvailablePackage pkgid _ (RemoteTarballPackage tarballURL) -> do-      tmp <- getTemporaryDirectory-      (tarballPath, hnd) <- openTempFile tmp (display pkgid)-      hClose hnd-      --TODO: perhaps we've already had to download this to a local cache-      --      so we even know what package version it is. So might be able-      --      to get it from the local cache rather than from remote.-      downloadURI verbosity tarballURL tarballPath-      unpackPackage verbosity prefix pkgid tarballPath--    AvailablePackage pkgid _ (RepoTarballPackage repo) -> do-      tarballPath <- fetchPackage verbosity repo pkgid-      unpackPackage verbosity prefix pkgid tarballPath--    AvailablePackage _ _ (LocalUnpackedPackage _) ->-      error "Distribution.Client.Unpack.unpack: the impossible happened."--    where-      verbosity = fromFlag (unpackVerbosity flags)-      prefix = fromFlagOrDefault "" (unpackDestDir flags)-      toUnresolved d = UnresolvedDependency d []--unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO ()-unpackPackage verbosity prefix pkgid pkgPath = do-    let pkgdirname = display pkgid-        pkgdir     = prefix </> pkgdirname-        pkgdir'    = addTrailingPathSeparator pkgdir-    existsDir  <- doesDirectoryExist pkgdir-    when existsDir $ die $-     "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."-    existsFile  <- doesFileExist pkgdir-    when existsFile $ die $-     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."-    notice verbosity $ "Unpacking to " ++ pkgdir'-    Tar.extractTarGzFile prefix pkgdirname pkgPath--resolvePackages :: AvailablePackageDb-                -> [UnresolvedDependency]-                -> IO [AvailablePackage]-resolvePackages-  (AvailablePackageDb available availablePrefs) deps =--    either (die . unlines . map show) return $-      resolveAvailablePackages-        installed   available-        preferences constraints-        targets--  where-    installed   = mempty-    targets     = dependencyTargets     deps-    constraints = dependencyConstraints deps-    preferences = PackagesPreference-                    PreferLatestForSelected-                    [ PackageVersionPreference name ver-                    | (name, ver) <- Map.toList availablePrefs ]
− cabal-install-0.9.5_rc20101226/Distribution/Client/Update.hs 
@@ -1,82 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Update--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Distribution.Client.Update-    ( update-    ) where--import Distribution.Client.Types-         ( Repo(..), RemoteRepo(..), LocalRepo(..), AvailablePackageDb(..) )-import Distribution.Client.Fetch-         ( downloadIndex )-import qualified Distribution.Client.PackageIndex as PackageIndex-import Distribution.Client.IndexUtils-         ( getAvailablePackages )-import qualified Paths_cabal_install-         ( version )--import Distribution.Package-         ( PackageName(..), packageVersion )-import Distribution.Version-         ( anyVersion, withinRange )-import Distribution.Simple.Utils-         ( warn, notice, writeFileAtomic )-import Distribution.Verbosity-         ( Verbosity )--import qualified Data.ByteString.Lazy       as BS-import qualified Data.ByteString.Lazy.Char8 as BS.Char8-import Distribution.Client.GZipUtils (maybeDecompress)-import qualified Data.Map as Map-import System.FilePath (dropExtension)-import Data.Maybe      (fromMaybe)-import Control.Monad   (when)---- | 'update' downloads the package list from all known servers-update :: Verbosity -> [Repo] -> IO ()-update verbosity [] = do-  warn verbosity $ "No remote package servers have been specified. Usually "-                ++ "you would have one specified in the config file."-update verbosity repos = do-  mapM_ (updateRepo verbosity) repos-  checkForSelfUpgrade verbosity repos--updateRepo :: Verbosity -> Repo -> IO ()-updateRepo verbosity repo = case repoKind repo of-  Right LocalRepo -> return ()-  Left remoteRepo -> do-    notice verbosity $ "Downloading the latest package list from "-                    ++ remoteRepoName remoteRepo-    indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)-    writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack-                                              . maybeDecompress-                                            =<< BS.readFile indexPath--checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()-checkForSelfUpgrade verbosity repos = do-  AvailablePackageDb available prefs <- getAvailablePackages verbosity repos--  let self = PackageName "cabal-install"-      preferredVersionRange  = fromMaybe anyVersion (Map.lookup self prefs)-      currentVersion         = Paths_cabal_install.version-      laterPreferredVersions =-        [ packageVersion pkg-        | pkg <- PackageIndex.lookupPackageName available self-        , let version = packageVersion pkg-        , version > currentVersion-        , version `withinRange` preferredVersionRange ]--  when (not (null laterPreferredVersions)) $-    notice verbosity $-         "Note: there is a new version of cabal-install available.\n"-      ++ "To upgrade, run: cabal install cabal-install"-
− cabal-install-0.9.5_rc20101226/Distribution/Client/Upload.hs 
@@ -1,177 +0,0 @@--- This is a quick hack for uploading packages to Hackage.--- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload--module Distribution.Client.Upload (check, upload, report) where--import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))-import Distribution.Client.HttpUtils (proxy, isOldHackageURI)--import Distribution.Simple.Utils (debug, notice, warn, info)-import Distribution.Verbosity (Verbosity)-import Distribution.Text (display)-import Distribution.Client.Config--import qualified Distribution.Client.BuildReports.Anonymous as BuildReport-import qualified Distribution.Client.BuildReports.Upload as BuildReport--import Network.Browser-         ( BrowserAction, browse, request-         , Authority(..), addAuthority, setAuthorityGen-         , setOutHandler, setErrHandler, setProxy )-import Network.HTTP-         ( Header(..), HeaderName(..), findHeader-         , Request(..), RequestMethod(..), Response(..) )-import Network.TCP (HandleStream)-import Network.URI (URI(uriPath), parseURI)--import Data.Char        (intToDigit)-import Numeric          (showHex)-import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho-                        ,openBinaryFile, IOMode(ReadMode), hGetContents)-import Control.Exception (bracket)-import System.Random    (randomRIO)-import System.FilePath  ((</>), takeExtension, takeFileName)-import qualified System.FilePath.Posix as FilePath.Posix (combine)-import System.Directory-import Control.Monad (forM_)-----FIXME: how do we find this path for an arbitrary hackage server?--- is it always at some fixed location relative to the server root?-legacyUploadURI :: URI-Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"--checkURI :: URI-Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"---upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()-upload verbosity repos mUsername mPassword paths = do-          let uploadURI = if isOldHackageURI targetRepoURI-                          then legacyUploadURI-                          else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}-          Username username <- maybe promptUsername return mUsername-          Password password <- maybe promptPassword return mPassword-          let auth = addAuthority AuthBasic {-                       auRealm    = "Hackage",-                       auUsername = username,-                       auPassword = password,-                       auSite     = uploadURI-                     }-          flip mapM_ paths $ \path -> do-            notice verbosity $ "Uploading " ++ path ++ "... "-            handlePackage verbosity uploadURI auth path-  where-    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given-    promptUsername :: IO Username-    promptUsername = do-      putStr "Hackage username: "-      hFlush stdout-      fmap Username getLine--    promptPassword :: IO Password-    promptPassword = do-      putStr "Hackage password: "-      hFlush stdout-      -- save/restore the terminal echoing status-      passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do-        hSetEcho stdin False  -- no echoing for entering the password-        fmap Password getLine-      putStrLn ""-      return passwd--report :: Verbosity -> [Repo] -> IO ()-report verbosity repos-    = forM_ repos $ \repo ->-      case repoKind repo of-        Left remoteRepo-            -> do dotCabal <- defaultCabalDir-                  let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo-                  contents <- getDirectoryContents srcDir-                  forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->-                      do inp <- readFile (srcDir </> logFile)-                         let (reportStr, buildLog) = read inp :: (String,String)-                         case BuildReport.parse reportStr of-                           Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME-                           Right report' ->-                               do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')-                                  browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)]-                                  return ()-        Right{} -> return ()--check :: Verbosity -> [FilePath] -> IO ()-check verbosity paths = do-          flip mapM_ paths $ \path -> do-            notice verbosity $ "Checking " ++ path ++ "... "-            handlePackage verbosity checkURI (return ()) path--handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()-              -> FilePath -> IO ()-handlePackage verbosity uri auth path =-  do req <- mkRequest uri path-     p   <- proxy verbosity-     debug verbosity $ "\n" ++ show req-     (_,resp) <- browse $ do-                   setProxy p-                   setErrHandler (warn verbosity . ("http error: "++))-                   setOutHandler (debug verbosity)-                   auth-                   setAuthorityGen (\_ _ -> return Nothing)-                   request req-     debug verbosity $ show resp-     case rspCode resp of-       (2,0,0) -> do notice verbosity "Ok"-       (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": "-                                     ++ map intToDigit [x,y,z] ++ " "-                                     ++ rspReason resp-                     case findHeader HdrContentType resp of-                       Just contenttype-                         | takeWhile (/= ';') contenttype == "text/plain"-                         -> notice verbosity $ rspBody resp-                       _ -> debug verbosity $ rspBody resp--mkRequest :: URI -> FilePath -> IO (Request String)-mkRequest uri path = -    do pkg <- readBinaryFile path-       boundary <- genBoundary-       let body = printMultiPart boundary (mkFormData path pkg)-       return $ Request {-                         rqURI = uri,-                         rqMethod = POST,-                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),-                                      Header HdrContentLength (show (length body)),-                                      Header HdrAccept ("text/plain")],-                         rqBody = body-                        }--readBinaryFile :: FilePath -> IO String-readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents--genBoundary :: IO String-genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer-                 return $ showHex i ""--mkFormData :: FilePath -> String -> [BodyPart]-mkFormData path pkg =-  -- yes, web browsers are that stupid (re quoting)-  [BodyPart [Header hdrContentDisposition $-             "form-data; name=package; filename=\""++takeFileName path++"\"",-             Header HdrContentType "application/x-gzip"]-   pkg]--hdrContentDisposition :: HeaderName-hdrContentDisposition = HdrCustom "Content-disposition"---- * Multipart, partly stolen from the cgi package.--data BodyPart = BodyPart [Header] String--printMultiPart :: String -> [BodyPart] -> String-printMultiPart boundary xs = -    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf--printBodyPart :: String -> BodyPart -> String-printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c--crlf :: String-crlf = "\r\n"
− cabal-install-0.9.5_rc20101226/Distribution/Client/Utils.hs 
@@ -1,60 +0,0 @@-module Distribution.Client.Utils where--import Data.List-         ( sortBy, groupBy )-import System.Directory-         ( doesFileExist, getModificationTime-         , getCurrentDirectory, setCurrentDirectory )-import qualified Control.Exception as Exception-         ( finally )---- | Generic merging utility. For sorted input lists this is a full outer join.------ * The result list never contains @(Nothing, Nothing)@.----mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]-mergeBy cmp = merge-  where-    merge []     ys     = [ OnlyInRight y | y <- ys]-    merge xs     []     = [ OnlyInLeft  x | x <- xs]-    merge (x:xs) (y:ys) =-      case x `cmp` y of-        GT -> OnlyInRight   y : merge (x:xs) ys-        EQ -> InBoth      x y : merge xs     ys-        LT -> OnlyInLeft  x   : merge xs  (y:ys)--data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b--duplicates :: Ord a => [a] -> [[a]]-duplicates = duplicatesBy compare--duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]-duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp-  where-    eq a b = case cmp a b of-               EQ -> True-               _  -> False-    moreThanOne (_:_:_) = True-    moreThanOne _       = False---- | 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)---- | Executes the action in the specified directory.-inDir :: Maybe FilePath -> IO () -> IO ()-inDir Nothing m = m-inDir (Just d) m = do-  old <- getCurrentDirectory-  setCurrentDirectory d-  m `Exception.finally` setCurrentDirectory old
− cabal-install-0.9.5_rc20101226/Distribution/Client/Win32SelfUpgrade.hs 
@@ -1,222 +0,0 @@-{-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-}--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Win32SelfUpgrade--- Copyright   :  (c) Duncan Coutts 2008--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable------ Support for self-upgrading executables on Windows platforms.-------------------------------------------------------------------------------module Distribution.Client.Win32SelfUpgrade (--- * Explanation------ | Windows inherited a design choice from DOS that while initially innocuous--- has rather unfortunate consequences. It maintains the invariant that every--- open file has a corresponding name on disk. One positive consequence of this--- is that an executable can always find it's own executable file. The downside--- is that a program cannot be deleted or upgraded while it is running without--- hideous workarounds. This module implements one such hideous workaround.------ The basic idea is:------ * Move our own exe file to a new name--- * Copy a new exe file to the previous name--- * Run the new exe file, passing our own pid and new path--- * Wait for the new process to start--- * Close the new exe file--- * Exit old process------ Then in the new process:------ * Inform the old process that we've started--- * Wait for the old process to die--- * Delete the old exe file--- * Exit new process-----    possibleSelfUpgrade,-    deleteOldExeFile,-  ) where--#if mingw32_HOST_OS || mingw32_TARGET_OS--import qualified System.Win32 as Win32-import qualified System.Win32.DLL as Win32-import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)-import Foreign.Ptr (Ptr, nullPtr)-import System.Process (runProcess)-import System.Directory (canonicalizePath)-import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)--import Distribution.Verbosity as Verbosity (Verbosity, showForCabal)-import Distribution.Simple.Utils (debug, info)--import Prelude hiding (log)---- | If one of the given files is our own exe file then we arrange things such--- that the nested action can replace our own exe file.------ We require that the new process accepts a command line invocation that--- calls 'deleteOldExeFile', passing in the pid and exe file.----possibleSelfUpgrade :: Verbosity-                    -> [FilePath]-                    -> IO a -> IO a-possibleSelfUpgrade verbosity newPaths action = do-  dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE--  newPaths' <- mapM canonicalizePath newPaths-  let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'--  if not doingSelfUpgrade-    then action-    else do-      info verbosity $ "cabal-install does the replace-own-exe-file dance..."-      tmpPath <- moveOurExeOutOfTheWay verbosity-      result <- action-      scheduleOurDemise verbosity dstPath tmpPath-        (\pid path -> ["win32selfupgrade", pid, path-                      ,"--verbose=" ++ Verbosity.showForCabal verbosity])-      return result---- | The name of a Win32 Event object that we use to synchronise between the--- old and new processes. We need to synchronise to make sure that the old--- process has not yet terminated by the time the new one starts up and looks--- for the old process. Otherwise the old one might have already terminated--- and we could not wait on it terminating reliably (eg the pid might get--- re-used).----syncEventName :: String-syncEventName = "Local\\cabal-install-upgrade"---- | The first part of allowing our exe file to be replaced is to move the--- existing exe file out of the way. Although we cannot delete our exe file--- while we're still running, fortunately we can rename it, at least within--- the same directory.----moveOurExeOutOfTheWay :: Verbosity -> IO FilePath-moveOurExeOutOfTheWay verbosity = do-  ourPID  <-       getCurrentProcessId-  dstPath <- Win32.getModuleFileName Win32.nullHANDLE--  let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)--  debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath-  Win32.moveFile dstPath tmpPath-  return tmpPath---- | Assuming we've now installed the new exe file in the right place, we--- launch it and ask it to delete our exe file when we eventually terminate.----scheduleOurDemise :: Verbosity -> FilePath -> FilePath-                  -> (String -> FilePath -> [String]) -> IO ()-scheduleOurDemise verbosity dstPath tmpPath mkArgs = do-  ourPID <- getCurrentProcessId-  event  <- createEvent syncEventName--  let args = mkArgs (show ourPID) tmpPath-  log $ "launching child " ++ unwords (dstPath : map show args)-  runProcess dstPath args Nothing Nothing Nothing Nothing Nothing--  log $ "waiting for the child to start up"-  waitForSingleObject event (10*1000) -- wait at most 10 sec-  log $ "child started ok"--  where-    log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)---- | Assuming we're now in the new child process, we've been asked by the old--- process to wait for it to terminate and then we can remove the old exe file--- that it renamted itself to.----deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()-deleteOldExeFile verbosity oldPID tmpPath = do-  log $ "process started. Will delete exe file of process "-     ++ show oldPID ++ " at path " ++ tmpPath--  log $ "getting handle of parent process " ++ show oldPID-  oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID)--  log $ "synchronising with parent"-  event <- openEvent syncEventName-  setEvent event--  log $ "waiting for parent process to terminate"-  waitForSingleObject oldPHANDLE Win32.iNFINITE-  log $ "parent process terminated"--  log $ "deleting parent's old .exe file"-  Win32.deleteFile tmpPath--  where-    log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)----------------------------- Win32 foreign imports------- A bunch of functions sadly not provided by the Win32 package.--foreign import stdcall unsafe "windows.h GetCurrentProcessId"-  getCurrentProcessId :: IO DWORD--foreign import stdcall unsafe "windows.h WaitForSingleObject"-  waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD--waitForSingleObject :: HANDLE -> DWORD -> IO ()-waitForSingleObject handle timeout =-  Win32.failIf_ bad "WaitForSingleObject" $-    waitForSingleObject_ handle timeout-  where-    bad result   = not (result == 0 || result == wAIT_TIMEOUT)-    wAIT_TIMEOUT = 0x00000102--foreign import stdcall unsafe "windows.h CreateEventW"-  createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE--createEvent :: String -> IO HANDLE-createEvent name = do-  Win32.failIfNull "CreateEvent" $-    Win32.withTString name $-      createEvent_ nullPtr False False--foreign import stdcall unsafe "windows.h OpenEventW"-  openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE--openEvent :: String -> IO HANDLE-openEvent name = do-  Win32.failIfNull "OpenEvent" $-    Win32.withTString name $-      openEvent_ eVENT_MODIFY_STATE False-  where-    eVENT_MODIFY_STATE :: DWORD-    eVENT_MODIFY_STATE = 0x0002--foreign import stdcall unsafe "windows.h SetEvent"-  setEvent_ :: HANDLE -> IO BOOL--setEvent :: HANDLE -> IO ()-setEvent handle =-  Win32.failIfFalse_ "SetEvent" $-    setEvent_ handle--#else--import Distribution.Verbosity (Verbosity)-import Distribution.Simple.Utils (die)--possibleSelfUpgrade :: Verbosity-                    -> [FilePath]-                    -> IO a -> IO a-possibleSelfUpgrade _ _ action = action--deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()-deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32"--#endif
− cabal-install-0.9.5_rc20101226/Distribution/Client/World.hs 
@@ -1,132 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.World--- Copyright   :  (c) Peter Robinson 2009--- License     :  BSD-like------ Maintainer  :  thaldyron@gmail.com--- Stability   :  provisional--- Portability :  portable------ Interface to the world-file that contains a list of explicitly--- requested packages. Meant to be imported qualified.------ A world file entry stores the package-name, package-version, and--- user flags.--- For example, the entry generated by--- # cabal install stm-io-hooks --flags="-debug"--- looks like this:--- # stm-io-hooks -any --flags="-debug"--- To rebuild/upgrade the packages in world (e.g. when updating the compiler)--- use--- # cabal install world----------------------------------------------------------------------------------module Distribution.Client.World (-    insert,-    delete,-    getContents,--    worldPkg,-    isWorldTarget,-    isGoodWorldTarget,-  ) where--import Distribution.Simple.Utils( writeFileAtomic )-import Distribution.Client.Types-    ( UnresolvedDependency(..) )-import Distribution.Package-    ( PackageName(..), Dependency( Dependency ) )-import Distribution.Version( anyVersion )-import Distribution.Text( display, simpleParse )-import Distribution.Verbosity ( Verbosity )-import Distribution.Simple.Utils ( die, info, chattyTry )-import Data.List( unionBy, deleteFirstsBy, nubBy )-import Data.Maybe( isJust, fromJust )-import System.IO.Error( isDoesNotExistError, )-import qualified Data.ByteString.Lazy.Char8 as B-import Prelude hiding ( getContents )---- | Adds packages to the world file; creates the file if it doesn't--- exist yet. Version constraints and flag assignments for a package are--- updated if already present. IO errors are non-fatal.-insert :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO ()-insert = modifyWorld $ unionBy equalUDep---- | Removes packages from the world file.--- Note: Currently unused as there is no mechanism in Cabal (yet) to--- handle uninstalls. IO errors are non-fatal.-delete :: Verbosity -> FilePath -> [UnresolvedDependency] -> IO ()-delete = modifyWorld $ flip (deleteFirstsBy equalUDep)---- | UnresolvedDependency values are considered equal if they refer to--- the same package, i.e., we don't care about differing versions or flags.-equalUDep :: UnresolvedDependency -> UnresolvedDependency -> Bool-equalUDep (UnresolvedDependency (Dependency pkg1 _) _)-          (UnresolvedDependency (Dependency pkg2 _) _) = pkg1 == pkg2---- | Modifies the world file by applying an update-function ('unionBy'--- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of--- packages. IO errors are considered non-fatal.-modifyWorld :: ([UnresolvedDependency] -> [UnresolvedDependency]-                -> [UnresolvedDependency])-                        -- ^ Function that defines how-                        -- the list of user packages are merged with-                        -- existing world packages.-            -> Verbosity-            -> FilePath               -- ^ Location of the world file-            -> [UnresolvedDependency] -- ^ list of user supplied packages-            -> IO ()-modifyWorld _ _         _     []   = return ()-modifyWorld f verbosity world pkgs =-  chattyTry "Error while updating world-file. " $ do-    pkgsOldWorld <- getContents world-    -- Filter out packages that are not in the world file:-    let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld-    -- 'Dependency' is not an Ord instance, so we need to check for-    -- equivalence the awkward way:-    if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&-            all (`elem` pkgsNewWorld) pkgsOldWorld)-      then do-        info verbosity "Updating world file..."-        writeFileAtomic world $ unlines-            [ (display pkg) | pkg <- pkgsNewWorld]-      else-        info verbosity "World file is already up to date."----- | Returns the content of the world file as a list-getContents :: FilePath -> IO [UnresolvedDependency]-getContents world = do-  content <- safelyReadFile world-  let result = map simpleParse (lines $ B.unpack content)-  if all isJust result-    then return $ map fromJust result-    else die "Could not parse world file."-  where-  safelyReadFile :: FilePath -> IO B.ByteString-  safelyReadFile file = B.readFile file `catch` handler-    where-      handler e | isDoesNotExistError e = return B.empty-                | otherwise             = ioError e----- | A dummy package that represents the world file.-worldPkg :: PackageName-worldPkg = PackageName "world"---- | Currently we have a silly way of representing the world target as--- an 'UnresolvedDependency' so we need a way to recognise it.------ We should be using a structured type with various target kinds, like--- local file, repo package etc.----isWorldTarget :: UnresolvedDependency -> Bool-isWorldTarget (UnresolvedDependency (Dependency pkg _) _) =-  pkg == worldPkg--isGoodWorldTarget :: UnresolvedDependency -> Bool-isGoodWorldTarget (UnresolvedDependency (Dependency pkg ver) flags) =-     pkg == worldPkg-  && ver == anyVersion-  && null flags
− cabal-install-0.9.5_rc20101226/Distribution/Compat/Exception.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--- #hide-module Distribution.Compat.Exception (-  SomeException,-  onException,-  catchIO,-  handleIO,-  catchExit,-  throwIOIO-  ) where--import System.Exit-import qualified Control.Exception as Exception-#if MIN_VERSION_base(4,0,0)-import Control.Exception (SomeException)-#else-import Control.Exception (Exception)-type SomeException = Exception-#endif--onException :: IO a -> IO b -> IO a-#if MIN_VERSION_base(4,0,0)-onException = Exception.onException-#else-onException io what = io `Exception.catch` \e -> do what-                                                    Exception.throw e-#endif--throwIOIO :: Exception.IOException -> IO a-#if MIN_VERSION_base(4,0,0)-throwIOIO = Exception.throwIO-#else-throwIOIO = Exception.throwIO . Exception.IOException-#endif--catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#if MIN_VERSION_base(4,0,0)-catchIO = Exception.catch-#else-catchIO = Exception.catchJust Exception.ioErrors-#endif--handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a-handleIO = flip catchIO--catchExit :: IO a -> (ExitCode -> IO a) -> IO a-#if MIN_VERSION_base(4,0,0)-catchExit = Exception.catch-#else-catchExit = Exception.catchJust exitExceptions-    where exitExceptions (Exception.ExitException ee) = Just ee-          exitExceptions _                            = Nothing-#endif
− cabal-install-0.9.5_rc20101226/LICENSE 
@@ -1,34 +0,0 @@-Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren,-                         Bjorn Bringert, Krasimir Angelov,-                         Malcolm Wallace, Ross Patterson,-                         Lemmih, Paolo Martini, Don Stewart,-                         Duncan Coutts-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-install-0.9.5_rc20101226/Main.hs 
@@ -1,388 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Main--- Copyright   :  (c) David Himmelstrup 2005--- License     :  BSD-like------ Maintainer  :  lemmih@gmail.com--- Stability   :  provisional--- Portability :  portable------ Entry point to the default cabal-install front-end.--------------------------------------------------------------------------------module Main (main) where--import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand, globalRepos-         , ConfigFlags(..)-         , ConfigExFlags(..), configureExCommand-         , InstallFlags(..), defaultInstallFlags-         , installCommand, upgradeCommand-         , FetchFlags(..), fetchCommand-         , checkCommand-         , updateCommand-         , ListFlags(..), listCommand-         , InfoFlags(..), infoCommand-         , UploadFlags(..), uploadCommand-         , InitFlags, initCommand-         , reportCommand-         , unpackCommand, UnpackFlags(..)-         , parsePackageArgs )-import Distribution.Simple.Setup-         ( BuildFlags(..), buildCommand-         , HaddockFlags(..), haddockCommand-         , HscolourFlags(..), hscolourCommand-         , CopyFlags(..), copyCommand-         , RegisterFlags(..), registerCommand-         , CleanFlags(..), cleanCommand-         , SDistFlags(..), sdistCommand-         , TestFlags(..), testCommand-         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )--import Distribution.Client.Types-         ( UnresolvedDependency(UnresolvedDependency) )-import Distribution.Client.SetupWrapper-         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Config-         ( SavedConfig(..), loadConfig, defaultConfigFile )-import Distribution.Client.List             (list, info)-import Distribution.Client.Install          (install, upgrade)-import Distribution.Client.Configure        (configure)-import Distribution.Client.Update           (update)-import Distribution.Client.Fetch            (fetch)-import Distribution.Client.Check as Check   (check)---import Distribution.Client.Clean            (clean)-import Distribution.Client.Upload as Upload (upload, check, report)-import Distribution.Client.SrcDist          (sdist)-import Distribution.Client.Unpack           (unpack)-import Distribution.Client.Init             (initCabal)-import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade--import Distribution.Simple.Compiler-         ( PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (defaultProgramConfiguration)-import Distribution.Simple.Command-import Distribution.Simple.Configure (configCompilerAux)-import Distribution.Simple.Utils-         ( cabalVersion, die, topHandler, intercalate )-import Distribution.Text-         ( display )-import Distribution.Verbosity as Verbosity-       ( Verbosity, normal, intToVerbosity )-import qualified Paths_cabal_install (version)--import System.Environment       (getArgs, getProgName)-import System.Exit              (exitFailure)-import System.FilePath          (splitExtension, takeExtension)-import System.Directory         (doesFileExist)-import Data.List                (intersperse)-import Data.Maybe               (fromMaybe)-import Data.Monoid              (Monoid(..))-import Control.Monad            (unless)---- | Entry point----main :: IO ()-main = getArgs >>= mainWorker--mainWorker :: [String] -> IO ()-mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args-mainWorker args = topHandler $-  case commandsRun globalCommand commands args of-    CommandHelp   help                 -> printGlobalHelp help-    CommandList   opts                 -> printOptionsList opts-    CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (globalflags, commandParse)  ->-      case commandParse of-        _ | fromFlag (globalVersion globalflags)        -> printVersion-          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion-        CommandHelp     help           -> printCommandHelp help-        CommandList     opts           -> printOptionsList opts-        CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action globalflags--  where-    printCommandHelp help = do-      pname <- getProgName-      putStr (help pname)-    printGlobalHelp help = do-      pname <- getProgName-      configFile <- defaultConfigFile-      putStr (help pname)-      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"-            ++ "  " ++ configFile ++ "\n"-    printOptionsList = putStr . unlines-    printErrors errs = die $ concat (intersperse "\n" errs)-    printNumericVersion = putStrLn $ display Paths_cabal_install.version-    printVersion        = putStrLn $ "cabal-install version "-                                  ++ display Paths_cabal_install.version-                                  ++ "\nusing version "-                                  ++ display cabalVersion-                                  ++ " of the Cabal library "--    commands =-      [installCommand         `commandAddAction` installAction-      ,updateCommand          `commandAddAction` updateAction-      ,listCommand            `commandAddAction` listAction-      ,infoCommand            `commandAddAction` infoAction-      ,fetchCommand           `commandAddAction` fetchAction-      ,unpackCommand          `commandAddAction` unpackAction-      ,checkCommand           `commandAddAction` checkAction-      ,sdistCommand           `commandAddAction` sdistAction-      ,uploadCommand          `commandAddAction` uploadAction-      ,reportCommand          `commandAddAction` reportAction-      ,initCommand            `commandAddAction` initAction-      ,configureExCommand     `commandAddAction` configureAction-      ,wrapperAction (buildCommand defaultProgramConfiguration)-                     buildVerbosity    buildDistPref-      ,wrapperAction copyCommand-                     copyVerbosity     copyDistPref-      ,wrapperAction haddockCommand-                     haddockVerbosity  haddockDistPref-      ,wrapperAction cleanCommand-                     cleanVerbosity    cleanDistPref-      ,wrapperAction hscolourCommand-                     hscolourVerbosity hscolourDistPref-      ,wrapperAction registerCommand-                     regVerbosity      regDistPref-      ,wrapperAction testCommand-                     testVerbosity     testDistPref-      ,upgradeCommand         `commandAddAction` upgradeAction-      ]--wrapperAction :: Monoid flags-              => CommandUI flags-              -> (flags -> Flag Verbosity)-              -> (flags -> Flag String)-              -> Command (GlobalFlags -> IO ())-wrapperAction command verbosityFlag distPrefFlag =-  commandAddAction command-    { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do-    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)-        setupScriptOptions = defaultSetupScriptOptions {-          useDistPref = fromFlagOrDefault-                          (useDistPref defaultSetupScriptOptions)-                          (distPrefFlag flags)-        }-    setupWrapper verbosity setupScriptOptions Nothing-                 command (const flags) extraArgs--configureAction :: (ConfigFlags, ConfigExFlags)-                -> [String] -> GlobalFlags -> IO ()-configureAction (configFlags, configExFlags) extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags'-  configure verbosity-            (configPackageDB' configFlags') (globalRepos globalFlags')-            comp conf configFlags' configExFlags' extraArgs--installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)-              -> [String] -> GlobalFlags -> IO ()-installAction (configFlags, _, installFlags) _ _globalFlags-  | fromFlagOrDefault False (installOnly installFlags)-  = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-    in setupWrapper verbosity defaultSetupScriptOptions Nothing-         installCommand (const mempty) []--installAction (configFlags, configExFlags, installFlags)-              extraArgs globalFlags = do-  pkgs <- either die return (parsePackageArgs extraArgs)-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags-      installFlags'  = defaultInstallFlags          `mappend`-                       savedInstallFlags     config `mappend` installFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags'-  install verbosity-          (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags'-          [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')-          | pkg <- pkgs ]--listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()-listAction listFlags extraArgs globalFlags = do-  let verbosity = fromFlag (listVerbosity listFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags-  list verbosity-       (configPackageDB' configFlags)-       (globalRepos globalFlags')-       comp-       conf-       listFlags-       extraArgs--infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()-infoAction infoFlags extraArgs globalFlags = do-  pkgs <- either die return (parsePackageArgs extraArgs)-  let verbosity = fromFlag (infoVerbosity infoFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags-  info verbosity-       (configPackageDB' configFlags)-       (globalRepos globalFlags')-       comp-       conf-       infoFlags-       [ UnresolvedDependency pkg []  | pkg <- pkgs ]--updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()-updateAction verbosityFlag extraArgs globalFlags = do-  unless (null extraArgs) $ do-    die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs-  let verbosity = fromFlag verbosityFlag-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  update verbosity (globalRepos globalFlags')--upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)-              -> [String] -> GlobalFlags -> IO ()-upgradeAction (configFlags, configExFlags, installFlags)-              extraArgs globalFlags = do-  pkgs <- either die return (parsePackageArgs extraArgs)-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags-      installFlags'  = defaultInstallFlags          `mappend`-                       savedInstallFlags     config `mappend` installFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags'-  upgrade verbosity-          (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags'-          [ UnresolvedDependency pkg (configConfigurationsFlags configFlags')-          | pkg <- pkgs ]--fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()-fetchAction fetchFlags extraArgs globalFlags = do-  pkgs <- either die return (parsePackageArgs extraArgs)-  let verbosity = fromFlag (fetchVerbosity fetchFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let configFlags  = savedConfigureFlags config-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags-  fetch verbosity-        (configPackageDB' configFlags) (globalRepos globalFlags')-        comp conf fetchFlags-        [ UnresolvedDependency pkg [] --TODO: flags?-        | pkg <- pkgs ]--uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()-uploadAction uploadFlags extraArgs globalFlags = do-  let verbosity = fromFlag (uploadVerbosity uploadFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags-      globalFlags' = savedGlobalFlags config `mappend` globalFlags-      tarfiles     = extraArgs-  checkTarFiles extraArgs-  if fromFlag (uploadCheck uploadFlags')-    then Upload.check  verbosity tarfiles-    else upload verbosity-                (globalRepos globalFlags')-                (flagToMaybe $ uploadUsername uploadFlags')-                (flagToMaybe $ uploadPassword uploadFlags')-                tarfiles-  where-    checkTarFiles tarfiles-      | null tarfiles-      = die "the 'upload' command expects one or more .tar.gz packages."-      | not (null otherFiles)-      = die $ "the 'upload' command expects only .tar.gz packages: "-           ++ intercalate ", " otherFiles-      | otherwise = sequence_-                      [ do exists <- doesFileExist tarfile-                           unless exists $ die $ "file not found: " ++ tarfile-                      | tarfile <- tarfiles ]--      where otherFiles = filter (not . isTarGzFile) tarfiles-            isTarGzFile file = case splitExtension file of-              (file', ".gz") -> takeExtension file' == ".tar"-              _              -> False--checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()-checkAction verbosityFlag extraArgs _globalFlags = do-  unless (null extraArgs) $ do-    die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs-  allOk <- Check.check (fromFlag verbosityFlag)-  unless allOk exitFailure---sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()-sdistAction sflags extraArgs _globalFlags = do-  unless (null extraArgs) $ do-    die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs-  sdist sflags--reportAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()-reportAction verbosityFlag extraArgs globalFlags = do-  unless (null extraArgs) $ do-    die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs--  let verbosity = fromFlag verbosityFlag-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let globalFlags' = savedGlobalFlags config `mappend` globalFlags--  Upload.report verbosity (globalRepos globalFlags')--unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()-unpackAction flags extraArgs globalFlags = do-  pkgs <- either die return (parsePackageArgs extraArgs)-  let verbosity = fromFlag (unpackVerbosity flags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  unpack flags (globalRepos (savedGlobalFlags config)) pkgs--initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()-initAction flags _extraArgs _globalFlags = do-  initCabal flags---- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.----win32SelfUpgradeAction :: [String] -> IO ()-win32SelfUpgradeAction (pid:path:rest) =-  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path-  where-    verbosity = case rest of-      (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']-         -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))-      _  ->           Verbosity.normal-win32SelfUpgradeAction _ = return ()------- Utils (transitionary)------- | Currently the user interface specifies the package dbs to use with just a--- single valued option, a 'PackageDB'. However internally we represent the--- stack of 'PackageDB's explictly as a list. This function converts encodes--- the package db stack implicit in a single packagedb.------ TODO: sort this out, make it consistent with the command line UI-implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack-implicitPackageDbStack userInstall packageDbFlag-  | userInstall = GlobalPackageDB : UserPackageDB : extra-  | otherwise   = GlobalPackageDB : extra-  where-    extra = case packageDbFlag of-      Just (SpecificPackageDB db) -> [SpecificPackageDB db]-      _                           -> []--configPackageDB' :: ConfigFlags -> PackageDBStack-configPackageDB' cfg =-  implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg))-  where-    userInstall = fromFlagOrDefault True (configUserInstall cfg)
− cabal-install-0.9.5_rc20101226/Paths_cabal_install.hs 
@@ -1,8 +0,0 @@-module Paths_cabal_install (-    version,-  ) where--import Data.Version (Version(..))--version :: Version-version = Version {versionBranch = [0,9,5], versionTags = []}
− cabal-install-0.9.5_rc20101226/README 
@@ -1,153 +0,0 @@-The cabal-install package-=========================--[Cabal home page](http://www.haskell.org/cabal/)--The `cabal-install` package provides a command line tool called `cabal`. The-tool uses the `Cabal` library and provides a convenient user interface to the-Cabal/Hackage package build and distribution system. It can build and install-both local and remote packages, including dependencies.---Installation instructions for the cabal-install command line tool-=================================================================--The `cabal-install` package requires a number of other packages, most of which-come with a standard ghc installation. It requires the `network` package, which-is sometimes packaged separately by Linux distributions, for example on-debian or ubuntu it is in "libghc6-network-dev".--It requires a few other Haskell packages that are not always installed:-- * Cabal  (version 1.8  or later)- * HTTP   (version 4000 or later)- * zlib   (version 0.4  or later)--All of these are available from [Hackage](http://hackage.haskell.org).--Note that on some Unix systems you may need to install an additional zlib-development package using your system package manager, for example on-debian or ubuntu it is in "zlib1g-dev". It is needed is because the-Haskell zlib package uses the system zlib C library and header files.--The `cabal-install` package is now part of the Haskell Platform so you do not-usually need to install it separately. However if you are starting from a-minimal ghc installation then you need to install `cabal-install` manually.-Since it is just an ordinary Cabal package it can be built in the standard-way, but to make it a bit easier we have partly automated the process:---Quickstart on Unix systems-----------------------------As a convenience for users on Unix systems there is a `bootstrap.sh` script-which will download and install each of the dependencies in turn.--    $ ./bootstrap.sh--It will download and install the above three dependencies. The script will-install the library packages into `$HOME/.cabal/` and the `cabal` program will-be installed into `$HOME/.cabal/bin/`.--You then have two choices:-- * put `$HOME/.cabal/bin` on your `$PATH`- * move the `cabal` program somewhere that is on your `$PATH`--The next thing to do is to get the latest list of packages with:--    $ cabal update--This will also create a default config file (if it does not already echo exist)-at `$HOME/.cabal/config`--By default cabal will install programs to `$HOME/.cabal/bin`. If you do not-want to add this directory to your `$PATH` then you can change the setting in-the config file, for example you could use:--    symlink-bindir: $HOME/bin---Quickstart on Windows systems--------------------------------For Windows users we provide a pre-compiled [cabal.exe] program. Just download-it and put it somewhere on your `%PATH%`, for example-`C:\Program Files\Haskell\bin`.--[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe--The next thing to do is to get the latest list of packages with--    cabal update--This will also create a default config file (if it does not already echo exist)-at `C:\Documents and Settings\username\Application Data\cabal\config`---Using cabal-install-===================--There are two sets of commands: commands for working with a local project build-tree and ones for working with distributed released packages from hackage.--For a list of the full set of commands and the flags for each command see--    $ cabal --help---Commands for developers for local build trees------------------------------------------------The commands for local project build trees are almost exactly the same as the-`runghc Setup` command line interface that many people are already familiar-with. In particular there are the commands--    cabal configure-    cabal build-    cabal haddock-    cabal clean-    cabal sdist--The `install` command is somewhat different. It is an all-in-one operation. If-you run--    $ cabal install--in your build tree it will configure, build and install. It takes all the flags-that `configure` takes such as `--global` and `--prefix`.--In addition, if any dependencies are not installed it will download and install-them. If can also rebuild packages to ensure a consistent set of dependencies.---Commands for released hackage packages-----------------------------------------    $ cabal update--This command gets the latest list of packages from the hackage server.-Currently this command has to be run manually occasionally, in particular if-you want to install a newly released package. ---    $ cabal install xmonad--This is the eponymous command. It installs one or more named packages (and all-their dependencies) from hackage.--By default it installs the latest available version however you can optionally-specify exact versions or version ranges. For example `cabal install alex-2.2`-or `cabal install parsec < 3`.--    $ cabal upgrade xmonad--This is a variation on the `install` command. Both mean to install the latest-version, the only difference is in the treatment of dependencies. The `install`-command tries to use existing installed versions of dependent packages while-the `upgrade` command tries to upgrade all the dependencies too.--    $ cabal list xml--This does a search of the installed and available packages. It does a-case-insensitive substring match on the package name.
− cabal-install-0.9.5_rc20101226/Setup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
− cabal-install-0.9.5_rc20101226/bash-completion/cabal 
@@ -1,24 +0,0 @@-# cabal command line completion-# Copyright 2007-2008 "Lennart Kolmodin" <kolmodin@gentoo.org>-#                     "Duncan Coutts"     <dcoutts@gentoo.org>-#--_cabal()-{-    # get the word currently being completed-    local cur-    cur=${COMP_WORDS[$COMP_CWORD]}--    # create a command line to run-    local cmd-    # copy all words the user has entered-    cmd=( ${COMP_WORDS[@]} )--    # replace the current word with --list-options-    cmd[${COMP_CWORD}]="--list-options"--    # the resulting completions should be put into this array-    COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) )-}--complete -F _cabal -o default cabal
− cabal-install-0.9.5_rc20101226/bootstrap.sh 
@@ -1,241 +0,0 @@-#!/bin/sh--# A script to bootstrap cabal-install.--# It works by downloading and installing the Cabal, zlib and-# HTTP packages. It then installs cabal-install itself.-# It expects to be run inside the cabal-install directory.--# install settings, you can override these by setting environment vars-PREFIX=${PREFIX:-${HOME}/.cabal}-#VERBOSE-#EXTRA_CONFIGURE_OPTS--# programs, you can override these by setting environment vars-GHC=${GHC:-ghc}-GHC_PKG=${GHC_PKG:-ghc-pkg}-WGET=${WGET:-wget}-CURL=${CURL:-curl}-TAR=${TAR:-tar}-GUNZIP=${GUNZIP:-gunzip}-SCOPE_OF_INSTALLATION="--user"---for arg in $*-do-  case "${arg}" in-    "--user")-      SCOPE_OF_INSTALLATION=${arg}-      shift;;-    "--global")-      SCOPE_OF_INSTALLATION=${arg}-      PREFIX="/usr/local"-      shift;;-    *)-      echo "Unknown argument or option, quitting: ${arg}"-      echo "usage: bootstrap.sh [OPTION]"-      echo-      echo "options:"-      echo "   --user    Install for the local user (default)"-      echo "   --global  Install systemwide"-      exit;;-  esac-done---# Versions of the packages to install.-# The version regex says what existing installed versions are ok.-PARSEC_VER="2.1.0.1";   PARSEC_VER_REGEXP="2\."     # == 2.*-NETWORK_VER="2.2.1.10"; NETWORK_VER_REGEXP="2\."    # == 2.*-CABAL_VER="1.10.0.0";   CABAL_VER_REGEXP="1\.10\."  # == 1.10.*-MTL_VER="1.1.1.0";      MTL_VER_REGEXP="1\.1\."     # == 1.1.*-HTTP_VER="4000.0.10";   HTTP_VER_REGEXP="4000\.0"   # == 4000.0.*-ZLIB_VER="0.5.2.0";     ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.*-TIME_VER="1.2.0.3"      TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.*--HACKAGE_URL="http://hackage.haskell.org/packages/archive"--die () {-  echo-  echo "Error during cabal-install bootstrap:"-  echo $1 >&2-  exit 2-}--# Check we're in the right directory:-grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \-  || die "The bootstrap.sh script must be run in the cabal-install directory"--${GHC} --numeric-version > /dev/null \-  || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars."-${GHC_PKG} --version     > /dev/null \-  || die "${GHC_PKG} not found."-GHC_VER=`${GHC} --numeric-version`-GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5`-[ ${GHC_VER} = ${GHC_PKG_VER} ] \-  || die "Version mismatch between ${GHC} and ${GHC_PKG} If you set the GHC variable then set GHC_PKG too"--# Cache the list of packages:-echo "Checking installed packages for ghc-${GHC_VER}..."-${GHC_PKG} list > ghc-pkg.list \-  || die "running '${GHC_PKG} list' failed"--# Will we need to install this package, or is a suitable version installed?-need_pkg () {-  PKG=$1-  VER_MATCH=$2-  if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1-  then-    return 1;-  else-    return 0;-  fi-  #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it.-}--info_pkg () {-  PKG=$1-  VER=$2-  VER_MATCH=$3--  if need_pkg ${PKG} ${VER_MATCH}-  then-    echo "${PKG}-${VER} will be downloaded and installed."-  else-    echo "${PKG} is already installed and the version is ok."-  fi-}--dep_pkg () {-  PKG=$1-  VER_MATCH=$2-  if need_pkg ${PKG} ${VER_MATCH}-  then-    echo-    echo "The Haskell package '${PKG}' is required but it is not installed."-    echo "If you are using a ghc package provided by your operating system"-    echo "then install the corresponding packages for 'parsec' and 'network'."-    echo "If you built ghc from source with only the core libraries then you"-    echo "should install these extra packages. You can get them from hackage."-    die "The Haskell package '${PKG}' is required but it is not installed."-  else-    echo "${PKG} is already installed and the version is ok."-  fi-}--fetch_pkg () {-  PKG=$1-  VER=$2--  URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz-  if which ${CURL} > /dev/null-  then-    ${CURL} -C - -O ${URL} || die "Failed to download ${PKG}."-  elif which ${WGET} > /dev/null-  then-    ${WGET} -c ${URL} || die "Failed to download ${PKG}."-  else-    die "Failed to find a downloader. 'wget' or 'curl' is required."-  fi-  [ -f "${PKG}-${VER}.tar.gz" ] \-    || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"-}--unpack_pkg () {-  PKG=$1-  VER=$2--  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/-  ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \-    || die "Failed to gunzip ${PKG}-${VER}.tar.gz"-  ${TAR} -xf "${PKG}-${VER}.tar" \-    || die "Failed to untar ${PKG}-${VER}.tar.gz"-  [ -d "${PKG}-${VER}" ] \-    || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/"-}--install_pkg () {-  PKG=$1--  [ -x Setup ] && ./Setup clean-  [ -f Setup ] && rm Setup--  ${GHC} --make Setup -o Setup \-    || die "Compiling the Setup script failed"-  [ -x Setup ] || die "The Setup script does not exist or cannot be run"--  ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \-    --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \-    ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \-    || die "Configuring the ${PKG} package failed"--  ./Setup build ${VERBOSE} \-    || die "Building the ${PKG} package failed"--  ./Setup install ${VERBOSE} \-    || die "Installing the ${PKG} package failed"-}--do_pkg () {-  PKG=$1-  VER=$2-  VER_MATCH=$3--  if need_pkg ${PKG} ${VER_MATCH}-  then-    echo-    echo "Downloading ${PKG}-${VER}..."-    fetch_pkg ${PKG} ${VER}-    unpack_pkg ${PKG} ${VER}-    cd "${PKG}-${VER}"-    install_pkg ${PKG} ${VER}-    cd ..-  fi-}--# Actually do something!--info_pkg "parsec"  ${PARSEC_VER}  ${PARSEC_VER_REGEXP}-info_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}-info_pkg "Cabal"   ${CABAL_VER}   ${CABAL_VER_REGEXP}-info_pkg "mtl"     ${MTL_VER}     ${MTL_VER_REGEXP}-info_pkg "time"    ${TIME_VER}   ${TIME_VER_REGEXP}-info_pkg "HTTP"    ${HTTP_VER}    ${HTTP_VER_REGEXP}-info_pkg "zlib"    ${ZLIB_VER}    ${ZLIB_VER_REGEXP}--do_pkg "parsec"  ${PARSEC_VER}  ${PARSEC_VER_REGEXP}-do_pkg "network" ${NETWORK_VER} ${NETWORK_VER_REGEXP}-do_pkg "Cabal"   ${CABAL_VER}   ${CABAL_VER_REGEXP}-do_pkg "mtl"     ${MTL_VER}     ${MTL_VER_REGEXP}-do_pkg "time"    ${TIME_VER}    ${TIME_VER_REGEXP}-do_pkg "HTTP"    ${HTTP_VER}    ${HTTP_VER_REGEXP}-do_pkg "zlib"    ${ZLIB_VER}    ${ZLIB_VER_REGEXP}--install_pkg "cabal-install"--echo-echo "==========================================="-CABAL_BIN="$PREFIX/bin"-if [ -x "$CABAL_BIN/cabal" ]-then-    echo "The 'cabal' program has been installed in $CABAL_BIN/"-    echo "You should either add $CABAL_BIN to your PATH"-    echo "or copy the cabal program to a directory that is on your PATH."-    echo-    echo "The first thing to do is to get the latest list of packages with:"-    echo "  cabal update"-    echo "This will also create a default config file (if it does not already"-    echo "exist) at $HOME/.cabal/config"-    echo-    echo "By default cabal will install programs to $HOME/.cabal/bin"-    echo "If you do not want to add this directory to your PATH then you can"-    echo "change the setting in the config file, for example you could use:"-    echo "symlink-bindir: $HOME/bin"-else-    echo "Sorry, something went wrong."-    echo "The 'cabal' executable was not successfully installed into"-    echo "$CABAL_BIN/"-fi-echo--rm ghc-pkg.list
− cabal-install-0.9.5_rc20101226/cabal-install.cabal 
@@ -1,117 +0,0 @@-Name:               cabal-install-Version:            0.9.5-Synopsis:           The command-line interface for Cabal and Hackage.-Description:-    The \'cabal\' command-line program simplifies the process of managing-    Haskell software by automating the fetching, configuration, compilation-    and installation of Haskell libraries and programs.-homepage:           http://www.haskell.org/cabal/-bug-reports:        http://hackage.haskell.org/trac/hackage/-License:            BSD3-License-File:       LICENSE-Author:             Lemmih <lemmih@gmail.com>-                    Paolo Martini <paolo@nemail.it>-                    Bjorn Bringert <bjorn@bringert.net>-                    Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    Duncan Coutts <duncan@haskell.org>-Maintainer:         cabal-devel@haskell.org-Copyright:          2005 Lemmih <lemmih@gmail.com>-                    2006 Paolo Martini <paolo@nemail.it>-                    2007 Bjorn Bringert <bjorn@bringert.net>-                    2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>-                    2007-2010 Duncan Coutts <duncan@haskell.org>-Category:           Distribution-Build-type:         Simple-Extra-Source-Files: README bash-completion/cabal bootstrap.sh-Cabal-Version:      >= 1.6--source-repository head-  type:     darcs-  location: http://darcs.haskell.org/cabal-install/--flag old-base-  description: Old, monolithic base-  default: False--flag bytestring-in-base--Executable cabal-    Main-Is:            Main.hs-    -- We want assertion checking on even if people build with -O-    -- although it is expensive, we want to catch problems early:-    ghc-options:        -Wall -fno-ignore-asserts-    if impl(ghc >= 6.8)-      ghc-options: -fwarn-tabs-    Other-Modules:-        Distribution.Client.BuildReports.Anonymous-        Distribution.Client.BuildReports.Storage-        Distribution.Client.BuildReports.Types-        Distribution.Client.BuildReports.Upload-        Distribution.Client.Check-        Distribution.Client.Config-        Distribution.Client.Configure-        Distribution.Client.Dependency-        Distribution.Client.Dependency.TopDown-        Distribution.Client.Dependency.TopDown.Constraints-        Distribution.Client.Dependency.TopDown.Types-        Distribution.Client.Dependency.Types-        Distribution.Client.Fetch-        Distribution.Client.GZipUtils-        Distribution.Client.Haddock-        Distribution.Client.HttpUtils-        Distribution.Client.IndexUtils-        Distribution.Client.Init-        Distribution.Client.Init.Heuristics-        Distribution.Client.Init.Licenses-        Distribution.Client.Init.Types-        Distribution.Client.Install-        Distribution.Client.InstallPlan-        Distribution.Client.InstallSymlink-        Distribution.Client.List-        Distribution.Client.PackageIndex-        Distribution.Client.PackageUtils-        Distribution.Client.Setup-        Distribution.Client.SetupWrapper-        Distribution.Client.SrcDist-        Distribution.Client.Tar-        Distribution.Client.Types-        Distribution.Client.Unpack-        Distribution.Client.Update-        Distribution.Client.Upload-        Distribution.Client.Utils-        Distribution.Client.World-        Distribution.Client.Win32SelfUpgrade-        Distribution.Compat.Exception-        Paths_cabal_install--    build-depends: base     >= 2        && < 5,-                   Cabal    >= 1.10     && < 1.11,-                   filepath >= 1.0      && < 1.3,-                   network  >= 1        && < 3,-                   HTTP     >= 4000.0.2 && < 4001,-                   zlib     >= 0.4      && < 0.6,-                   time     >= 1.1      && < 1.3--    if flag(old-base)-      build-depends: base < 3-    else-      build-depends: base       >= 3,-                     process    >= 1   && < 1.1,-                     directory  >= 1   && < 1.2,-                     pretty     >= 1   && < 1.1,-                     random     >= 1   && < 1.1,-                     containers >= 0.1 && < 0.5,-                     array      >= 0.1 && < 0.4,-                     old-time   >= 1   && < 1.1--    if flag(bytestring-in-base)-      build-depends: base >= 2.0 && < 2.2-    else-      build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9--    if os(windows)-      build-depends: Win32 >= 2 && < 3-      cpp-options: -DWIN32-    else-      build-depends: unix >= 1.0 && < 2.5-    extensions: CPP
− cabal-install-0.9.5_rc20101226/changelog 
@@ -1,100 +0,0 @@--*-change-log-*---0.8.0 Duncan Coutts <duncan@haskell.org> Dec 2009-	* Works with ghc-6.12-	* New "cabal init" command for making initial project .cabal file-	* New feature to maintain an index of haddock documentation--0.6.4 Duncan Coutts <duncan@haskell.org> Nov 2009-	* Improve the algorithm for selecting the base package version-	* Hackage errors now reported by "cabal upload [--check]"-	* Improved format of messages from "cabal check"-	* Config file can now be selected by an env var-	* Updated tar reading/writing code-	* Improve instructions in the README and bootstrap output-	* Fix bootstrap.sh on Solaris 9-	* Fix bootstrap for systems where network uses parsec 3-	* Fix building with ghc-6.6--0.6.2 Duncan Coutts <duncan@haskell.org> Feb 2009-	* The upgrade command has been disabled in this release-	* The configure and install commands now have consistent behaviour-	* Reduce the tendancy to re-install already existing packages-	* The --constraint= flag now works for the install command-	* New --preference= flag for soft constraints / version preferences-	* Improved bootstrap.sh script, smarter and better error checking-	* New cabal info command to display detailed info on packages-	* New cabal unpack command to download and untar a package-	* HTTP-4000 package required, should fix bugs with http proxies-	* Now works with authenticated proxies.-	* On Windows can now override the proxy setting using an env var-	* Fix compatability with config files generated by older versions-	* Warn if the hackage package list is very old-	* More helpful --help output, mention config file and examples-	* Better documentation in ~/.cabal/config file-	* Improved command line interface for logging and build reporting-	* Minor improvements to some messages--0.6.0 Duncan Coutts <duncan@haskell.org> Oct 2008-	* Constraint solver can now cope with base 3 and base 4-	* Allow use of package version preferences from hackage index-	* More detailed output from cabal install --dry-run -v-	* Improved bootstrap.sh--0.5.2 Duncan Coutts <duncan@haskell.org> Aug 2008-	* Suport building haddock documentaion-	* Self-reinstall now works on Windows-	* Allow adding symlinks to excutables into a separate bindir-	* New self-documenting config file-	* New install --reinstall flag-	* More helpful status messages in a couple places-	* Upload failures now report full text error message from the server-	* Support for local package repositories-	* New build logging and reporting-	* New command to upload build reports to (a compatible) server-	* Allow tilde in hackage server URIs-	* Internal code improvements-	* Many other minor improvements and bug fixes--0.5.1 Duncan Coutts <duncan@haskell.org> June 2008-	* Restore minimal hugs support in dependency resolver-	* Fix for disabled http proxies on Windows-	* Revert to global installs on Windows by default--0.5.0 Duncan Coutts <duncan@haskell.org> June 2008-	* New package dependency resolver, solving diamond dep problem-	* Integrate cabal-setup functionality-	* Integrate cabal-upload functionality-	* New cabal update and check commands-	* Improved behavior for install and upgrade commands-	* Full Windows support-	* New command line handling-	* Bash command line completion-	* Allow case insensitive package names on command line-	* New --dry-run flag for install, upgrade and fetch commands-	* New --root-cmd flag to allow installing as root-	* New --cabal-lib-version flag to select different Cabal lib versions-	* Support for HTTP proxies-	* Improved cabal list output-	* Build other non-dependent packages even when some fail-	* Report a summary of all build failures at the end-	* Partial support for hugs-	* Partial implementation of build reporting and logging-	* More consistent logging and verbosity-	* Significant internal code restructuring--0.4 Duncan Coutts <duncan@haskell.org> Oct 2007-	* Renamed executable from 'cabal-install' to 'cabal'-	* Partial Windows compatability-	* Do per-user installs by default-	* cabal install now installs the package in the current directory-	* Allow multiple remote servers-	* Use zlib lib and internal tar code and rather than external tar-	* Reorganised configuration files-	* Significant code restructuring-	* Cope with packages with conditional dependencies--0.3 and older versions by Lemmih, Paolo Martini and others 2006-2007-	* Switch from smart-server, dumb-client model to the reverse-	* New .tar.gz based index format-	* New remote and local package archive format
− cabal-install-0.9.5_rc20101226/tests/test-cabal-install 
@@ -1,9 +0,0 @@-#!/bin/sh--darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \-cd Cabal/cabal-install && \-make && \-sudo make install && \-sudo cabal-install update && \-cabal-install install --prefix=/tmp --user hnop && \-ls -l /tmp/bin/hnop
− cabal-install-0.9.5_rc20101226/tests/test-cabal-install-user 
@@ -1,8 +0,0 @@-#!/bin/sh--darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \-cd Cabal/cabal-install && \-make install-user && \-cabal-install update && \-cabal-install install --prefix=/tmp --user hnop && \-ls -l /tmp/bin/hnop
+ cabal/.darcs-boring view
@@ -0,0 +1,6 @@+^dist(/|$)+^setup(/|$)+^GNUmakefile$+^Makefile.local$+^.depend(.bak)?$+^doc/.depend(.bak)?$
+ cabal/HACKING view
@@ -0,0 +1,10 @@+If you want to hack on Cabal, don't be intimidated!++Read the guide to the source code:+  http://hackage.haskell.org/trac/hackage/wiki/SourceGuide++There are other resources listed on the dev wiki:+  http://hackage.haskell.org/trac/hackage/++In particular, the open tickets and the cabal-devel mailing list+which is a good place to ask questions.
+ cabal/IMPORTED-FROM view
@@ -0,0 +1,7 @@+http://darcs.haskell.org/cabal-branches/cabal-1.12++Fri Jul 15 15:04:46 EEST 2011  Ian Lynagh <igloo@earth.li>+  * Bump version number+    hunk ./cabal/Cabal.cabal 2+    -Version: 1.11.2+    +Version: 1.12.0
+ cabal/LICENSE view
@@ -0,0 +1,33 @@+Copyright (c) 2011, Duncan Coutts and Ian Lynagh.++See */LICENSE for the copyright holders of the subcomponents.++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/README view
@@ -0,0 +1,8 @@+This Cabal darcs repository contains multiple packages:++ * cabal/          -- the Cabal library package+ * cabal-install/  -- the cabal-install package containing the 'cabal' tool.++See the README in each subdir for more details.++The canonical upstream repo lives at http://darcs.haskell.org/cabal/
+ cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs view
@@ -0,0 +1,311 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Anonymous (+    BuildReport(..),+    InstallOutcome(..),+    Outcome(..),++    -- * Constructing and writing reports+    new,++    -- * parsing and pretty printing+    parse,+    parseList,+    show,+--    showList,+  ) where++import Distribution.Client.Types+         ( ConfiguredPackage(..) )+import qualified Distribution.Client.Types as BR+         ( BuildResult, BuildFailure(..), BuildSuccess(..)+         , DocsResult(..), TestsResult(..) )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )+import qualified Paths_cabal_install (version)++import Distribution.Package+         ( PackageIdentifier(..), PackageName(..), Package(packageId) )+import Distribution.PackageDescription+         ( FlagName(..), FlagAssignment )+--import Distribution.Version+--         ( Version )+import Distribution.System+         ( OS, Arch )+import Distribution.Compiler+         ( CompilerId )+import qualified Distribution.Text as Text+         ( Text(disp, parse) )+import Distribution.ParseUtils+         ( FieldDescr(..), ParseResult(..), Field(..)+         , simpleField, listField, ppFields, readFields+         , syntaxError, locatedErrorMsg )+import Distribution.Simple.Utils+         ( comparing )++import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, pfail, munch1, skipSpaces )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( Doc, render, char, text )+import Text.PrettyPrint.HughesPJ+         ( (<+>), (<>) )++import Data.List+         ( unfoldr, sortBy )+import Data.Char as Char+         ( isAlpha, isAlphaNum )++import Prelude hiding (show)++data BuildReport+   = BuildReport {+    -- | The package this build report is about+    package         :: PackageIdentifier,++    -- | The OS and Arch the package was built on+    os              :: OS,+    arch            :: Arch,++    -- | The Haskell compiler (and hopefully version) used+    compiler        :: CompilerId,++    -- | The uploading client, ie cabal-install-x.y.z+    client          :: PackageIdentifier,++    -- | Which configurations flags we used+    flagAssignment  :: FlagAssignment,++    -- | Which dependent packages we were using exactly+    dependencies    :: [PackageIdentifier],++    -- | Did installing work ok?+    installOutcome  :: InstallOutcome,++    --   Which version of the Cabal library was used to compile the Setup.hs+--    cabalVersion    :: Version,++    --   Which build tools we were using (with versions)+--    tools      :: [PackageIdentifier],++    -- | Configure outcome, did configure work ok?+    docsOutcome     :: Outcome,++    -- | Configure outcome, did configure work ok?+    testsOutcome    :: Outcome+  }++data InstallOutcome+   = DependencyFailed PackageIdentifier+   | DownloadFailed+   | UnpackFailed+   | SetupFailed+   | ConfigureFailed+   | BuildFailed+   | InstallFailed+   | InstallOk+  deriving Eq++data Outcome = NotTried | Failed | Ok+  deriving Eq++new :: OS -> Arch -> CompilerId -- -> Version+    -> ConfiguredPackage -> BR.BuildResult+    -> BuildReport+new os' arch' comp (ConfiguredPackage pkg flags deps) result =+  BuildReport {+    package               = packageId pkg,+    os                    = os',+    arch                  = arch',+    compiler              = comp,+    client                = cabalInstallID,+    flagAssignment        = flags,+    dependencies          = deps,+    installOutcome        = convertInstallOutcome,+--    cabalVersion          = undefined+    docsOutcome           = convertDocsOutcome,+    testsOutcome          = convertTestsOutcome+  }+  where+    convertInstallOutcome = case result of+      Left  (BR.DependentFailed p) -> DependencyFailed p+      Left  (BR.DownloadFailed  _) -> DownloadFailed+      Left  (BR.UnpackFailed    _) -> UnpackFailed+      Left  (BR.ConfigureFailed _) -> ConfigureFailed+      Left  (BR.BuildFailed     _) -> BuildFailed+      Left  (BR.InstallFailed   _) -> InstallFailed+      Right (BR.BuildOk       _ _) -> InstallOk+    convertDocsOutcome = case result of+      Left _                                -> NotTried+      Right (BR.BuildOk BR.DocsNotTried _)  -> NotTried+      Right (BR.BuildOk BR.DocsFailed _)    -> Failed+      Right (BR.BuildOk BR.DocsOk _)        -> Ok+    convertTestsOutcome = case result of+      Left _                                -> NotTried+      Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried+      Right (BR.BuildOk _ BR.TestsFailed)   -> Failed+      Right (BR.BuildOk _ BR.TestsOk)       -> Ok++cabalInstallID :: PackageIdentifier+cabalInstallID =+  PackageIdentifier (PackageName "cabal-install") Paths_cabal_install.version++-- ------------------------------------------------------------+-- * External format+-- ------------------------------------------------------------++initialBuildReport :: BuildReport+initialBuildReport = BuildReport {+    package         = requiredField "package",+    os              = requiredField "os",+    arch            = requiredField "arch",+    compiler        = requiredField "compiler",+    client          = requiredField "client",+    flagAssignment  = [],+    dependencies    = [],+    installOutcome  = requiredField "install-outcome",+--    cabalVersion  = Nothing,+--    tools         = [],+    docsOutcome     = NotTried,+    testsOutcome    = NotTried+  }+  where+    requiredField fname = error ("required field: " ++ fname)++-- -----------------------------------------------------------------------------+-- Parsing++parse :: String -> Either String BuildReport+parse s = case parseFields s of+  ParseFailed perror -> Left  msg where (_, msg) = locatedErrorMsg perror+  ParseOk   _ report -> Right report++--FIXME: this does not allow for optional or repeated fields+parseFields :: String -> ParseResult BuildReport+parseFields input = do+  fields <- mapM extractField =<< readFields input+  let merged = mergeBy (\desc (_,name,_) -> compare (fieldName desc) name)+                       sortedFieldDescrs+                       (sortBy (comparing (\(_,name,_) -> name)) fields)+  checkMerged initialBuildReport merged++  where+    extractField :: Field -> ParseResult (Int, String, String)+    extractField (F line name value)  = return (line, name, value)+    extractField (Section line _ _ _) = syntaxError line "Unrecognized stanza"+    extractField (IfBlock line _ _ _) = syntaxError line "Unrecognized stanza"++    checkMerged report [] = return report+    checkMerged report (merged:remaining) = case merged of+      InBoth fieldDescr (line, _name, value) -> do+        report' <- fieldSet fieldDescr line value report+        checkMerged report' remaining+      OnlyInRight (line, name, _) ->+        syntaxError line ("Unrecognized field " ++ name)+      OnlyInLeft  fieldDescr ->+        fail ("Missing field " ++ fieldName fieldDescr)++parseList :: String -> [BuildReport]+parseList str =+  [ report | Right report <- map parse (split str) ]++  where+    split :: String -> [String]+    split = filter (not . null) . unfoldr chunk . lines+    chunk [] = Nothing+    chunk ls = case break null ls of+                 (r, rs) -> Just (unlines r, dropWhile null rs)++-- -----------------------------------------------------------------------------+-- Pretty-printing++show :: BuildReport -> String+show = Disp.render . ppFields fieldDescrs++-- -----------------------------------------------------------------------------+-- Description of the fields, for parsing/printing++fieldDescrs :: [FieldDescr BuildReport]+fieldDescrs =+ [ simpleField "package"         Text.disp      Text.parse+                                 package        (\v r -> r { package = v })+ , simpleField "os"              Text.disp      Text.parse+                                 os             (\v r -> r { os = v })+ , simpleField "arch"            Text.disp      Text.parse+                                 arch           (\v r -> r { arch = v })+ , simpleField "compiler"        Text.disp      Text.parse+                                 compiler       (\v r -> r { compiler = v })+ , simpleField "client"          Text.disp      Text.parse+                                 client         (\v r -> r { client = v })+ , listField   "flags"           dispFlag       parseFlag+                                 flagAssignment (\v r -> r { flagAssignment = v })+ , listField   "dependencies"    Text.disp      Text.parse+                                 dependencies   (\v r -> r { dependencies = v })+ , simpleField "install-outcome" Text.disp      Text.parse+                                 installOutcome (\v r -> r { installOutcome = v })+ , simpleField "docs-outcome"    Text.disp      Text.parse+                                 docsOutcome    (\v r -> r { docsOutcome = v })+ , simpleField "tests-outcome"   Text.disp      Text.parse+                                 testsOutcome   (\v r -> r { testsOutcome = v })+ ]++sortedFieldDescrs :: [FieldDescr BuildReport]+sortedFieldDescrs = sortBy (comparing fieldName) fieldDescrs++dispFlag :: (FlagName, Bool) -> Disp.Doc+dispFlag (FlagName name, True)  =                  Disp.text name+dispFlag (FlagName name, False) = Disp.char '-' <> Disp.text name++parseFlag :: Parse.ReadP r (FlagName, Bool)+parseFlag = do+  name <- Parse.munch1 (\c -> Char.isAlphaNum c || c == '_' || c == '-')+  case name of+    ('-':flag) -> return (FlagName flag, False)+    flag       -> return (FlagName flag, True)++instance Text.Text InstallOutcome where+  disp (DependencyFailed pkgid) = Disp.text "DependencyFailed" <+> Text.disp pkgid+  disp DownloadFailed  = Disp.text "DownloadFailed"+  disp UnpackFailed    = Disp.text "UnpackFailed"+  disp SetupFailed     = Disp.text "SetupFailed"+  disp ConfigureFailed = Disp.text "ConfigureFailed"+  disp BuildFailed     = Disp.text "BuildFailed"+  disp InstallFailed   = Disp.text "InstallFailed"+  disp InstallOk       = Disp.text "InstallOk"++  parse = do+    name <- Parse.munch1 Char.isAlphaNum+    case name of+      "DependencyFailed" -> do Parse.skipSpaces+                               pkgid <- Text.parse+                               return (DependencyFailed pkgid)+      "DownloadFailed"   -> return DownloadFailed+      "UnpackFailed"     -> return UnpackFailed+      "SetupFailed"      -> return SetupFailed+      "ConfigureFailed"  -> return ConfigureFailed+      "BuildFailed"      -> return BuildFailed+      "InstallFailed"    -> return InstallFailed+      "InstallOk"        -> return InstallOk+      _                  -> Parse.pfail++instance Text.Text Outcome where+  disp NotTried = Disp.text "NotTried"+  disp Failed   = Disp.text "Failed"+  disp Ok       = Disp.text "Ok"+  parse = do+    name <- Parse.munch1 Char.isAlpha+    case name of+      "NotTried" -> return NotTried+      "Failed"   -> return Failed+      "Ok"       -> return Ok+      _          -> Parse.pfail
+ cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs view
@@ -0,0 +1,127 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Reporting+-- Copyright   :  (c) David Waern 2008+-- License     :  BSD-like+--+-- Maintainer  :  david.waern@gmail.com+-- Stability   :  experimental+-- Portability :  portable+--+-- Anonymous build report data structure, printing and parsing+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Storage (++    -- * Storing and retrieving build reports+    storeAnonymous,+    storeLocal,+--    retrieve,++    -- * 'InstallPlan' support+    fromInstallPlan,+  ) where++import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (BuildReport)++import Distribution.Client.Types+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan+         ( InstallPlan )++import Distribution.Simple.InstallDirs+         ( PathTemplate, fromPathTemplate+         , initialPathTemplateEnv, substPathTemplate )+import Distribution.System+         ( Platform(Platform) )+import Distribution.Compiler+         ( CompilerId )+import Distribution.Simple.Utils+         ( comparing, equating )++import Data.List+         ( groupBy, sortBy )+import Data.Maybe+         ( catMaybes )+import System.FilePath+         ( (</>), takeDirectory )+import System.Directory+         ( createDirectoryIfMissing )++storeAnonymous :: [(BuildReport, Repo)] -> IO ()+storeAnonymous reports = sequence_+  [ appendFile file (concatMap format reports')+  | (repo, reports') <- separate reports+  , let file = repoLocalDir repo </> "build-reports.log" ]+  --TODO: make this concurrency safe, either lock the report file or make sure+  -- the writes for each report are atomic (under 4k and flush at boundaries)++  where+    format r = '\n' : BuildReport.show r ++ "\n"+    separate :: [(BuildReport, Repo)]+             -> [(Repo, [BuildReport])]+    separate = map (\rs@((_,repo,_):_) -> (repo, [ r | (r,_,_) <- rs ]))+             . map concat+             . groupBy (equating (repoName . head))+             . sortBy (comparing (repoName . head))+             . groupBy (equating repoName)+             . onlyRemote+    repoName (_,_,rrepo) = remoteRepoName rrepo++    onlyRemote :: [(BuildReport, Repo)] -> [(BuildReport, Repo, RemoteRepo)]+    onlyRemote rs =+      [ (report, repo, remoteRepo)+      | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ]++storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()+storeLocal templates reports = sequence_+  [ do createDirectoryIfMissing True (takeDirectory file)+       appendFile file output+       --TODO: make this concurrency safe, either lock the report file or make+       --      sure the writes for each report are atomic+  | (file, reports') <- groupByFileName+                          [ (reportFileName template report, report)+                          | template <- templates+                          , (report, _repo) <- reports ]+  , let output = concatMap format reports'+  ]+  where+    format r = '\n' : BuildReport.show r ++ "\n"++    reportFileName template report =+        fromPathTemplate (substPathTemplate env template)+      where env = initialPathTemplateEnv+                    (BuildReport.package  report)+                    (BuildReport.compiler report)++    groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))+                    . groupBy (equating  fst)+                    . sortBy  (comparing fst)++-- ------------------------------------------------------------+-- * InstallPlan support+-- ------------------------------------------------------------++fromInstallPlan :: InstallPlan -> [(BuildReport, Repo)]+fromInstallPlan plan = catMaybes+                     . map (fromPlanPackage platform comp)+                     . InstallPlan.toList+                     $ plan+  where platform = InstallPlan.planPlatform plan+        comp     = InstallPlan.planCompiler plan++fromPlanPackage :: Platform -> CompilerId+                -> InstallPlan.PlanPackage+                -> Maybe (BuildReport, Repo)+fromPlanPackage (Platform arch os) comp planPackage = case planPackage of++  InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {+                          packageSource = RepoTarballPackage repo _ _ }) _ _) result+    -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)++  InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {+                       packageSource = RepoTarballPackage repo _ _ }) _ _) result+    -> Just $ (BuildReport.new os arch comp pkg (Left result), repo)++  _ -> Nothing
+ cabal/cabal-install/Distribution/Client/BuildReports/Types.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.BuildReports.Types+-- Copyright   :  (c) Duncan Coutts 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Types related to build reporting+--+-----------------------------------------------------------------------------+module Distribution.Client.BuildReports.Types (+    ReportLevel(..),+  ) where++import qualified Distribution.Text as Text+         ( Text(..) )++import qualified Distribution.Compat.ReadP as Parse+         ( pfail, munch1 )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( text )++import Data.Char as Char+         ( isAlpha, toLower )++data ReportLevel = NoReports | AnonymousReports | DetailedReports+  deriving (Eq, Ord, Show)++instance Text.Text ReportLevel where+  disp NoReports        = Disp.text "none"+  disp AnonymousReports = Disp.text "anonymous"+  disp DetailedReports  = Disp.text "detailed"+  parse = do+    name <- Parse.munch1 Char.isAlpha+    case lowercase name of+      "none"       -> return NoReports+      "anonymous"  -> return AnonymousReports+      "detailed"   -> return DetailedReports+      _            -> Parse.pfail++lowercase :: String -> String+lowercase = map Char.toLower
+ cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs view
@@ -0,0 +1,74 @@+{-# LANGUAGE PatternGuards #-}+-- This is a quick hack for uploading build reports to Hackage.++module Distribution.Client.BuildReports.Upload+    ( BuildLog+    , BuildReportId+    , uploadReports+    , postBuildReport+    , putBuildLog+    ) where++import Network.Browser+         ( BrowserAction, request, setAllowRedirects )+import Network.HTTP+         ( Header(..), HeaderName(..)+         , Request(..), RequestMethod(..), Response(..) )+import Network.TCP (HandleStream)+import Network.URI (URI, uriPath, parseRelativeReference, relativeTo)++import Control.Monad+         ( forM_ )+import System.FilePath.Posix+         ( (</>) )+import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import Distribution.Client.BuildReports.Anonymous (BuildReport)+import Distribution.Text (display)++type BuildReportId = URI+type BuildLog = String++uploadReports :: URI -> [(BuildReport, Maybe BuildLog)]+              -> BrowserAction (HandleStream String) ()+              ->  BrowserAction (HandleStream BuildLog) ()+uploadReports uri reports auth = do+  auth+  forM_ reports $ \(report, mbBuildLog) -> do+     buildId <- postBuildReport uri report+     case mbBuildLog of+       Just buildLog -> putBuildLog buildId buildLog+       Nothing       -> return ()++postBuildReport :: URI -> BuildReport+                -> BrowserAction (HandleStream BuildLog) BuildReportId+postBuildReport uri buildReport = do+  setAllowRedirects False+  (_, response) <- request Request {+    rqURI     = uri { uriPath = "/package" </> display (BuildReport.package buildReport) </> "reports" },+    rqMethod  = POST,+    rqHeaders = [Header HdrContentType   ("text/plain"),+                 Header HdrContentLength (show (length body)),+                 Header HdrAccept        ("text/plain")],+    rqBody    = body+  }+  case rspCode response of+    (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location+                                     relativeTo rel uri+                                  | Header HdrLocation location <- rspHeaders response ]+              -> return $ buildId+    _         -> error "Unrecognised response from server."+  where body  = BuildReport.show buildReport++putBuildLog :: BuildReportId -> BuildLog+            -> BrowserAction (HandleStream BuildLog) ()+putBuildLog reportId buildLog = do+  --FIXME: do something if the request fails+  (_, response) <- request Request {+      rqURI     = reportId{uriPath = uriPath reportId </> "log"},+      rqMethod  = PUT,+      rqHeaders = [Header HdrContentType   ("text/plain"),+                   Header HdrContentLength (show (length buildLog)),+                   Header HdrAccept        ("text/plain")],+      rqBody    = buildLog+    }+  return ()
+ cabal/cabal-install/Distribution/Client/Check.hs view
@@ -0,0 +1,85 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Check+-- Copyright   :  (c) Lennart Kolmodin 2008+-- License     :  BSD-like+--+-- Maintainer  :  kolmodin@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Check a package for common mistakes+--+-----------------------------------------------------------------------------+module Distribution.Client.Check (+    check+  ) where++import Control.Monad ( when, unless )++import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.PackageDescription.Check+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Simple.Utils+         ( defaultPackageDesc, toUTF8, wrapText )++check :: Verbosity -> IO Bool+check verbosity = do+    pdfile <- defaultPackageDesc verbosity+    ppd <- readPackageDescription verbosity pdfile+    -- flatten the generic package description into a regular package+    -- description+    -- TODO: this may give more warnings than it should give;+    --       consider two branches of a condition, one saying+    --          ghc-options: -Wall+    --       and the other+    --          ghc-options: -Werror+    --      joined into+    --          ghc-options: -Wall -Werror+    --      checkPackages will yield a warning on the last line, but it+    --      would not on each individual branch.+    --      Hovever, this is the same way hackage does it, so we will yield+    --      the exact same errors as it will.+    let pkg_desc = flattenPackageDescription ppd+    ioChecks <- checkPackageFiles pkg_desc "."+    let packageChecks = ioChecks ++ checkPackage ppd (Just pkg_desc)+        buildImpossible = [ x | x@PackageBuildImpossible {} <- packageChecks ]+        buildWarning    = [ x | x@PackageBuildWarning {}    <- packageChecks ]+        distSuspicious  = [ x | x@PackageDistSuspicious {}  <- packageChecks ]+        distInexusable  = [ x | x@PackageDistInexcusable {} <- packageChecks ]++    unless (null buildImpossible) $ do+        putStrLn "The package will not build sanely due to these errors:"+        printCheckMessages buildImpossible++    unless (null buildWarning) $ do+        putStrLn "The following warnings are likely affect your build negatively:"+        printCheckMessages buildWarning++    unless (null distSuspicious) $ do+        putStrLn "These warnings may cause trouble when distributing the package:"+        printCheckMessages distSuspicious++    unless (null distInexusable) $ do+        putStrLn "The following errors will cause portability problems on other environments:"+        printCheckMessages distInexusable++    let isDistError (PackageDistSuspicious {}) = False+        isDistError _                          = True+        errors = filter isDistError packageChecks++    unless (null errors) $ do+        putStrLn "Hackage would reject this package."++    when (null packageChecks) $ do+        putStrLn "No errors or warnings could be found in the package."++    return (null packageChecks)++  where+    printCheckMessages = mapM_ (putStrLn . format . explanation)+    format = toUTF8 . wrapText . ("* "++)
+ cabal/cabal-install/Distribution/Client/Config.hs view
@@ -0,0 +1,536 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Config+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Utilities for handling saved state such as known packages, known servers and downloaded packages.+-----------------------------------------------------------------------------+module Distribution.Client.Config (+    SavedConfig(..),+    loadConfig,++    showConfig,+    showConfigWithComments,+    parseConfig,++    defaultCabalDir,+    defaultConfigFile,+    defaultCacheDir,+    defaultLogsDir,+  ) where+++import Distribution.Client.Types+         ( RemoteRepo(..), Username(..), Password(..) )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand+         , ConfigExFlags(..), configureExOptions, defaultConfigExFlags+         , InstallFlags(..), installOptions, defaultInstallFlags+         , UploadFlags(..), uploadCommand+         , ReportFlags(..), reportCommand+         , showRepo, parseRepo )++import Distribution.Simple.Setup+         ( ConfigFlags(..), configureOptions, defaultConfigFlags+         , installDirsOptions+         , Flag, toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Simple.InstallDirs+         ( InstallDirs(..), defaultInstallDirs+         , PathTemplate, toPathTemplate )+import Distribution.ParseUtils+         ( FieldDescr(..), liftField+         , ParseResult(..), locatedErrorMsg, showPWarning+         , readFields, warning, lineNo+         , simpleField, listField, parseFilePathQ, parseTokenQ )+import qualified Distribution.ParseUtils as ParseUtils+         ( Field(..) )+import qualified Distribution.Text as Text+         ( Text(..) )+import Distribution.Simple.Command+         ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)+         , viewAsFieldDescr )+import Distribution.Simple.Program+         ( defaultProgramConfiguration )+import Distribution.Simple.Utils+         ( notice, warn, lowercase )+import Distribution.Compiler+         ( CompilerFlavor(..), defaultCompilerFlavor )+import Distribution.Verbosity+         ( Verbosity, normal )++import Data.List+         ( partition, find )+import Data.Maybe+         ( fromMaybe )+import Data.Monoid+         ( Monoid(..) )+import Control.Monad+         ( when, foldM, liftM )+import qualified Data.Map as Map+import qualified Distribution.Compat.ReadP as Parse+         ( option )+import qualified Text.PrettyPrint.HughesPJ as Disp+         ( Doc, render, text, colon, vcat, empty, isEmpty, nest )+import Text.PrettyPrint.HughesPJ+         ( (<>), (<+>), ($$), ($+$) )+import System.Directory+         ( createDirectoryIfMissing, getAppUserDataDirectory )+import Network.URI+         ( URI(..), URIAuth(..) )+import System.FilePath+         ( (</>), takeDirectory )+import System.Environment+         ( getEnvironment )+import System.IO.Error+         ( isDoesNotExistError )++--+-- * Configuration saved in the config file+--++data SavedConfig = SavedConfig {+    savedGlobalFlags       :: GlobalFlags,+    savedInstallFlags      :: InstallFlags,+    savedConfigureFlags    :: ConfigFlags,+    savedConfigureExFlags  :: ConfigExFlags,+    savedUserInstallDirs   :: InstallDirs (Flag PathTemplate),+    savedGlobalInstallDirs :: InstallDirs (Flag PathTemplate),+    savedUploadFlags       :: UploadFlags,+    savedReportFlags       :: ReportFlags+  }++instance Monoid SavedConfig where+  mempty = SavedConfig {+    savedGlobalFlags       = mempty,+    savedInstallFlags      = mempty,+    savedConfigureFlags    = mempty,+    savedConfigureExFlags  = mempty,+    savedUserInstallDirs   = mempty,+    savedGlobalInstallDirs = mempty,+    savedUploadFlags       = mempty,+    savedReportFlags       = mempty+  }+  mappend a b = SavedConfig {+    savedGlobalFlags       = combine savedGlobalFlags,+    savedInstallFlags      = combine savedInstallFlags,+    savedConfigureFlags    = combine savedConfigureFlags,+    savedConfigureExFlags  = combine savedConfigureExFlags,+    savedUserInstallDirs   = combine savedUserInstallDirs,+    savedGlobalInstallDirs = combine savedGlobalInstallDirs,+    savedUploadFlags       = combine savedUploadFlags,+    savedReportFlags       = combine savedReportFlags+  }+    where combine field = field a `mappend` field b++updateInstallDirs :: Flag Bool -> SavedConfig -> SavedConfig+updateInstallDirs userInstallFlag+  savedConfig@SavedConfig {+    savedConfigureFlags    = configureFlags,+    savedUserInstallDirs   = userInstallDirs,+    savedGlobalInstallDirs = globalInstallDirs+  } =+  savedConfig {+    savedConfigureFlags = configureFlags {+      configInstallDirs = installDirs+    }+  }+  where+    installDirs | userInstall = userInstallDirs+                | otherwise   = globalInstallDirs+    userInstall = fromFlagOrDefault defaultUserInstall $+                    configUserInstall configureFlags `mappend` userInstallFlag++--+-- * Default config+--++-- | These are the absolute basic defaults. The fields that must be+-- initialised. When we load the config from the file we layer the loaded+-- values over these ones, so any missing fields in the file take their values+-- from here.+--+baseSavedConfig :: IO SavedConfig+baseSavedConfig = do+  userPrefix <- defaultCabalDir+  logsDir    <- defaultLogsDir+  worldFile  <- defaultWorldFile+  return mempty {+    savedConfigureFlags  = mempty {+      configHcFlavor     = toFlag defaultCompiler,+      configUserInstall  = toFlag defaultUserInstall,+      configVerbosity    = toFlag normal+    },+    savedUserInstallDirs = mempty {+      prefix             = toFlag (toPathTemplate userPrefix)+    },+    savedGlobalFlags = mempty {+      globalLogsDir      = toFlag logsDir,+      globalWorldFile    = toFlag worldFile+    }+  }++-- | This is the initial configuration that we write out to to the config file+-- if the file does not exist (or the config we use if the file cannot be read+-- for some other reason). When the config gets loaded it gets layered on top+-- of 'baseSavedConfig' so we do not need to include it into the initial+-- values we save into the config file.+--+initialSavedConfig :: IO SavedConfig+initialSavedConfig = do+  cacheDir   <- defaultCacheDir+  logsDir    <- defaultLogsDir+  worldFile  <- defaultWorldFile+  return mempty {+    savedGlobalFlags     = mempty {+      globalCacheDir     = toFlag cacheDir,+      globalRemoteRepos  = [defaultRemoteRepo],+      globalWorldFile    = toFlag worldFile+    },+    savedInstallFlags    = mempty {+      installSummaryFile = [toPathTemplate (logsDir </> "build.log")],+      installBuildReports= toFlag AnonymousReports+    }+  }++--TODO: misleading, there's no way to override this default+--      either make it possible or rename to simply getCabalDir.+defaultCabalDir :: IO FilePath+defaultCabalDir = getAppUserDataDirectory "cabal"++defaultConfigFile :: IO FilePath+defaultConfigFile = do+  dir <- defaultCabalDir+  return $ dir </> "config"++defaultCacheDir :: IO FilePath+defaultCacheDir = do+  dir <- defaultCabalDir+  return $ dir </> "packages"++defaultLogsDir :: IO FilePath+defaultLogsDir = do+  dir <- defaultCabalDir+  return $ dir </> "logs"++-- | Default position of the world file+defaultWorldFile :: IO FilePath+defaultWorldFile = do+  dir <- defaultCabalDir+  return $ dir </> "world"++defaultCompiler :: CompilerFlavor+defaultCompiler = fromMaybe GHC defaultCompilerFlavor++defaultUserInstall :: Bool+defaultUserInstall = True+-- We do per-user installs by default on all platforms. We used to default to+-- global installs on Windows but that no longer works on Windows Vista or 7.++defaultRemoteRepo :: RemoteRepo+defaultRemoteRepo = RemoteRepo name uri+  where+    name = "hackage.haskell.org"+    uri  = URI "http:" (Just (URIAuth "" name "")) "/packages/archive" "" ""++--+-- * Config file reading+--++loadConfig :: Verbosity -> Flag FilePath -> Flag Bool -> IO SavedConfig+loadConfig verbosity configFileFlag userInstallFlag = addBaseConf $ do+  let sources = [+        ("commandline option",   return . flagToMaybe $ configFileFlag),+        ("env var CABAL_CONFIG", lookup "CABAL_CONFIG" `liftM` getEnvironment),+        ("default config file",  Just `liftM` defaultConfigFile) ]++      getSource [] = error "no config file path candidate found."+      getSource ((msg,action): xs) = +                        action >>= maybe (getSource xs) (return . (,) msg)++  (source, configFile) <- getSource sources+  minp <- readConfigFile mempty configFile+  case minp of+    Nothing -> do+      notice verbosity $ "Config file path source is " ++ source ++ "."+      notice verbosity $ "Config file " ++ configFile ++ " not found."+      notice verbosity $ "Writing default configuration to " ++ configFile+      commentConf <- commentSavedConfig+      initialConf <- initialSavedConfig+      writeConfigFile configFile commentConf initialConf+      return initialConf+    Just (ParseOk ws conf) -> do+      when (not $ null ws) $ warn verbosity $+        unlines (map (showPWarning configFile) ws)+      return conf+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      warn verbosity $+          "Error parsing config file " ++ configFile+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg+      warn verbosity $ "Using default configuration."+      initialSavedConfig++  where+    addBaseConf body = do+      base  <- baseSavedConfig+      extra <- body+      return (updateInstallDirs userInstallFlag (base `mappend` extra))++readConfigFile :: SavedConfig -> FilePath -> IO (Maybe (ParseResult SavedConfig))+readConfigFile initial file = handleNotExists $+  fmap (Just . parseConfig initial) (readFile file)++  where+    handleNotExists action = catch action $ \ioe ->+      if isDoesNotExistError ioe+        then return Nothing+        else ioError ioe++writeConfigFile :: FilePath -> SavedConfig -> SavedConfig -> IO ()+writeConfigFile file comments vals = do+  createDirectoryIfMissing True (takeDirectory file)+  writeFile file $ explanation ++ showConfigWithComments comments vals ++ "\n"+  where+    explanation = unlines+      ["-- This is the configuration file for the 'cabal' command line tool."+      ,""+      ,"-- The available configuration options are listed below."+      ,"-- Some of them have default values listed."+      ,""+      ,"-- Lines (like this one) beginning with '--' are comments."+      ,"-- Be careful with spaces and indentation because they are"+      ,"-- used to indicate layout for nested sections."+      ,"",""+      ]++-- | These are the default values that get used in Cabal if a no value is+-- given. We use these here to include in comments when we write out the+-- initial config file so that the user can see what default value they are+-- overriding.+--+commentSavedConfig :: IO SavedConfig+commentSavedConfig = do+  userInstallDirs   <- defaultInstallDirs defaultCompiler True True+  globalInstallDirs <- defaultInstallDirs defaultCompiler False True+  return SavedConfig {+    savedGlobalFlags       = commandDefaultFlags globalCommand,+    savedInstallFlags      = defaultInstallFlags,+    savedConfigureExFlags  = defaultConfigExFlags,+    savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {+      configUserInstall    = toFlag defaultUserInstall+    },+    savedUserInstallDirs   = fmap toFlag userInstallDirs,+    savedGlobalInstallDirs = fmap toFlag globalInstallDirs,+    savedUploadFlags       = commandDefaultFlags uploadCommand,+    savedReportFlags       = commandDefaultFlags reportCommand+  }++-- | All config file fields.+--+configFieldDescriptions :: [FieldDescr SavedConfig]+configFieldDescriptions =++     toSavedConfig liftGlobalFlag+       (commandOptions globalCommand ParseArgs)+       ["version", "numeric-version", "config-file"] []++  ++ toSavedConfig liftConfigFlag+       (configureOptions ParseArgs)+       (["builddir", "configure-option"] ++ map fieldName installDirsFields)++        --FIXME: this is only here because viewAsFieldDescr gives us a parser+        -- that only recognises 'ghc' etc, the case-sensitive flag names, not+        -- what the normal case-insensitive parser gives us.+       [simpleField "compiler"+          (fromFlagOrDefault Disp.empty . fmap Text.disp) (optional Text.parse)+          configHcFlavor (\v flags -> flags { configHcFlavor = v })+       ]++  ++ toSavedConfig liftConfigExFlag+       (configureExOptions ParseArgs)+       [] []++  ++ toSavedConfig liftInstallFlag+       (installOptions ParseArgs)+       ["dry-run", "reinstall", "only"] []++  ++ toSavedConfig liftUploadFlag+       (commandOptions uploadCommand ParseArgs)+       ["verbose", "check"] []++  ++ toSavedConfig liftReportFlag+       (commandOptions reportCommand ParseArgs)+       ["verbose", "username", "password"] []+       --FIXME: this is a hack, hiding the username and password.+       -- But otherwise it masks the upload ones. Either need to+       -- share the options or make then distinct. In any case+       -- they should probably be per-server.++  where+    toSavedConfig lift options exclusions replacements =+      [ lift (fromMaybe field replacement)+      | opt <- options+      , let field       = viewAsFieldDescr opt+            name        = fieldName field+            replacement = find ((== name) . fieldName) replacements+      , name `notElem` exclusions ]+    optional = Parse.option mempty . fmap toFlag++-- TODO: next step, make the deprecated fields elicit a warning.+--+deprecatedFieldDescriptions :: [FieldDescr SavedConfig]+deprecatedFieldDescriptions =+  [ liftGlobalFlag $+    listField "repos"+      (Disp.text . showRepo) parseRepo+      globalRemoteRepos (\rs cfg -> cfg { globalRemoteRepos = rs })+  , liftGlobalFlag $+    simpleField "cachedir"+      (Disp.text . fromFlagOrDefault "") (optional parseFilePathQ)+      globalCacheDir    (\d cfg -> cfg { globalCacheDir = d })+  , liftUploadFlag $+    simpleField "hackage-username"+      (Disp.text . fromFlagOrDefault "" . fmap unUsername)+      (optional (fmap Username parseTokenQ))+      uploadUsername    (\d cfg -> cfg { uploadUsername = d })+  , liftUploadFlag $+    simpleField "hackage-password"+      (Disp.text . fromFlagOrDefault "" . fmap unPassword)+      (optional (fmap Password parseTokenQ))+      uploadPassword    (\d cfg -> cfg { uploadPassword = d })+  ]+ ++ map (modifyFieldName ("user-"++)   . liftUserInstallDirs)   installDirsFields+ ++ map (modifyFieldName ("global-"++) . liftGlobalInstallDirs) installDirsFields+  where+    optional = Parse.option mempty . fmap toFlag+    modifyFieldName :: (String -> String) -> FieldDescr a -> FieldDescr a+    modifyFieldName f d = d { fieldName = f (fieldName d) }++liftUserInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                    -> FieldDescr SavedConfig+liftUserInstallDirs = liftField+  savedUserInstallDirs (\flags conf -> conf { savedUserInstallDirs = flags })++liftGlobalInstallDirs :: FieldDescr (InstallDirs (Flag PathTemplate))+                      -> FieldDescr SavedConfig+liftGlobalInstallDirs = liftField+  savedGlobalInstallDirs (\flags conf -> conf { savedGlobalInstallDirs = flags })++liftGlobalFlag :: FieldDescr GlobalFlags -> FieldDescr SavedConfig+liftGlobalFlag = liftField+  savedGlobalFlags (\flags conf -> conf { savedGlobalFlags = flags })++liftConfigFlag :: FieldDescr ConfigFlags -> FieldDescr SavedConfig+liftConfigFlag = liftField+  savedConfigureFlags (\flags conf -> conf { savedConfigureFlags = flags })++liftConfigExFlag :: FieldDescr ConfigExFlags -> FieldDescr SavedConfig+liftConfigExFlag = liftField+  savedConfigureExFlags (\flags conf -> conf { savedConfigureExFlags = flags })++liftInstallFlag :: FieldDescr InstallFlags -> FieldDescr SavedConfig+liftInstallFlag = liftField+  savedInstallFlags (\flags conf -> conf { savedInstallFlags = flags })++liftUploadFlag :: FieldDescr UploadFlags -> FieldDescr SavedConfig+liftUploadFlag = liftField+  savedUploadFlags (\flags conf -> conf { savedUploadFlags = flags })++liftReportFlag :: FieldDescr ReportFlags -> FieldDescr SavedConfig+liftReportFlag = liftField+  savedReportFlags (\flags conf -> conf { savedReportFlags = flags })++parseConfig :: SavedConfig -> String -> ParseResult SavedConfig+parseConfig initial = \str -> do+  fields <- readFields str+  let (knownSections, others) = partition isKnownSection fields+  config <- parse others+  let user0   = savedUserInstallDirs config+      global0 = savedGlobalInstallDirs config+  (user, global) <- foldM parseSections (user0, global0) knownSections+  return config {+    savedUserInstallDirs   = user,+    savedGlobalInstallDirs = global+  }++  where+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True+    isKnownSection _                                          = False++    parse = parseFields (configFieldDescriptions+                      ++ deprecatedFieldDescriptions) initial++    parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs)+      | name' == "user"   = do u' <- parseFields installDirsFields u fs+                               return (u', g)+      | name' == "global" = do g' <- parseFields installDirsFields g fs+                               return (u, g')+      | otherwise         = do+          warning "The install-paths section should be for 'user' or 'global'"+          return accum+      where name' = lowercase name+    parseSections accum f = do+      warning $ "Unrecognized stanza on line " ++ show (lineNo f)+      return accum++showConfig :: SavedConfig -> String+showConfig = showConfigWithComments mempty++showConfigWithComments :: SavedConfig -> SavedConfig -> String+showConfigWithComments comment vals = Disp.render $+      ppFields configFieldDescriptions comment vals+  $+$ Disp.text ""+  $+$ installDirsSection "user"   savedUserInstallDirs+  $+$ Disp.text ""+  $+$ installDirsSection "global" savedGlobalInstallDirs+  where+    installDirsSection name field =+      ppSection "install-dirs" name installDirsFields+                (field comment) (field vals)++------------------------+-- * Parsing utils+--++--FIXME: replace this with something better in Cabal-1.5+parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a+parseFields fields initial = foldM setField initial+  where+    fieldMap = Map.fromList+      [ (name, f) | f@(FieldDescr name _ _) <- fields ]+    setField accum (ParseUtils.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++-- | This is a customised version of the function from Cabal that also prints+-- default values for empty fields as comments.+--+ppFields :: [FieldDescr a] -> a -> a -> Disp.Doc+ppFields fields def cur = Disp.vcat [ ppField name (getter def) (getter cur)+                                    | FieldDescr name getter _ <- fields]++ppField :: String -> Disp.Doc -> Disp.Doc -> Disp.Doc+ppField name def cur+  | Disp.isEmpty cur = Disp.text "--" <+> Disp.text name <> Disp.colon <+> def+  | otherwise        =                    Disp.text name <> Disp.colon <+> cur++ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc+ppSection name arg fields def cur =+     Disp.text name <+> Disp.text arg+  $$ Disp.nest 2 (ppFields fields def cur)++installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))]+installDirsFields = map viewAsFieldDescr installDirsOptions+
+ cabal/cabal-install/Distribution/Client/Configure.hs view
@@ -0,0 +1,194 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Configure+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Duncan Coutts 2005+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- High level interface to configuring a package.+-----------------------------------------------------------------------------+module Distribution.Client.Configure (+    configure,+  ) where++import Distribution.Client.Dependency+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.Setup+         ( ConfigExFlags(..), configureCommand, filterConfigureFlags )+import Distribution.Client.Types as Source+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Targets+         ( userToPackageConstraint )++import Distribution.Simple.Compiler+         ( CompilerId(..), Compiler(compilerId)+         , PackageDB(..), PackageDBStack )+import Distribution.Simple.Program (ProgramConfiguration )+import Distribution.Simple.Setup+         ( ConfigFlags(..), toFlag, flagToMaybe, fromFlagOrDefault )+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Simple.Utils+         ( defaultPackageDesc )+import Distribution.Package+         ( Package(..), packageName, Dependency(..), thisPackageVersion )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Version+         ( anyVersion, thisVersion )+import Distribution.Simple.Utils as Utils+         ( notice, info, debug, die )+import Distribution.System+         ( Platform, buildPlatform )+import Distribution.Verbosity as Verbosity+         ( Verbosity )++import Data.Monoid (Monoid(..))++-- | Configure the package found in the local directory+configure :: Verbosity+          -> PackageDBStack+          -> [Repo]+          -> Compiler+          -> ProgramConfiguration+          -> ConfigFlags+          -> ConfigExFlags+          -> [String]+          -> IO ()+configure verbosity packageDBs repos comp conf+  configFlags configExFlags extraArgs = do++  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  sourcePkgDb       <- getSourcePackages    verbosity repos++  progress <- planLocalPackage verbosity comp configFlags configExFlags+                               installedPkgIndex sourcePkgDb++  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress logMsg (return . Left) (return . Right)+                            progress+  case maybePlan of+    Left message -> do+      info verbosity message+      setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing+        configureCommand (const configFlags) extraArgs++    Right installPlan -> case InstallPlan.ready installPlan of+      [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _)] ->+        configurePackage verbosity+          (InstallPlan.planPlatform installPlan)+          (InstallPlan.planCompiler installPlan)+          (setupScriptOptions installedPkgIndex)+          configFlags pkg extraArgs++      _ -> die $ "internal error: configure install plan should have exactly "+              ++ "one local ready package."++  where+    setupScriptOptions index = SetupScriptOptions {+      useCabalVersion  = maybe anyVersion thisVersion+                         (flagToMaybe (configCabalVersion configExFlags)),+      useCompiler      = Just comp,+      -- Hack: we typically want to allow the UserPackageDB for finding the+      -- Cabal lib when compiling any Setup.hs even if we're doing a global+      -- install. However we also allow looking in a specific package db.+      usePackageDB     = if UserPackageDB `elem` packageDBs+                           then packageDBs+                           else packageDBs ++ [UserPackageDB],+      usePackageIndex  = if UserPackageDB `elem` packageDBs+                           then Just index+                           else Nothing,+      useProgramConfig = conf,+      useDistPref      = fromFlagOrDefault+                           (useDistPref defaultSetupScriptOptions)+                           (configDistPref configFlags),+      useLoggingHandle = Nothing,+      useWorkingDir    = Nothing+    }++    logMsg message rest = debug verbosity message >> rest++-- | Make an 'InstallPlan' for the unpacked package in the current directory,+-- and all its dependencies.+--+planLocalPackage :: Verbosity -> Compiler+                 -> ConfigFlags -> ConfigExFlags+                 -> PackageIndex InstalledPackage+                 -> SourcePackageDb+                 -> IO (Progress String String InstallPlan)+planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex+  (SourcePackageDb _ packagePrefs) = do+  pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity++  let -- We create a local package and ask to resolve a dependency on it+      localPkg = SourcePackage {+        packageInfoId             = packageId pkg,+        Source.packageDescription = pkg,+        packageSource             = LocalUnpackedPackage "."+      }++      resolverParams =++          addPreferences+            -- preferences from the config file or command line+            [ PackageVersionPreference name ver+            | Dependency name ver <- configPreferences configExFlags ]++        . addConstraints+            -- version constraints from the config file or command line+            -- TODO: should warn or error on constraints that are not on direct deps+            -- or flag constraints not on the package in question.+            (map userToPackageConstraint (configExConstraints configExFlags))++        . addConstraints+            -- package flags from the config file or command line+            [ PackageConstraintFlags (packageName pkg)+                                     (configConfigurationsFlags configFlags) ]++        $ standardInstallPolicy+            installedPkgIndex+            (SourcePackageDb mempty packagePrefs)+            [SpecificSourcePackage localPkg]++  return (resolveDependencies buildPlatform (compilerId comp) resolverParams)+++-- | Call an installer for an 'SourcePackage' but override the configure+-- flags with the ones given by the 'ConfiguredPackage'. In particular the+-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- versioned package dependencies. So we ignore any previous partial flag+-- assignment or dependency constraints and use the new ones.+--+configurePackage :: Verbosity+                 -> Platform -> CompilerId+                 -> SetupScriptOptions+                 -> ConfigFlags+                 -> ConfiguredPackage+                 -> [String]+                 -> IO ()+configurePackage verbosity platform comp scriptOptions configFlags+  (ConfiguredPackage (SourcePackage _ gpkg _) flags deps) extraArgs =++  setupWrapper verbosity+    scriptOptions (Just pkg) configureCommand configureFlags extraArgs++  where+    configureFlags   = filterConfigureFlags configFlags {+      configConfigurationsFlags = flags,+      configConstraints         = map thisPackageVersion deps,+      configVerbosity           = toFlag verbosity+    }++    pkg = case finalizePackageDescription flags+           (const True)+           platform comp [] gpkg of+      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Right (desc, _) -> desc
+ cabal/cabal-install/Distribution/Client/Dependency.hs view
@@ -0,0 +1,449 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007+--                    Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Top level interface to dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency (+    -- * The main package dependency resolver+    resolveDependencies,+    Progress(..),+    foldProgress,++    -- * Alternate, simple resolver that does not do dependencies recursively+    resolveWithoutDependencies,++    -- * Constructing resolver policies+    DepResolverParams(..),+    PackageConstraint(..),+    PackagesPreferenceDefault(..),+    PackagePreference(..),+    InstalledPreference(..),++    -- ** Standard policy+    standardInstallPolicy,+    PackageSpecifier(..),++    -- ** Extra policy options+    dontUpgradeBasePackage,+    hideBrokenInstalledPackages,+    upgradeDependencies,+    reinstallTargets,++    -- ** Policy utils+    addConstraints,+    addPreferences,+    setPreferenceDefault,+    addSourcePackages,+    hideInstalledPackagesSpecific,+    hideInstalledPackagesAllVersions,+  ) where++import Distribution.Client.Dependency.TopDown (topDownResolver)+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Types+         ( SourcePackageDb(SourcePackageDb)+         , SourcePackage(..), InstalledPackage )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, PackageConstraint(..)+         , PackagePreferences(..), InstalledPreference(..)+         , Progress(..), foldProgress )+import Distribution.Client.Targets+import Distribution.Package+         ( PackageName(..), PackageId, Package(..), packageVersion+         , Dependency(Dependency))+import Distribution.Version+         ( VersionRange, anyVersion, withinRange, simplifyVersionRange )+import Distribution.Compiler+         ( CompilerId(..) )+import Distribution.System+         ( Platform )+import Distribution.Simple.Utils (comparing)+import Distribution.Text+         ( display )++import Data.List (maximumBy, foldl')+import Data.Maybe (fromMaybe, isJust)+import qualified Data.Map as Map+import qualified Data.Set as Set+import Data.Set (Set)+++-- ------------------------------------------------------------+-- * High level planner policy+-- ------------------------------------------------------------++-- | The set of parameters to the dependency resolver. These parameters are+-- relatively low level but many kinds of high level policies can be+-- implemented in terms of adjustments to the parameters.+--+data DepResolverParams = DepResolverParams {+       depResolverTargets           :: [PackageName],+       depResolverConstraints       :: [PackageConstraint],+       depResolverPreferences       :: [PackagePreference],+       depResolverPreferenceDefault :: PackagesPreferenceDefault,+       depResolverInstalledPkgIndex :: PackageIndex InstalledPackage,+       depResolverSourcePkgIndex    :: PackageIndex SourcePackage+     }+++-- | Global policy for all packages to say if we prefer package versions that+-- are already installed locally or if we just prefer the latest available.+--+data PackagesPreferenceDefault =++     -- | Always prefer the latest version irrespective of any existing+     -- installed version.+     --+     -- * This is the standard policy for upgrade.+     --+     PreferAllLatest++     -- | Always prefer the installed versions over ones that would need to be+     -- installed. Secondarily, prefer latest versions (eg the latest installed+     -- version or if there are none then the latest source version).+   | PreferAllInstalled++     -- | Prefer the latest version for packages that are explicitly requested+     -- but prefers the installed version for any other packages.+     --+     -- * This is the standard policy for install.+     --+   | PreferLatestForSelected+++-- | A package selection preference for a particular package.+--+-- Preferences are soft constraints that the dependency resolver should try to+-- respect where possible. It is not specified if preferences on some packages+-- are more important than others.+--+data PackagePreference =++     -- | A suggested constraint on the version number.+     PackageVersionPreference   PackageName VersionRange++     -- | If we prefer versions of packages that are already installed.+   | PackageInstalledPreference PackageName InstalledPreference++basicDepResolverParams :: PackageIndex InstalledPackage+                       -> PackageIndex SourcePackage+                       -> DepResolverParams+basicDepResolverParams installedPkgIndex sourcePkgIndex =+    DepResolverParams {+       depResolverTargets           = [],+       depResolverConstraints       = [],+       depResolverPreferences       = [],+       depResolverPreferenceDefault = PreferLatestForSelected,+       depResolverInstalledPkgIndex = installedPkgIndex,+       depResolverSourcePkgIndex    = sourcePkgIndex+     }++addTargets :: [PackageName]+           -> DepResolverParams -> DepResolverParams+addTargets extraTargets params =+    params {+      depResolverTargets = extraTargets ++ depResolverTargets params+    }++addConstraints :: [PackageConstraint]+               -> DepResolverParams -> DepResolverParams+addConstraints extraConstraints params =+    params {+      depResolverConstraints = extraConstraints+                            ++ depResolverConstraints params+    }++addPreferences :: [PackagePreference]+               -> DepResolverParams -> DepResolverParams+addPreferences extraPreferences params =+    params {+      depResolverPreferences = extraPreferences+                            ++ depResolverPreferences params+    }++setPreferenceDefault :: PackagesPreferenceDefault+                     -> DepResolverParams -> DepResolverParams+setPreferenceDefault preferenceDefault params =+    params {+      depResolverPreferenceDefault = preferenceDefault+    }++dontUpgradeBasePackage :: DepResolverParams -> DepResolverParams+dontUpgradeBasePackage params =+    addConstraints extraConstraints params+  where+    extraConstraints =+      [ PackageConstraintInstalled pkgname+      | all (/=PackageName "base") (depResolverTargets params)+      , pkgname <-  [ PackageName "base", PackageName "ghc-prim" ]+      , isInstalled pkgname ]+    -- TODO: the top down resolver chokes on the base constraints+    -- below when there are no targets and thus no dep on base.+    -- Need to refactor contraints separate from needing packages.+    isInstalled = not . null+                . PackageIndex.lookupPackageName+                                 (depResolverInstalledPkgIndex params)++addSourcePackages :: [SourcePackage]+                  -> DepResolverParams -> DepResolverParams+addSourcePackages pkgs params =+    params {+      depResolverSourcePkgIndex =+        foldl (flip PackageIndex.insert)+              (depResolverSourcePkgIndex params) pkgs+    }++hideInstalledPackagesSpecific :: [PackageId]+                              -> DepResolverParams -> DepResolverParams+hideInstalledPackagesSpecific pkgids params =+    --TODO: this should work using exclude constraints instead+    params {+      depResolverInstalledPkgIndex =+        foldl' (flip PackageIndex.deletePackageId)+               (depResolverInstalledPkgIndex params) pkgids+    }++hideInstalledPackagesAllVersions :: [PackageName]+                                 -> DepResolverParams -> DepResolverParams+hideInstalledPackagesAllVersions pkgnames params =+    --TODO: this should work using exclude constraints instead+    params {+      depResolverInstalledPkgIndex =+        foldl' (flip PackageIndex.deletePackageName)+               (depResolverInstalledPkgIndex params) pkgnames+    }+++hideBrokenInstalledPackages :: DepResolverParams -> DepResolverParams+hideBrokenInstalledPackages params =+    hideInstalledPackagesSpecific pkgids params+  where+    pkgids = map packageId+           . PackageIndex.reverseDependencyClosure+                            (depResolverInstalledPkgIndex params)+           . map (packageId . fst)+           . PackageIndex.brokenPackages+           $ depResolverInstalledPkgIndex params+++upgradeDependencies :: DepResolverParams -> DepResolverParams+upgradeDependencies = setPreferenceDefault PreferAllLatest+++reinstallTargets :: DepResolverParams -> DepResolverParams+reinstallTargets params =+    hideInstalledPackagesAllVersions (depResolverTargets params) params+++standardInstallPolicy :: PackageIndex InstalledPackage+                      -> SourcePackageDb+                      -> [PackageSpecifier SourcePackage]+                      -> DepResolverParams+standardInstallPolicy+    installedPkgIndex (SourcePackageDb sourcePkgIndex sourcePkgPrefs)+    pkgSpecifiers++  = addPreferences+      [ PackageVersionPreference name ver+      | (name, ver) <- Map.toList sourcePkgPrefs ]++  . addConstraints+      (concatMap pkgSpecifierConstraints pkgSpecifiers)++  . addTargets+      (map pkgSpecifierTarget pkgSpecifiers)++  . hideInstalledPackagesSpecific+      [ packageId pkg | SpecificSourcePackage pkg <- pkgSpecifiers ]++  . addSourcePackages+      [ pkg  | SpecificSourcePackage pkg <- pkgSpecifiers ]++  $ basicDepResolverParams+      installedPkgIndex sourcePkgIndex+++-- ------------------------------------------------------------+-- * Interface to the standard resolver+-- ------------------------------------------------------------++defaultResolver :: DependencyResolver+defaultResolver = topDownResolver++-- | Run the dependency solver.+--+-- Since this is potentially an expensive operation, the result is wrapped in a+-- a 'Progress' structure that can be unfolded to provide progress information,+-- logging messages and the final result or an error.+--+resolveDependencies :: Platform+                    -> CompilerId+                    -> DepResolverParams+                    -> Progress String String InstallPlan++    --TODO: is this needed here? see dontUpgradeBasePackage+resolveDependencies platform comp params+  | null (depResolverTargets params)+  = return (mkInstallPlan platform comp [])++resolveDependencies platform comp params =++    fmap (mkInstallPlan platform comp)+  $ defaultResolver platform comp installedPkgIndex sourcePkgIndex+                    preferences constraints targets+  where+    DepResolverParams+      targets constraints+      prefs defpref+      installedPkgIndex+      sourcePkgIndex = dontUpgradeBasePackage+                     . hideBrokenInstalledPackages+                     $ params++    preferences = interpretPackagesPreference+                    (Set.fromList targets) defpref prefs+++-- | Make an install plan from the output of the dep resolver.+-- It checks that the plan is valid, or it's an error in the dep resolver.+--+mkInstallPlan :: Platform+              -> CompilerId+              -> [InstallPlan.PlanPackage] -> InstallPlan+mkInstallPlan platform comp pkgIndex =+  case InstallPlan.new platform comp (PackageIndex.fromList pkgIndex) of+    Right plan     -> plan+    Left  problems -> error $ unlines $+        "internal error: could not construct a valid install plan."+      : "The proposed (invalid) plan contained the following problems:"+      : map InstallPlan.showPlanProblem problems+++-- | Give an interpretation to the global 'PackagesPreference' as+--  specific per-package 'PackageVersionPreference'.+--+interpretPackagesPreference :: Set PackageName+                            -> PackagesPreferenceDefault+                            -> [PackagePreference]+                            -> (PackageName -> PackagePreferences)+interpretPackagesPreference selected defaultPref prefs =+  \pkgname -> PackagePreferences (versionPref pkgname) (installPref pkgname)++  where+    versionPref pkgname =+      fromMaybe anyVersion (Map.lookup pkgname versionPrefs)+    versionPrefs = Map.fromList+      [ (pkgname, pref)+      | PackageVersionPreference pkgname pref <- prefs ]++    installPref pkgname =+      fromMaybe (installPrefDefault pkgname) (Map.lookup pkgname installPrefs)+    installPrefs = Map.fromList+      [ (pkgname, pref)+      | PackageInstalledPreference pkgname pref <- prefs ]+    installPrefDefault = case defaultPref of+      PreferAllLatest         -> \_       -> PreferLatest+      PreferAllInstalled      -> \_       -> PreferInstalled+      PreferLatestForSelected -> \pkgname ->+        -- When you say cabal install foo, what you really mean is, prefer the+        -- latest version of foo, but the installed version of everything else+        if pkgname `Set.member` selected then PreferLatest+                                         else PreferInstalled++-- ------------------------------------------------------------+-- * Simple resolver that ignores dependencies+-- ------------------------------------------------------------++-- | A simplistic method of resolving a list of target package names to+-- available packages.+--+-- Specifically, it does not consider package dependencies at all. Unlike+-- 'resolveDependencies', no attempt is made to ensure that the selected+-- packages have dependencies that are satisfiable or consistent with+-- each other.+--+-- It is suitable for tasks such as selecting packages to download for user+-- inspection. It is not suitable for selecting packages to install.+--+-- Note: if no installed package index is available, it is ok to pass 'mempty'.+-- It simply means preferences for installed packages will be ignored.+--+resolveWithoutDependencies :: DepResolverParams+                           -> Either [ResolveNoDepsError] [SourcePackage]+resolveWithoutDependencies (DepResolverParams targets constraints+                              prefs defpref installedPkgIndex sourcePkgIndex) =+    collectEithers (map selectPackage targets)+  where+    selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage+    selectPackage pkgname+      | null choices = Left  $! ResolveUnsatisfiable pkgname requiredVersions+      | otherwise    = Right $! maximumBy bestByPrefs choices++      where+        -- Constraints+        requiredVersions = packageConstraints pkgname+        pkgDependency    = Dependency pkgname requiredVersions+        choices          = PackageIndex.lookupDependency sourcePkgIndex+                                                         pkgDependency++        -- Preferences+        PackagePreferences preferredVersions preferInstalled+          = packagePreferences pkgname++        bestByPrefs   = comparing $ \pkg ->+                          (installPref pkg, versionPref pkg, packageVersion pkg)+        installPref   = case preferInstalled of+          PreferLatest    -> const False+          PreferInstalled -> isJust . PackageIndex.lookupPackageId+                                                     installedPkgIndex+                           . packageId+        versionPref   pkg = packageVersion pkg `withinRange` preferredVersions++    packageConstraints :: PackageName -> VersionRange+    packageConstraints pkgname =+      Map.findWithDefault anyVersion pkgname packageVersionConstraintMap+    packageVersionConstraintMap =+      Map.fromList [ (name, range)+                   | PackageConstraintVersion name range <- constraints ]++    packagePreferences :: PackageName -> PackagePreferences+    packagePreferences = interpretPackagesPreference+                           (Set.fromList targets) defpref prefs+++collectEithers :: [Either a b] -> Either [a] [b]+collectEithers = collect . partitionEithers+  where+    collect ([], xs) = Right xs+    collect (errs,_) = Left errs+    partitionEithers :: [Either a b] -> ([a],[b])+    partitionEithers = foldr (either left right) ([],[])+     where+       left  a (l, r) = (a:l, r)+       right a (l, r) = (l, a:r)++-- | Errors for 'resolveWithoutDependencies'.+--+data ResolveNoDepsError =++     -- | A package name which cannot be resolved to a specific package.+     -- Also gives the constraint on the version and whether there was+     -- a constraint on the package being installed.+     ResolveUnsatisfiable PackageName VersionRange++instance Show ResolveNoDepsError where+  show (ResolveUnsatisfiable name ver) =+       "There is no available version of " ++ display name+    ++ " that satisfies " ++ display (simplifyVersionRange ver)
+ cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs view
@@ -0,0 +1,928 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Common types for dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown (+    topDownResolver+  ) where++import Distribution.Client.Dependency.TopDown.Types+import qualified Distribution.Client.Dependency.TopDown.Constraints as Constraints+import Distribution.Client.Dependency.TopDown.Constraints+         ( Satisfiable(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan+         ( PlanPackage(..) )+import Distribution.Client.Types+         ( SourcePackage(..), ConfiguredPackage(..), InstalledPackage(..) )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, PackageConstraint(..)+         , PackagePreferences(..), InstalledPreference(..)+         , Progress(..), foldProgress )++import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Package+         ( PackageName(..), PackageId, Package(..), packageVersion, packageName+         , Dependency(Dependency), thisPackageVersion+         , simplifyDependency, PackageFixedDeps(depends) )+import Distribution.PackageDescription+         ( PackageDescription(buildDepends) )+import Distribution.Client.PackageUtils+         ( externalBuildDepends )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription, flattenPackageDescription )+import Distribution.Version+         ( VersionRange, withinRange, simplifyVersionRange+         , UpperBound(..), asVersionIntervals )+import Distribution.Compiler+         ( CompilerId )+import Distribution.System+         ( Platform )+import Distribution.Simple.Utils+         ( equating, comparing )+import Distribution.Text+         ( display )++import Data.List+         ( foldl', maximumBy, minimumBy, nub, sort, sortBy, groupBy )+import Data.Maybe+         ( fromJust, fromMaybe, catMaybes )+import Data.Monoid+         ( Monoid(mempty) )+import Control.Monad+         ( guard )+import qualified Data.Set as Set+import Data.Set (Set)+import qualified Data.Map as Map+import qualified Data.Graph as Graph+import qualified Data.Array as Array+import Control.Exception+         ( assert )++-- ------------------------------------------------------------+-- * Search state types+-- ------------------------------------------------------------++type Constraints  = Constraints.Constraints+                      InstalledPackageEx UnconfiguredPackage ExclusionReason+type SelectedPackages = PackageIndex SelectedPackage++-- ------------------------------------------------------------+-- * The search tree type+-- ------------------------------------------------------------++data SearchSpace inherited pkg+   = ChoiceNode inherited [[(pkg, SearchSpace inherited pkg)]]+   | Failure Failure++-- ------------------------------------------------------------+-- * Traverse a search tree+-- ------------------------------------------------------------++explore :: (PackageName -> PackagePreferences)+        -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)+                       SelectablePackage+        -> Progress Log Failure (SelectedPackages, Constraints)++explore _    (Failure failure)       = Fail failure+explore _    (ChoiceNode (s,c,_) []) = Done (s,c)+explore pref (ChoiceNode _ choices)  =+  case [ choice | [choice] <- choices ] of+    ((_, node'):_) -> Step (logInfo node') (explore pref node')+    []             -> Step (logInfo node') (explore pref node')+      where+        choice     = minimumBy (comparing topSortNumber) choices+        pkgname    = packageName . fst . head $ choice+        (_, node') = maximumBy (bestByPref pkgname) choice+  where+    topSortNumber choice = case fst (head choice) of+      InstalledOnly        (InstalledPackageEx  _ i _) -> i+      SourceOnly           (UnconfiguredPackage _ i _) -> i+      InstalledAndSource _ (UnconfiguredPackage _ i _) -> i++    bestByPref pkgname = case packageInstalledPreference of+        PreferLatest    ->+          comparing (\(p,_) -> (               isPreferred p, packageId p))+        PreferInstalled ->+          comparing (\(p,_) -> (isInstalled p, isPreferred p, packageId p))+      where+        isInstalled (SourceOnly _) = False+        isInstalled _              = True+        isPreferred p = packageVersion p `withinRange` preferredVersions+        (PackagePreferences preferredVersions packageInstalledPreference)+          = pref pkgname++    logInfo node = Select selected discarded+      where (selected, discarded) = case node of+              Failure    _               -> ([], [])+              ChoiceNode (_,_,changes) _ -> changes++-- ------------------------------------------------------------+-- * Generate a search tree+-- ------------------------------------------------------------++type ConfigurePackage = PackageIndex SelectablePackage+                     -> SelectablePackage+                     -> Either [Dependency] SelectedPackage++-- | (packages selected, packages discarded)+type SelectionChanges = ([SelectedPackage], [PackageId])++searchSpace :: ConfigurePackage+            -> Constraints+            -> SelectedPackages+            -> SelectionChanges+            -> Set PackageName+            -> SearchSpace (SelectedPackages, Constraints, SelectionChanges)+                           SelectablePackage+searchSpace configure constraints selected changes next =+  assert (Set.null (selectedSet `Set.intersection` next)) $+  assert (selectedSet `Set.isSubsetOf` Constraints.packages constraints) $+  assert (next `Set.isSubsetOf` Constraints.packages constraints) $++  ChoiceNode (selected, constraints, changes)+    [ [ (pkg, select name pkg)+      | pkg <- PackageIndex.lookupPackageName available name ]+    | name <- Set.elems next ]+  where+    available = Constraints.choices constraints++    selectedSet = Set.fromList (map packageName (PackageIndex.allPackages selected))++    select name pkg = case configure available pkg of+      Left missing -> Failure $ ConfigureFailed pkg+                        [ (dep, Constraints.conflicting constraints dep)+                        | dep <- missing ]+      Right pkg' ->+        case constrainDeps pkg' newDeps (addDeps constraints newPkgs) [] of+          Left failure       -> Failure failure+          Right (constraints', newDiscarded) ->+            searchSpace configure+              constraints' selected' (newSelected, newDiscarded) next'+        where+          selected' = foldl' (flip PackageIndex.insert) selected newSelected+          newSelected =+            case Constraints.isPaired constraints (packageId pkg) of+              Nothing     -> [pkg']+              Just pkgid' -> [pkg', pkg'']+                where+                  Just pkg'' = fmap (\(InstalledOnly p) -> InstalledOnly p)+                    (PackageIndex.lookupPackageId available pkgid')++          newPkgs   = [ name'+                      | (Dependency name' _, _) <- newDeps+                      , null (PackageIndex.lookupPackageName selected' name') ]+          newDeps   = concatMap packageConstraints newSelected+          next'     = Set.delete name+                    $ foldl' (flip Set.insert) next newPkgs++packageConstraints :: SelectedPackage -> [(Dependency, Bool)]+packageConstraints = either installedConstraints availableConstraints+                   . preferSource+  where+    preferSource (InstalledOnly        pkg) = Left pkg+    preferSource (SourceOnly           pkg) = Right pkg+    preferSource (InstalledAndSource _ pkg) = Right pkg+    installedConstraints (InstalledPackageEx    _ _ deps) =+      [ (thisPackageVersion dep, True)+      | dep <- deps ]+    availableConstraints (SemiConfiguredPackage _ _ deps) =+      [ (dep, False) | dep <- deps ]++addDeps :: Constraints -> [PackageName] -> Constraints+addDeps =+  foldr $ \pkgname cs ->+            case Constraints.addTarget pkgname cs of+              Satisfiable cs' () -> cs'+              _                  -> impossible "addDeps unsatisfiable"++constrainDeps :: SelectedPackage -> [(Dependency, Bool)] -> Constraints+              -> [PackageId]+              -> Either Failure (Constraints, [PackageId])+constrainDeps pkg []         cs discard =+  case addPackageSelectConstraint (packageId pkg) cs of+    Satisfiable cs' discard' -> Right (cs', discard' ++ discard)+    _                        -> impossible "constrainDeps unsatisfiable(1)"+constrainDeps pkg ((dep, installedConstraint):deps) cs discard =+  case addPackageDependencyConstraint (packageId pkg) dep installedConstraint cs of+    Satisfiable cs' discard' -> constrainDeps pkg deps cs' (discard' ++ discard)+    Unsatisfiable            -> impossible "constrainDeps unsatisfiable(2)"+    ConflictsWith conflicts  ->+      Left (DependencyConflict pkg dep installedConstraint conflicts)++-- ------------------------------------------------------------+-- * The main algorithm+-- ------------------------------------------------------------++search :: ConfigurePackage+       -> (PackageName -> PackagePreferences)+       -> Constraints+       -> Set PackageName+       -> Progress Log Failure (SelectedPackages, Constraints)+search configure pref constraints =+  explore pref . searchSpace configure constraints mempty ([], [])++-- ------------------------------------------------------------+-- * The top level resolver+-- ------------------------------------------------------------++-- | The main exported resolver, with string logging and failure types to fit+-- the standard 'DependencyResolver' interface.+--+topDownResolver :: DependencyResolver+topDownResolver = ((((((mapMessages .).).).).).) . topDownResolver'+  where+    mapMessages :: Progress Log Failure a -> Progress String String a+    mapMessages = foldProgress (Step . showLog) (Fail . showFailure) Done++-- | The native resolver with detailed structured logging and failure types.+--+topDownResolver' :: Platform -> CompilerId+                 -> PackageIndex InstalledPackage+                 -> PackageIndex SourcePackage+                 -> (PackageName -> PackagePreferences)+                 -> [PackageConstraint]+                 -> [PackageName]+                 -> Progress Log Failure [PlanPackage]+topDownResolver' platform comp installedPkgIndex sourcePkgIndex+                 preferences constraints targets =+      fmap (uncurry finalise)+    . (\cs -> search configure preferences cs initialPkgNames)+  =<< pruneBottomUp platform comp+  =<< addTopLevelConstraints constraints+  =<< addTopLevelTargets targets emptyConstraintSet++  where+    configure   = configurePackage platform comp+    emptyConstraintSet :: Constraints+    emptyConstraintSet = Constraints.empty+      (annotateInstalledPackages          topSortNumber installedPkgIndex')+      (annotateSourcePackages constraints topSortNumber sourcePkgIndex')+    (installedPkgIndex', sourcePkgIndex') =+      selectNeededSubset installedPkgIndex sourcePkgIndex initialPkgNames+    topSortNumber = topologicalSortNumbering installedPkgIndex' sourcePkgIndex'++    initialPkgNames = Set.fromList targets++    finalise selected' constraints' =+        PackageIndex.allPackages+      . fst . improvePlan installedPkgIndex' constraints'+      . PackageIndex.fromList+      $ finaliseSelectedPackages preferences selected' constraints'+++addTopLevelTargets :: [PackageName]+                   -> Constraints+                   -> Progress a Failure Constraints+addTopLevelTargets []         cs = Done cs+addTopLevelTargets (pkg:pkgs) cs =+  case Constraints.addTarget pkg cs of+    Satisfiable cs' ()       -> addTopLevelTargets pkgs cs'+    Unsatisfiable            -> Fail (NoSuchPackage pkg)+    ConflictsWith _conflicts -> impossible "addTopLevelTargets conflicts"+++addTopLevelConstraints :: [PackageConstraint] -> Constraints+                       -> Progress Log Failure Constraints+addTopLevelConstraints []                                      cs = Done cs+addTopLevelConstraints (PackageConstraintFlags   _   _  :deps) cs =+  addTopLevelConstraints deps cs++addTopLevelConstraints (PackageConstraintVersion pkg ver:deps) cs =+  case addTopLevelVersionConstraint pkg ver cs of+    Satisfiable cs' pkgids  ->+      Step (AppliedVersionConstraint pkg ver pkgids)+           (addTopLevelConstraints deps cs')++    Unsatisfiable           ->+      Fail (TopLevelVersionConstraintUnsatisfiable pkg ver)++    ConflictsWith conflicts ->+      Fail (TopLevelVersionConstraintConflict pkg ver conflicts)++addTopLevelConstraints (PackageConstraintInstalled pkg:deps) cs =+  case addTopLevelInstalledConstraint pkg cs of+    Satisfiable cs' pkgids  ->+      Step (AppliedInstalledConstraint pkg InstalledConstraint pkgids)+           (addTopLevelConstraints deps cs')++    Unsatisfiable           ->+      Fail (TopLevelInstallConstraintUnsatisfiable pkg InstalledConstraint)++    ConflictsWith conflicts ->+      Fail (TopLevelInstallConstraintConflict pkg InstalledConstraint conflicts)++addTopLevelConstraints (PackageConstraintSource pkg:deps) cs =+  case addTopLevelSourceConstraint pkg cs of+    Satisfiable cs' pkgids  ->+      Step (AppliedInstalledConstraint pkg SourceConstraint pkgids)+            (addTopLevelConstraints deps cs')++    Unsatisfiable           ->+      Fail (TopLevelInstallConstraintUnsatisfiable pkg SourceConstraint)++    ConflictsWith conflicts ->+      Fail (TopLevelInstallConstraintConflict pkg SourceConstraint conflicts)++-- | Add exclusion on available packages that cannot be configured.+--+pruneBottomUp :: Platform -> CompilerId+              -> Constraints -> Progress Log Failure Constraints+pruneBottomUp platform comp constraints =+    foldr prune Done (initialPackages constraints) constraints++  where+    prune pkgs rest cs = foldr addExcludeConstraint rest unconfigurable cs+      where+        unconfigurable =+          [ (pkg, missing) -- if necessary we could look up missing reasons+          | (Just pkg', pkg) <- zip (map getSourcePkg pkgs) pkgs+          , Left missing <- [configure cs pkg'] ]++    addExcludeConstraint (pkg, missing) rest cs =+      let reason = ExcludedByConfigureFail missing in+      case addPackageExcludeConstraint (packageId pkg) reason cs of+        Satisfiable cs' [pkgid]| packageId pkg == pkgid+                         -> Step (ExcludeUnconfigurable pkgid) (rest cs')+        Satisfiable _ _  -> impossible "pruneBottomUp satisfiable"+        _                -> Fail $ ConfigureFailed pkg+                              [ (dep, Constraints.conflicting cs dep)+                              | dep <- missing ]++    configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags) =+      finalizePackageDescription flags (dependencySatisfiable cs)+                                 platform comp [] pkg+    dependencySatisfiable cs =+      not . null . PackageIndex.lookupDependency (Constraints.choices cs)++    -- collect each group of packages (by name) in reverse topsort order+    initialPackages =+        reverse+      . sortBy (comparing (topSortNumber . head))+      . PackageIndex.allPackagesByName+      . Constraints.choices++    topSortNumber (InstalledOnly        (InstalledPackageEx  _ i _)) = i+    topSortNumber (SourceOnly           (UnconfiguredPackage _ i _)) = i+    topSortNumber (InstalledAndSource _ (UnconfiguredPackage _ i _)) = i++    getSourcePkg (InstalledOnly      _     ) = Nothing+    getSourcePkg (SourceOnly           spkg) = Just spkg+    getSourcePkg (InstalledAndSource _ spkg) = Just spkg+++configurePackage :: Platform -> CompilerId -> ConfigurePackage+configurePackage platform comp available spkg = case spkg of+  InstalledOnly      ipkg      -> Right (InstalledOnly ipkg)+  SourceOnly              apkg -> fmap SourceOnly (configure apkg)+  InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)+                                       (configure apkg)+  where+  configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags) =+    case finalizePackageDescription flags dependencySatisfiable+                                    platform comp [] p of+      Left missing        -> Left missing+      Right (pkg, flags') -> Right $+        SemiConfiguredPackage apkg flags' (externalBuildDepends pkg)++  dependencySatisfiable = not . null . PackageIndex.lookupDependency available++-- | Annotate each installed packages with its set of transative dependencies+-- and its topological sort number.+--+annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)+                          -> PackageIndex InstalledPackage+                          -> PackageIndex InstalledPackageEx+annotateInstalledPackages dfsNumber installed = PackageIndex.fromList+  [ InstalledPackageEx pkg (dfsNumber (packageName pkg)) (transitiveDepends pkg)+  | pkg <- PackageIndex.allPackages installed ]+  where+    transitiveDepends :: InstalledPackage -> [PackageId]+    transitiveDepends = map (packageId . toPkg) . tail . Graph.reachable graph+                      . fromJust . toVertex . packageId+    (graph, toPkg, toVertex) = PackageIndex.dependencyGraph installed+++-- | Annotate each available packages with its topological sort number and any+-- user-supplied partial flag assignment.+--+annotateSourcePackages :: [PackageConstraint]+                       -> (PackageName -> TopologicalSortNumber)+                       -> PackageIndex SourcePackage+                       -> PackageIndex UnconfiguredPackage+annotateSourcePackages constraints dfsNumber sourcePkgIndex =+    PackageIndex.fromList+      [ UnconfiguredPackage pkg (dfsNumber name) (flagsFor name)+      | pkg <- PackageIndex.allPackages sourcePkgIndex+      , let name = packageName pkg ]+  where+    flagsFor = fromMaybe [] . flip Map.lookup flagsMap+    flagsMap = Map.fromList+      [ (name, flags)+      | PackageConstraintFlags name flags <- constraints ]++-- | One of the heuristics we use when guessing which path to take in the+-- search space is an ordering on the choices we make. It's generally better+-- to make decisions about packages higer in the dep graph first since they+-- place constraints on packages lower in the dep graph.+--+-- To pick them in that order we annotate each package with its topological+-- sort number. So if package A depends on package B then package A will have+-- a lower topological sort number than B and we'll make a choice about which+-- version of A to pick before we make a choice about B (unless there is only+-- one possible choice for B in which case we pick that immediately).+--+-- To construct these topological sort numbers we combine and flatten the+-- installed and source package sets. We consider only dependencies between+-- named packages, not including versions and for not-yet-configured packages+-- we look at all the possible dependencies, not just those under any single+-- flag assignment. This means we can actually get impossible combinations of+-- edges and even cycles, but that doesn't really matter here, it's only a+-- heuristic.+--+topologicalSortNumbering :: PackageIndex InstalledPackage+                         -> PackageIndex SourcePackage+                         -> (PackageName -> TopologicalSortNumber)+topologicalSortNumbering installedPkgIndex sourcePkgIndex =+    \pkgname -> let Just vertex = toVertex pkgname+                 in topologicalSortNumbers Array.! vertex+  where+    topologicalSortNumbers = Array.array (Array.bounds graph)+                                         (zip (Graph.topSort graph) [0..])+    (graph, _, toVertex)   = Graph.graphFromEdges $+         [ ((), packageName pkg, nub deps)+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName installedPkgIndex+         , let deps = [ packageName dep+                      | pkg' <- pkgs+                      , dep  <- depends pkg' ] ]+      ++ [ ((), packageName pkg, nub deps)+         | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex+         , let deps = [ depName+                      | SourcePackage _ pkg' _ <- pkgs+                      , Dependency depName _ <-+                          buildDepends (flattenPackageDescription pkg') ] ]++-- | We don't need the entire index (which is rather large and costly if we+-- force it by examining the whole thing). So trace out the maximul subset of+-- each index that we could possibly ever need. Do this by flattening packages+-- and looking at the names of all possible dependencies.+--+selectNeededSubset :: PackageIndex InstalledPackage+                   -> PackageIndex SourcePackage+                   -> Set PackageName+                   -> (PackageIndex InstalledPackage+                      ,PackageIndex SourcePackage)+selectNeededSubset installedPkgIndex sourcePkgIndex = select mempty mempty+  where+    select :: PackageIndex InstalledPackage+           -> PackageIndex SourcePackage+           -> Set PackageName+           -> (PackageIndex InstalledPackage+              ,PackageIndex SourcePackage)+    select installedPkgIndex' sourcePkgIndex' remaining+      | Set.null remaining = (installedPkgIndex', sourcePkgIndex')+      | otherwise = select installedPkgIndex'' sourcePkgIndex'' remaining''+      where+        (next, remaining') = Set.deleteFindMin remaining+        moreInstalled = PackageIndex.lookupPackageName installedPkgIndex next+        moreSource    = PackageIndex.lookupPackageName sourcePkgIndex next+        moreRemaining = -- we filter out packages already included in the indexes+                        -- this avoids an infinite loop if a package depends on itself+                        -- like base-3.0.3.0 with base-4.0.0.0+                        filter notAlreadyIncluded+                      $ [ packageName dep+                        | pkg <- moreInstalled+                        , dep <- depends pkg ]+                     ++ [ name+                        | SourcePackage _ pkg _ <- moreSource+                        , Dependency name _ <-+                            buildDepends (flattenPackageDescription pkg) ]+        installedPkgIndex'' = foldl' (flip PackageIndex.insert)+                                     installedPkgIndex' moreInstalled+        sourcePkgIndex''    = foldl' (flip PackageIndex.insert)+                                     sourcePkgIndex' moreSource+        remaining''         = foldl' (flip          Set.insert)+                                     remaining' moreRemaining+        notAlreadyIncluded name =+            null (PackageIndex.lookupPackageName installedPkgIndex' name)+         && null (PackageIndex.lookupPackageName sourcePkgIndex' name)++-- ------------------------------------------------------------+-- * Post processing the solution+-- ------------------------------------------------------------++finaliseSelectedPackages :: (PackageName -> PackagePreferences)+                         -> SelectedPackages+                         -> Constraints+                         -> [PlanPackage]+finaliseSelectedPackages pref selected constraints =+  map finaliseSelected (PackageIndex.allPackages selected)+  where+    remainingChoices = Constraints.choices constraints+    finaliseSelected (InstalledOnly      ipkg     ) = finaliseInstalled ipkg+    finaliseSelected (SourceOnly              apkg) = finaliseSource Nothing apkg+    finaliseSelected (InstalledAndSource ipkg apkg) =+      case PackageIndex.lookupPackageId remainingChoices (packageId ipkg) of+                                        --picked package not in constraints+        Nothing                       -> impossible "finaliseSelected no pkg"+                                        -- to constrain to avail only:+        Just (SourceOnly _)           -> impossible "finaliseSelected src only"+        Just (InstalledOnly _)        -> finaliseInstalled ipkg+        Just (InstalledAndSource _ _) -> finaliseSource (Just ipkg) apkg++    finaliseInstalled (InstalledPackageEx pkg _ _) = InstallPlan.PreExisting pkg+    finaliseSource mipkg (SemiConfiguredPackage pkg flags deps) =+      InstallPlan.Configured (ConfiguredPackage pkg flags deps')+      where+        deps' = map (packageId . pickRemaining mipkg) deps++    pickRemaining mipkg dep@(Dependency _name versionRange) =+          case PackageIndex.lookupDependency remainingChoices dep of+            []        -> impossible "pickRemaining no pkg"+            [pkg']    -> pkg'+            remaining -> assert (checkIsPaired remaining)+                       $ maximumBy bestByPref remaining+      where+        -- We order candidate packages to pick for a dependency by these+        -- three factors. The last factor is just highest version wins.+        bestByPref =+          comparing (\p -> (isCurrent p, isPreferred p, packageVersion p))+        -- Is the package already used by the installed version of this+        -- package? If so we should pick that first. This stops us from doing+        -- silly things like deciding to rebuild haskell98 against base 3.+        isCurrent = case mipkg :: Maybe InstalledPackageEx of+          Nothing   -> \_ -> False+          Just ipkg -> \p -> packageId p `elem` depends ipkg+        -- If there is no upper bound on the version range then we apply a+        -- preferred version according to the hackage or user's suggested+        -- version constraints. TODO: distinguish hacks from prefs+        bounded = boundedAbove versionRange+        isPreferred p+          | bounded   = True -- any constant will do+          | otherwise = packageVersion p `withinRange` preferredVersions+          where (PackagePreferences preferredVersions _) = pref (packageName p)++        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++        -- We really only expect to find more than one choice remaining when+        -- we're finalising a dependency on a paired package.+        checkIsPaired [p1, p2] =+          case Constraints.isPaired constraints (packageId p1) of+            Just p2'   -> packageId p2' == packageId p2+            Nothing    -> False+        checkIsPaired _ = False++-- | Improve an existing installation plan by, where possible, swapping+-- packages we plan to install with ones that are already installed.+-- This may add additional constraints due to the dependencies of installed+-- packages on other installed packages.+--+improvePlan :: PackageIndex InstalledPackage+            -> Constraints+            -> PackageIndex PlanPackage+            -> (PackageIndex PlanPackage, Constraints)+improvePlan installed constraints0 selected0 =+  foldl' improve (selected0, constraints0) (reverseTopologicalOrder selected0)+  where+    improve (selected, constraints) = fromMaybe (selected, constraints)+                                    . improvePkg selected constraints++    -- The idea is to improve the plan by swapping a configured package for+    -- an equivalent installed one. For a particular package the condition is+    -- that the package be in a configured state, that a the same version be+    -- already installed with the exact same dependencies and all the packages+    -- in the plan that it depends on are in the installed state+    improvePkg selected constraints pkgid = do+      Configured pkg  <- PackageIndex.lookupPackageId selected  pkgid+      ipkg            <- PackageIndex.lookupPackageId installed pkgid+      guard $ all (isInstalled selected) (depends pkg)+      tryInstalled selected constraints [ipkg]++    isInstalled selected pkgid =+      case PackageIndex.lookupPackageId selected pkgid of+        Just (PreExisting _) -> True+        _                    -> False++    tryInstalled :: PackageIndex PlanPackage -> Constraints+                 -> [InstalledPackage]+                 -> Maybe (PackageIndex PlanPackage, Constraints)+    tryInstalled selected constraints [] = Just (selected, constraints)+    tryInstalled selected constraints (pkg:pkgs) =+      case constraintsOk (packageId pkg) (depends pkg) constraints of+        Nothing           -> Nothing+        Just constraints' -> tryInstalled selected' constraints' pkgs'+          where+            selected' = PackageIndex.insert (PreExisting pkg) selected+            pkgs'      = catMaybes (map notSelected (depends pkg)) ++ pkgs+            notSelected pkgid =+              case (PackageIndex.lookupPackageId installed pkgid+                   ,PackageIndex.lookupPackageId selected  pkgid) of+                (Just pkg', Nothing) -> Just pkg'+                _                    -> Nothing++    constraintsOk _     []              constraints = Just constraints+    constraintsOk pkgid (pkgid':pkgids) constraints =+      case addPackageDependencyConstraint pkgid dep True constraints of+        Satisfiable constraints' _ -> constraintsOk pkgid pkgids constraints'+        _                          -> Nothing+      where+        dep = thisPackageVersion pkgid'++    reverseTopologicalOrder :: PackageFixedDeps pkg+                            => PackageIndex pkg -> [PackageId]+    reverseTopologicalOrder index = map (packageId . toPkg)+                                  . Graph.topSort+                                  . Graph.transposeG+                                  $ graph+      where (graph, toPkg, _) = PackageIndex.dependencyGraph index++-- ------------------------------------------------------------+-- * Adding and recording constraints+-- ------------------------------------------------------------++addPackageSelectConstraint :: PackageId -> Constraints+                           -> Satisfiable Constraints+                                [PackageId] ExclusionReason+addPackageSelectConstraint pkgid =+    Constraints.constrain pkgname constraint reason+  where+    pkgname          = packageName pkgid+    constraint ver _ = ver == packageVersion pkgid+    reason           = SelectedOther pkgid++addPackageExcludeConstraint :: PackageId -> ExclusionReason+                            -> Constraints+                            -> Satisfiable Constraints+                                           [PackageId] ExclusionReason+addPackageExcludeConstraint pkgid reason =+    Constraints.constrain pkgname constraint reason+  where+    pkgname = packageName pkgid+    constraint ver installed+      | ver == packageVersion pkgid = installed+      | otherwise                   = True++addPackageDependencyConstraint :: PackageId -> Dependency -> Bool+                               -> Constraints+                               -> Satisfiable Constraints+                                    [PackageId] ExclusionReason+addPackageDependencyConstraint pkgid dep@(Dependency pkgname verrange)+                                     installedConstraint =+    Constraints.constrain pkgname constraint reason+  where+    constraint ver installed = ver `withinRange` verrange+                            && if installedConstraint then installed else True+    reason = ExcludedByPackageDependency pkgid dep installedConstraint++addTopLevelVersionConstraint :: PackageName -> VersionRange+                             -> Constraints+                             -> Satisfiable Constraints+                                  [PackageId] ExclusionReason+addTopLevelVersionConstraint pkgname verrange =+    Constraints.constrain pkgname constraint reason+  where+    constraint ver _installed = ver `withinRange` verrange+    reason = ExcludedByTopLevelConstraintVersion pkgname verrange++addTopLevelInstalledConstraint,+  addTopLevelSourceConstraint :: PackageName+                              -> Constraints+                              -> Satisfiable Constraints+                                   [PackageId] ExclusionReason+addTopLevelInstalledConstraint pkgname =+    Constraints.constrain pkgname constraint reason+  where+    constraint _ver installed = installed+    reason = ExcludedByTopLevelConstraintInstalled pkgname++addTopLevelSourceConstraint pkgname =+    Constraints.constrain pkgname constraint reason+  where+    constraint _ver installed = not installed+    reason = ExcludedByTopLevelConstraintSource pkgname+++-- ------------------------------------------------------------+-- * Reasons for constraints+-- ------------------------------------------------------------++-- | For every constraint we record we also record the reason that constraint+-- is needed. So if we end up failing due to conflicting constraints then we+-- can give an explnanation as to what was conflicting and why.+--+data ExclusionReason =++     -- | We selected this other version of the package. That means we exclude+     -- all the other versions.+     SelectedOther PackageId++     -- | We excluded this version of the package because it failed to+     -- configure probably because of unsatisfiable deps.+   | ExcludedByConfigureFail [Dependency]++     -- | We excluded this version of the package because another package that+     -- we selected imposed a dependency which this package did not satisfy.+   | ExcludedByPackageDependency PackageId Dependency Bool++     -- | We excluded this version of the package because it did not satisfy+     -- a dependency given as an original top level input.+     --+   | ExcludedByTopLevelConstraintVersion   PackageName VersionRange+   | ExcludedByTopLevelConstraintInstalled PackageName+   | ExcludedByTopLevelConstraintSource    PackageName++  deriving Eq++-- | Given an excluded package and the reason it was excluded, produce a human+-- readable explanation.+--+showExclusionReason :: PackageId -> ExclusionReason -> String+showExclusionReason pkgid (SelectedOther pkgid') =+  display pkgid ++ " was excluded because " +++  display pkgid' ++ " was selected instead"+showExclusionReason pkgid (ExcludedByConfigureFail missingDeps) =+  display pkgid ++ " was excluded because it could not be configured. "+  ++ "It requires " ++ listOf displayDep missingDeps+showExclusionReason pkgid (ExcludedByPackageDependency pkgid' dep installedConstraint)+  = display pkgid ++ " was excluded because " ++ display pkgid' ++ " requires "+ ++ (if installedConstraint then "an installed instance of " else "")+ ++ displayDep dep+showExclusionReason pkgid (ExcludedByTopLevelConstraintVersion pkgname verRange) =+  display pkgid ++ " was excluded because of the top level constraint " +++  displayDep (Dependency pkgname verRange)+showExclusionReason pkgid (ExcludedByTopLevelConstraintInstalled pkgname)+  = display pkgid ++ " was excluded because of the top level constraint '"+ ++ display pkgname ++ " installed' which means that only installed instances "+ ++ "of the package may be selected."+showExclusionReason pkgid (ExcludedByTopLevelConstraintSource pkgname)+  = display pkgid ++ " was excluded because of the top level constraint '"+ ++ display pkgname ++ " source' which means that only source versions "+ ++ "of the package may be selected."+++-- ------------------------------------------------------------+-- * Logging progress and failures+-- ------------------------------------------------------------++data Log = Select [SelectedPackage] [PackageId]+         | AppliedVersionConstraint   PackageName VersionRange [PackageId]+         | AppliedInstalledConstraint PackageName InstalledConstraint [PackageId]+         | ExcludeUnconfigurable PackageId++data Failure+   = NoSuchPackage+       PackageName+   | ConfigureFailed+       SelectablePackage+       [(Dependency, [(PackageId, [ExclusionReason])])]+   | DependencyConflict+       SelectedPackage Dependency Bool+       [(PackageId, [ExclusionReason])]+   | TopLevelVersionConstraintConflict+       PackageName VersionRange+       [(PackageId, [ExclusionReason])]+   | TopLevelVersionConstraintUnsatisfiable+       PackageName VersionRange+   | TopLevelInstallConstraintConflict+       PackageName InstalledConstraint+       [(PackageId, [ExclusionReason])]+   | TopLevelInstallConstraintUnsatisfiable+       PackageName InstalledConstraint++showLog :: Log -> String+showLog (Select selected discarded) = case (selectedMsg, discardedMsg) of+  ("", y) -> y+  (x, "") -> x+  (x,  y) -> x ++ " and " ++ y++  where+    selectedMsg  = "selecting " ++ case selected of+      []     -> ""+      [s]    -> display (packageId s) ++ " " ++ kind s+      (s:ss) -> listOf id+              $ (display (packageId s) ++ " " ++ kind s)+              : [ display (packageVersion s') ++ " " ++ kind s'+                | s' <- ss ]++    kind (InstalledOnly _)        = "(installed)"+    kind (SourceOnly _)           = "(source)"+    kind (InstalledAndSource _ _) = "(installed or source)"++    discardedMsg = case discarded of+      []  -> ""+      _   -> "discarding " ++ listOf id+        [ element+        | (pkgid:pkgids) <- groupBy (equating packageName) (sort discarded)+        , element <- display pkgid : map (display . packageVersion) pkgids ]+showLog (AppliedVersionConstraint pkgname ver pkgids) =+     "applying constraint " ++ display (Dependency pkgname ver)+  ++ if null pkgids+       then ""+       else "which excludes " ++ listOf display pkgids+showLog (AppliedInstalledConstraint pkgname inst pkgids) =+     "applying constraint " ++ display pkgname ++ " '"+  ++ (case inst of InstalledConstraint -> "installed"; _ -> "source") ++ "' "+  ++ if null pkgids+       then ""+       else "which excludes " ++ listOf display pkgids+showLog (ExcludeUnconfigurable pkgid) =+     "excluding " ++ display pkgid ++ " (it cannot be configured)"++showFailure :: Failure -> String+showFailure (NoSuchPackage pkgname) =+     "The package " ++ display pkgname ++ " is unknown."+showFailure (ConfigureFailed pkg missingDeps) =+     "cannot configure " ++ displayPkg pkg ++ ". It requires "+  ++ listOf (displayDep . fst) missingDeps+  ++ '\n' : unlines (map (uncurry whyNot) missingDeps)++  where+    whyNot (Dependency name ver) [] =+         "There is no available version of " ++ display name+      ++ " that satisfies " ++ displayVer ver++    whyNot dep conflicts =+         "For the dependency on " ++ displayDep dep+      ++ " there are these packages: " ++ listOf display pkgs+      ++ ". However none of them are available.\n"+      ++ unlines [ showExclusionReason (packageId pkg') reason+                 | (pkg', reasons) <- conflicts, reason <- reasons ]++      where pkgs = map fst conflicts++showFailure (DependencyConflict pkg dep installedConstraint conflicts) =+     "dependencies conflict: "+  ++ displayPkg pkg ++ " requires "+  ++ (if installedConstraint then "an installed instance of " else "")+  ++ displayDep dep ++ " however:\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelVersionConstraintConflict name ver conflicts) =+     "constraints conflict: we have the top level constraint "+  ++ displayDep (Dependency name ver) ++ ", but\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelVersionConstraintUnsatisfiable name ver) =+     "There is no available version of " ++ display name+      ++ " that satisfies " ++ displayVer ver++showFailure (TopLevelInstallConstraintConflict name InstalledConstraint conflicts) =+     "constraints conflict: "+  ++ "top level constraint '" ++ display name ++ " installed' however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelInstallConstraintUnsatisfiable name InstalledConstraint) =+     "There is no installed version of " ++ display name++showFailure (TopLevelInstallConstraintConflict name SourceConstraint conflicts) =+     "constraints conflict: "+  ++ "top level constraint '" ++ display name ++ " source' however\n"+  ++ unlines [ showExclusionReason (packageId pkg') reason+             | (pkg', reasons) <- conflicts, reason <- reasons ]++showFailure (TopLevelInstallConstraintUnsatisfiable name SourceConstraint) =+     "There is no available source version of " ++ display name++displayVer :: VersionRange -> String+displayVer = display . simplifyVersionRange++displayDep :: Dependency -> String+displayDep = display . simplifyDependency+++-- ------------------------------------------------------------+-- * Utils+-- ------------------------------------------------------------++impossible :: String -> a+impossible msg = internalError $ "assertion failure: " ++ msg++internalError :: String -> a+internalError msg = error $ "internal error: " ++ msg++displayPkg :: Package pkg => pkg -> String+displayPkg = display . packageId++listOf :: (a -> String) -> [a] -> String+listOf _    []   = []+listOf disp [x0] = disp x0+listOf disp (x0:x1:xs) = disp x0 ++ go x1 xs+  where go x []       = " and " ++ disp x+        go x (x':xs') = ", " ++ disp x ++ go x' xs'
+ cabal/cabal-install/Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -0,0 +1,601 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.TopDown.Constraints+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A set of satisfiable constraints on a set of packages.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown.Constraints (+  Constraints,+  empty,+  packages,+  choices,+  isPaired,++  addTarget,+  constrain,+  Satisfiable(..),+  conflicting,+  ) where++import Distribution.Client.Dependency.TopDown.Types+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Package+         ( PackageName, PackageId, PackageIdentifier(..)+         , Package(packageId), packageName, packageVersion+         , Dependency, PackageFixedDeps(depends) )+import Distribution.Version+         ( Version )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )++import Data.Monoid+         ( Monoid(mempty) )+import Data.Either+         ( partitionEithers )         +import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Set as Set+import Data.Set (Set)+import Control.Exception+         ( assert )+++-- | A set of satisfiable constraints on a set of packages.+--+-- The 'Constraints' type keeps track of a set of targets (identified by+-- package name) that we know that we need. It also keeps track of a set of+-- constraints over all packages in the environment.+--+-- It maintains the guarantee that, for the target set, the constraints are+-- satisfiable, meaning that there is at least one instance available for each+-- package name that satisfies the constraints on that package name.+--+-- Note that it is possible to over-constrain a package in the environment that+-- is not in the target set -- the satisfiability guarantee is only maintained+-- for the target set. This is useful because it allows us to exclude packages+-- without needing to know if it would ever be needed or not (e.g. allows+-- excluding broken installed packages).+--+-- Adding a constraint for a target package can fail if it would mean that+-- there are no remaining choices.+--+-- Adding a constraint for package that is not a target never fails.+--+-- Adding a new target package can fail if that package already has conflicting+-- constraints.+--+data (Package installed, Package source)+  => Constraints installed source reason+   = Constraints++       -- | Targets that we know we need. This is the set for which we+       -- guarantee the constraints are satisfiable.+       !(Set PackageName)++       -- | The available/remaining set. These are packages that have available+       -- choices remaining. This is guaranteed to cover the target packages,+       -- but can also cover other packages in the environment. New targets can+       -- only be added if there are available choices remaining for them.+       !(PackageIndex (InstalledOrSource installed source))++       -- | The excluded set. Choices that we have excluded by applying+       -- constraints. Excluded choices are tagged with the reason.+       !(PackageIndex (ExcludedPkg (InstalledOrSource installed source) reason))++       -- | Paired choices, this is an ugly hack.+       !(Map PackageName (Version, Version))++       -- | Purely for the invariant, we keep a copy of the original index+       !(PackageIndex (InstalledOrSource installed source))+++-- | Reasons for excluding all, or some choices for a package version.+--+-- Each package version can have a source instance, an installed instance or+-- both. We distinguish reasons for constraints that excluded both instances,+-- from reasons for constraints that excluded just one instance.+--+data ExcludedPkg pkg reason+   = ExcludedPkg pkg+       [reason] -- ^ reasons for excluding both source and installed instances+       [reason] -- ^ reasons for excluding the installed instance+       [reason] -- ^ reasons for excluding the source instance++instance Package pkg => Package (ExcludedPkg pkg reason) where+  packageId (ExcludedPkg p _ _ _) = packageId p+++-- | There is a conservation of packages property. Packages are never gained or+-- lost, they just transfer from the remaining set to the excluded set.+--+invariant :: (Package installed, Package source)+          => Constraints installed source a -> Bool+invariant (Constraints targets available excluded _ original) =+    +    -- Relationship between available, excluded and original+    all check merged++    -- targets is a subset of available+ && all (PackageIndex.elemByPackageName available) (Set.elems targets)++  where+    merged = mergeBy (\a b -> packageId a `compare` mergedPackageId b)+                     (PackageIndex.allPackages original)+                     (mergeBy (\a b -> packageId a `compare` packageId b)+                              (PackageIndex.allPackages available)+                              (PackageIndex.allPackages excluded))+      where+        mergedPackageId (OnlyInLeft  p  ) = packageId p+        mergedPackageId (OnlyInRight   p) = packageId p+        mergedPackageId (InBoth      p _) = packageId p++    -- If the package was originally installed only, then+    check (InBoth (InstalledOnly _) cur) = case cur of+      -- now it's either still remaining as installed only+      OnlyInLeft               (InstalledOnly _)              -> True+      -- or it has been excluded+      OnlyInRight (ExcludedPkg (InstalledOnly _) [] (_:_) []) -> True+      _                                                       -> False++    -- If the package was originally available only, then+    check (InBoth (SourceOnly _) cur) = case cur of+      -- now it's either still remaining as source only+      OnlyInLeft               (SourceOnly _)              -> True+      -- or it has been excluded+      OnlyInRight (ExcludedPkg (SourceOnly _) [] [] (_:_)) -> True+      _                                                    -> False++    -- If the package was originally installed and source, then+    check (InBoth (InstalledAndSource _ _) cur) = case cur of+      -- We can have both remaining:+      OnlyInLeft               (InstalledAndSource _ _)        -> True++      -- both excluded, in particular it can have had the just source or+      -- installed excluded and later had both excluded so we do not mind if+      -- the source or installed excluded is empty or non-empty.+      OnlyInRight (ExcludedPkg (InstalledAndSource _ _) _ _ _) -> True++      -- the installed remaining and the source excluded:+      InBoth                   (InstalledOnly _)+                  (ExcludedPkg (SourceOnly _) [] [] (_:_))     -> True++      -- the source remaining and the installed excluded:+      InBoth                   (SourceOnly _)+                  (ExcludedPkg (InstalledOnly _) [] (_:_) [])  -> True+      _                                                        -> False++    check _ = False+++-- | An update to the constraints can move packages between the two piles+-- but not gain or loose packages.+transitionsTo :: (Package installed, Package source)+              => Constraints installed source a+              -> Constraints installed source a -> Bool+transitionsTo constraints @(Constraints _ available  excluded  _ _)+              constraints'@(Constraints _ available' excluded' _ _) =++     invariant constraints && invariant constraints'+  && null availableGained  && null excludedLost+  &&    map (mapInstalledOrSource packageId packageId) availableLost+     == map (mapInstalledOrSource packageId packageId) excludedGained++  where+    (availableLost, availableGained)+      = partitionEithers (foldr lostAndGained [] availableChange)++    (excludedLost, excludedGained)+      = partitionEithers (foldr lostAndGained [] excludedChange)++    availableChange =+      mergeBy (\a b -> packageId a `compare` packageId b)+        (PackageIndex.allPackages available)+        (PackageIndex.allPackages available')++    excludedChange =+      mergeBy (\a b -> packageId a `compare` packageId b)+        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded  ]+        [ pkg | ExcludedPkg pkg _ _ _ <- PackageIndex.allPackages excluded' ]+    +    lostAndGained mr rest = case mr of+      OnlyInLeft pkg                    -> Left pkg : rest+      InBoth (InstalledAndSource pkg _)+             (SourceOnly _)             -> Left (InstalledOnly pkg) : rest+      InBoth (InstalledAndSource _ pkg)+             (InstalledOnly _)          -> Left (SourceOnly pkg) : rest+      InBoth (SourceOnly _)+             (InstalledAndSource pkg _) -> Right (InstalledOnly pkg) : rest+      InBoth (InstalledOnly _)+             (InstalledAndSource _ pkg) -> Right (SourceOnly pkg) : rest+      OnlyInRight pkg                   -> Right pkg : rest+      _                                 -> rest++    mapInstalledOrSource f g pkg = case pkg of+      InstalledOnly      a   -> InstalledOnly (f a)+      SourceOnly           b -> SourceOnly    (g b)+      InstalledAndSource a b -> InstalledAndSource (f a) (g b)+++-- | We construct 'Constraints' with an initial 'PackageIndex' of all the+-- packages available.+--+empty :: (PackageFixedDeps installed, Package source)+      => PackageIndex installed+      -> PackageIndex source+      -> Constraints installed source reason+empty installed source =+    Constraints targets pkgs excluded pairs pkgs+  where+    targets  = mempty+    excluded = mempty+    pkgs = PackageIndex.fromList+         . map toInstalledOrSource+         $ mergeBy (\a b -> packageId a `compare` packageId b)+                   (PackageIndex.allPackages installed)+                   (PackageIndex.allPackages source)+    toInstalledOrSource (OnlyInLeft  i  ) = InstalledOnly      i+    toInstalledOrSource (OnlyInRight   a) = SourceOnly           a+    toInstalledOrSource (InBoth      i a) = InstalledAndSource i a++    -- pick up cases like base-3 and 4 where one version depends on the other:+    pairs = Map.fromList+      [ (name, (packageVersion pkgid1, packageVersion pkgid2))+      | [pkg1, pkg2] <- PackageIndex.allPackagesByName installed+      , let name   = packageName pkg1+            pkgid1 = packageId pkg1+            pkgid2 = packageId pkg2+      ,    any ((pkgid1==) . packageId) (depends pkg2)+        || any ((pkgid2==) . packageId) (depends pkg1) ]+++-- | The package targets.+--+packages :: (Package installed, Package source)+         => Constraints installed source reason+         -> Set PackageName+packages (Constraints ts _ _ _ _) = ts+++-- | The package choices that are still available.+--+choices :: (Package installed, Package source)+        => Constraints installed source reason+        -> PackageIndex (InstalledOrSource installed source)+choices (Constraints _ available _ _ _) = available++isPaired :: (Package installed, Package source)+         => Constraints installed source reason+         -> PackageId -> Maybe PackageId+isPaired (Constraints _ _ _ pairs _) (PackageIdentifier name version) =+  case Map.lookup name pairs of+    Just (v1, v2)+      | version == v1 -> Just (PackageIdentifier name v2)+      | version == v2 -> Just (PackageIdentifier name v1)+    _                 -> Nothing+++data Satisfiable constraints discarded reason+       = Satisfiable constraints discarded+       | Unsatisfiable+       | ConflictsWith [(PackageId, [reason])]+++addTarget :: (Package installed, Package source)+          => PackageName+          -> Constraints installed source reason+          -> Satisfiable (Constraints installed source reason)+                         () reason+addTarget pkgname+          constraints@(Constraints targets available excluded paired original)++    -- If it's already a target then there's no change+  | pkgname `Set.member` targets+  = Satisfiable constraints ()++    -- If there is some possible choice available for this target then we're ok+  | PackageIndex.elemByPackageName available pkgname+  = let targets'     = Set.insert pkgname targets+        constraints' = Constraints targets' available excluded paired original+     in assert (constraints `transitionsTo` constraints') $+        Satisfiable constraints' ()++    -- If it's not available and it is excluded then we return the conflicts+  | PackageIndex.elemByPackageName excluded pkgname+  = ConflictsWith conflicts++    -- Otherwise, it's not available and it has not been excluded so the+    -- package is simply completely unknown.+  | otherwise+  = Unsatisfiable+  +  where+    conflicts =+      [ (packageId pkg, reasons)+      | let excludedChoices = PackageIndex.lookupPackageName excluded pkgname+      , ExcludedPkg pkg isReasons iReasons sReasons <- excludedChoices+      , let reasons = isReasons ++ iReasons ++ sReasons ]+++constrain :: (Package installed, Package source)+          => PackageName                -- ^ which package to constrain+          -> (Version -> Bool -> Bool)  -- ^ the constraint test+          -> reason                     -- ^ the reason for the constraint+          -> Constraints installed source reason+          -> Satisfiable (Constraints installed source reason)+                         [PackageId] reason+constrain pkgname constraint reason+          constraints@(Constraints targets available excluded paired original)++  | pkgname `Set.member` targets  &&  not anyRemaining+  = if null conflicts then Unsatisfiable+                      else ConflictsWith conflicts++  | otherwise+  = let constraints' = Constraints targets available' excluded' paired original+     in assert (constraints `transitionsTo` constraints') $+        Satisfiable constraints' (map packageId newExcluded)++  where+    -- This tells us if any packages would remain at all for this package name if+    -- we applied this constraint. This amounts to checking if any package+    -- satisfies the given constraint, including version range and installation+    -- status.+    --+    (available', excluded', newExcluded, anyRemaining, conflicts) =+      updatePkgsStatus+        available excluded+        [] False []+        (mergeBy (\pkg pkg' -> packageVersion pkg `compare` packageVersion pkg')+                 (PackageIndex.lookupPackageName available pkgname)+                 (PackageIndex.lookupPackageName excluded  pkgname))++    testConstraint pkg =+      let ver = packageVersion pkg in+      case Map.lookup (packageName pkg) paired of++        Just (v1, v2)+          | ver == v1 || ver == v2+          -> case pkg of+               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)+               SourceOnly    spkg -> SourceOnly    (spkg, sOk)+               InstalledAndSource ipkg spkg ->+                 InstalledAndSource (ipkg, iOk) (spkg, sOk)+          where+            iOk = constraint v1 True  || constraint v2 True+            sOk = constraint v1 False || constraint v2 False++        _ -> case pkg of+               InstalledOnly ipkg -> InstalledOnly (ipkg, iOk)+               SourceOnly    spkg -> SourceOnly    (spkg, sOk)+               InstalledAndSource ipkg spkg ->+                 InstalledAndSource (ipkg, iOk) (spkg, sOk)+          where+            iOk = constraint ver True+            sOk = constraint ver False++    -- For the info about available and excluded versions of the package in+    -- question, update the info given the current constraint+    --+    -- We update the available package map and the excluded package map+    -- we also collect:+    --   * the change in available packages (for logging)+    --   * whether there are any remaining choices+    --   * any constraints that conflict with the current constraint++    updatePkgsStatus _ _ nePkgs ok cs _+      | seq nePkgs $ seq ok $ seq cs False = undefined++    updatePkgsStatus aPkgs ePkgs nePkgs ok cs []+      = (aPkgs, ePkgs, reverse nePkgs, ok, reverse cs)++    updatePkgsStatus aPkgs ePkgs nePkgs ok cs (pkg:pkgs) =+        let (aPkgs', ePkgs', mnePkg, ok', mc) = updatePkgStatus aPkgs ePkgs pkg+            nePkgs' = maybeCons mnePkg nePkgs+            cs'     = maybeCons mc cs+         in updatePkgsStatus aPkgs' ePkgs' nePkgs' (ok' || ok) cs' pkgs++    maybeCons Nothing  xs = xs+    maybeCons (Just x) xs = x:xs+        ++    -- For the info about an available or excluded version of the package in+    -- question, update the info given the current constraint.+    --+    updatePkgStatus aPkgs ePkgs pkg =+      case viewPackageStatus pkg of+        AllAvailable (InstalledOnly (aiPkg, False)) ->+          removeAvailable False+            (InstalledOnly aiPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])+            Nothing++        AllAvailable (SourceOnly (asPkg, False)) ->+          removeAvailable False+            (SourceOnly asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])+            Nothing++        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, False)) ->+          removeAvailable False +            (InstalledAndSource aiPkg asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource aiPkg asPkg) [reason] [] [])+            Nothing++        AllAvailable (InstalledAndSource (aiPkg, True) (asPkg, False)) ->+          removeAvailable True +            (SourceOnly asPkg)+            (PackageIndex.insert (InstalledOnly aiPkg))+            (ExcludedPkg (SourceOnly asPkg) [] [] [reason])+            Nothing++        AllAvailable (InstalledAndSource (aiPkg, False) (asPkg, True)) ->+          removeAvailable True+            (InstalledOnly aiPkg)+            (PackageIndex.insert (SourceOnly asPkg))+            (ExcludedPkg (InstalledOnly aiPkg) [] [reason] [])+            Nothing++        AllAvailable _ -> noChange True Nothing++        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, False) _ _ srs) ->+          removeAvailable False+            (InstalledOnly aiPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [reason] [] srs)+            Nothing++        AvailableExcluded (_aiPkg, True) (ExcludedPkg (esPkg, False) _ _ srs) ->+          addExtraExclusion True+            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))+            Nothing++        AvailableExcluded (aiPkg, False) (ExcludedPkg (esPkg, True) _ _ srs) ->+          removeAvailable  True+            (InstalledOnly aiPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource aiPkg esPkg) [] [reason] srs)+            (Just (pkgid, srs))++        AvailableExcluded (_aiPkg, True) (ExcludedPkg (_esPkg, True) _ _ srs) ->+          noChange True+            (Just (pkgid, srs))++        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (asPkg, False) ->+          removeAvailable  False+            (SourceOnly asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [reason] irs [])+            Nothing++        ExcludedAvailable (ExcludedPkg (eiPkg, True) _ irs _) (asPkg, False) ->+          removeAvailable False+            (SourceOnly asPkg)+            (PackageIndex.deletePackageId pkgid)+            (ExcludedPkg (InstalledAndSource eiPkg asPkg) [] irs [reason])+            (Just (pkgid, irs))++        ExcludedAvailable (ExcludedPkg (eiPkg, False) _ irs _) (_asPkg, True) ->+          addExtraExclusion True+            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])+            Nothing++        ExcludedAvailable (ExcludedPkg (_eiPkg, True) _ irs _) (_asPkg, True) ->+          noChange True+            (Just (pkgid, irs))++        AllExcluded (ExcludedPkg (InstalledOnly (eiPkg, False)) _ irs _) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledOnly eiPkg) [] (reason:irs) [])+            Nothing++        AllExcluded (ExcludedPkg (InstalledOnly (_eiPkg, True)) _ irs _) ->+          noChange False+            (Just (pkgid, irs))++        AllExcluded (ExcludedPkg (SourceOnly (esPkg, False)) _ _ srs) ->+          addExtraExclusion False+            (ExcludedPkg (SourceOnly esPkg) [] [] (reason:srs))+            Nothing++        AllExcluded (ExcludedPkg (SourceOnly (_esPkg, True)) _ _ srs) ->+          noChange False+            (Just (pkgid, srs))++        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, False)) isrs irs srs) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledAndSource eiPkg esPkg) (reason:isrs) irs srs)+            Nothing++        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, True) (esPkg, False)) isrs irs srs) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs irs (reason:srs))+            (Just (pkgid, irs))++        AllExcluded (ExcludedPkg (InstalledAndSource (eiPkg, False) (esPkg, True)) isrs irs srs) ->+          addExtraExclusion False+            (ExcludedPkg (InstalledAndSource eiPkg esPkg) isrs (reason:irs) srs)+            (Just (pkgid, srs))++        AllExcluded (ExcludedPkg (InstalledAndSource (_eiPkg, True) (_esPkg, True)) isrs irs srs) ->+          noChange False+            (Just (pkgid, isrs ++ irs ++ srs))++      where+        removeAvailable ok nePkg adjustAvailable ePkg c =+          let aPkgs' = adjustAvailable aPkgs+              ePkgs' = PackageIndex.insert ePkg ePkgs+           in aPkgs' `seq` ePkgs' `seq`+              (aPkgs', ePkgs', Just nePkg, ok, c)++        addExtraExclusion ok ePkg c =+          let ePkgs' = PackageIndex.insert ePkg ePkgs+           in ePkgs' `seq`+              (aPkgs, ePkgs', Nothing, ok, c)++        noChange ok c =+          (aPkgs, ePkgs, Nothing, ok, c)++        pkgid = case pkg of OnlyInLeft  p   -> packageId p+                            OnlyInRight p   -> packageId p+                            InBoth      p _ -> packageId p+++    viewPackageStatus+      :: (Package installed, Package source)+      => MergeResult (InstalledOrSource installed source)+                     (ExcludedPkg (InstalledOrSource installed source) reason)+      -> PackageStatus (installed, Bool) (source, Bool) reason+    viewPackageStatus merged =+        case merged of+          OnlyInLeft aPkg ->+            AllAvailable (testConstraint aPkg)++          OnlyInRight (ExcludedPkg ePkg isrs irs srs) ->+            AllExcluded (ExcludedPkg (testConstraint ePkg) isrs irs srs)++          InBoth (InstalledOnly aiPkg)+                 (ExcludedPkg (SourceOnly esPkg) [] [] srs) ->+            case testConstraint (InstalledAndSource aiPkg esPkg) of+              InstalledAndSource (aiPkg', iOk) (esPkg', sOk) ->+                AvailableExcluded (aiPkg', iOk) (ExcludedPkg (esPkg', sOk) [] [] srs)+              _ -> impossible++          InBoth (SourceOnly asPkg)+                 (ExcludedPkg (InstalledOnly eiPkg) [] irs []) ->+            case testConstraint (InstalledAndSource eiPkg asPkg) of+              InstalledAndSource (eiPkg', iOk) (asPkg', sOk) ->+                ExcludedAvailable (ExcludedPkg (eiPkg', iOk) [] irs []) (asPkg', sOk)+              _ -> impossible+          _ -> impossible+      where+        impossible = error "impossible: viewPackageStatus invariant violation"++-- A intermediate structure that enumerates all the possible cases given the+-- invariant. This helps us to get simpler and complete pattern matching in+-- updatePkg above+--+data PackageStatus installed source reason+   = AllAvailable (InstalledOrSource installed source)+   | AllExcluded  (ExcludedPkg (InstalledOrSource installed source) reason)+   | AvailableExcluded installed (ExcludedPkg source reason)+   | ExcludedAvailable (ExcludedPkg installed reason) source+++conflicting :: (Package installed, Package source)+            => Constraints installed source reason+            -> Dependency+            -> [(PackageId, [reason])]+conflicting (Constraints _ _ excluded _ _) dep =+  [ (packageId pkg, reasonsAll ++ reasonsAvail ++ reasonsInstalled) --TODO+  | ExcludedPkg pkg reasonsAll reasonsAvail reasonsInstalled <-+      PackageIndex.lookupDependency excluded dep ]
+ cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs view
@@ -0,0 +1,89 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.TopDown.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Types for the top-down dependency resolver.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.TopDown.Types where++import Distribution.Client.Types+         ( SourcePackage(..), InstalledPackage )++import Distribution.Package+         ( PackageIdentifier, Dependency+         , Package(packageId), PackageFixedDeps(depends) )+import Distribution.PackageDescription+         ( FlagAssignment )++-- ------------------------------------------------------------+-- * The various kinds of packages+-- ------------------------------------------------------------++type SelectablePackage+   = InstalledOrSource InstalledPackageEx UnconfiguredPackage++type SelectedPackage+   = InstalledOrSource InstalledPackageEx SemiConfiguredPackage++data InstalledOrSource installed source+   = InstalledOnly      installed+   | SourceOnly                   source+   | InstalledAndSource installed source+  deriving Eq++type TopologicalSortNumber = Int++data InstalledPackageEx+   = InstalledPackageEx+       InstalledPackage+       !TopologicalSortNumber+       [PackageIdentifier]    -- transative closure of installed deps++data UnconfiguredPackage+   = UnconfiguredPackage+       SourcePackage+       !TopologicalSortNumber+       FlagAssignment++data SemiConfiguredPackage+   = SemiConfiguredPackage+       SourcePackage     -- package info+       FlagAssignment    -- total flag assignment for the package+       [Dependency]      -- dependencies we end up with when we apply+                         -- the flag assignment++instance Package InstalledPackageEx where+  packageId (InstalledPackageEx p _ _) = packageId p++instance PackageFixedDeps InstalledPackageEx where+  depends (InstalledPackageEx _ _ deps) = deps++instance Package UnconfiguredPackage where+  packageId (UnconfiguredPackage p _ _) = packageId p++instance Package SemiConfiguredPackage where+  packageId (SemiConfiguredPackage p _ _) = packageId p++instance (Package installed, Package source)+      => Package (InstalledOrSource installed source) where+  packageId (InstalledOnly      p  ) = packageId p+  packageId (SourceOnly         p  ) = packageId p+  packageId (InstalledAndSource p _) = packageId p+++-- | We can have constraints on selecting just installed or just source+-- packages.+--+-- In particular, installed packages can only depend on other installed+-- packages while packages that are not yet installed but which we plan to+-- install can depend on installed or other not-yet-installed packages.+--+data InstalledConstraint = InstalledConstraint+                         | SourceConstraint+  deriving (Eq, Show)
+ cabal/cabal-install/Distribution/Client/Dependency/Types.hs view
@@ -0,0 +1,116 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Types+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Common types for dependency resolution.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.Types (+    DependencyResolver,++    PackageConstraint(..),+    PackagePreferences(..),+    InstalledPreference(..),++    Progress(..),+    foldProgress,+  ) where++import Distribution.Client.Types+         ( SourcePackage(..), InstalledPackage )+import qualified Distribution.Client.InstallPlan as InstallPlan++import Distribution.PackageDescription+         ( FlagAssignment )+import Distribution.Client.PackageIndex+         ( PackageIndex )+import Distribution.Package+         ( PackageName )+import Distribution.Version+         ( VersionRange )+import Distribution.Compiler+         ( CompilerId )+import Distribution.System+         ( Platform )++import Prelude hiding (fail)++-- | A dependency resolver is a function that works out an installation plan+-- given the set of installed and available packages and a set of deps to+-- solve for.+--+-- The reason for this interface is because there are dozens of approaches to+-- solving the package dependency problem and we want to make it easy to swap+-- in alternatives.+--+type DependencyResolver = Platform+                       -> CompilerId+                       -> PackageIndex InstalledPackage+                       -> PackageIndex SourcePackage+                       -> (PackageName -> PackagePreferences)+                       -> [PackageConstraint]+                       -> [PackageName]+                       -> Progress String String [InstallPlan.PlanPackage]++-- | Per-package constraints. Package constraints must be respected by the+-- solver. Multiple constraints for each package can be given, though obviously+-- it is possible to construct conflicting constraints (eg impossible version+-- range or inconsistent flag assignment).+--+data PackageConstraint+   = PackageConstraintVersion   PackageName VersionRange+   | PackageConstraintInstalled PackageName+   | PackageConstraintSource    PackageName+   | PackageConstraintFlags     PackageName FlagAssignment+  deriving (Show,Eq)++-- | A per-package preference on the version. It is a soft constraint that the+-- 'DependencyResolver' should try to respect where possible. It consists of+-- a 'InstalledPreference' which says if we prefer versions of packages+-- that are already installed. It also hase a 'PackageVersionPreference' which+-- is a suggested constraint on the version number. The resolver should try to+-- use package versions that satisfy the suggested version constraint.+--+-- It is not specified if preferences on some packages are more important than+-- others.+--+data PackagePreferences = PackagePreferences VersionRange InstalledPreference++-- | Wether we prefer an installed version of a package or simply the latest+-- version.+--+data InstalledPreference = PreferInstalled | PreferLatest++-- | A type to represent the unfolding of an expensive long running+-- calculation that may fail. We may get intermediate steps before the final+-- retult which may be used to indicate progress and\/or logging messages.+--+data Progress step fail done = Step step (Progress step fail done)+                             | Fail fail+                             | Done done++-- | Consume a 'Progres' calculation. Much like 'foldr' for lists but with+-- two base cases, one for a final result and one for failure.+--+-- Eg to convert into a simple 'Either' result use:+--+-- > foldProgress (flip const) Left Right+--+foldProgress :: (step -> a -> a) -> (fail -> a) -> (done -> a)+             -> Progress step fail done -> a+foldProgress step fail done = fold+  where fold (Step s p) = step s (fold p)+        fold (Fail f)   = fail f+        fold (Done r)   = done r++instance Functor (Progress step fail) where+  fmap f = foldProgress Step Fail (Done . f)++instance Monad (Progress step fail) where+  return a = Done a+  p >>= f  = foldProgress Step Fail f p
+ cabal/cabal-install/Distribution/Client/Fetch.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Fetch+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal fetch command+-----------------------------------------------------------------------------+module Distribution.Client.Fetch (+    fetch,+  ) where++import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.FetchUtils hiding (fetchPackage)+import Distribution.Client.Dependency+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.Setup+         ( GlobalFlags(..), FetchFlags(..) )++import Distribution.Package+         ( packageId )+import Distribution.Simple.Compiler+         ( Compiler(compilerId), PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration )+import Distribution.Simple.Setup+         ( fromFlag )+import Distribution.Simple.Utils+         ( die, notice, debug )+import Distribution.System+         ( buildPlatform )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import Control.Monad+         ( filterM )++-- ------------------------------------------------------------+-- * The fetch command+-- ------------------------------------------------------------++--TODO:+-- * add fetch -o support+-- * support tarball URLs via ad-hoc download cache (or in -o mode?)+-- * suggest using --no-deps, unpack or fetch -o if deps cannot be satisfied+-- * Port various flags from install:+--   * --updage-dependencies+--   * --constraint and --preference+--   * --only-dependencies, but note it conflicts with --no-deps+++-- | Fetch a list of packages and their dependencies.+--+fetch :: Verbosity+      -> PackageDBStack+      -> [Repo]+      -> Compiler+      -> ProgramConfiguration+      -> GlobalFlags+      -> FetchFlags+      -> [UserTarget]+      -> IO ()+fetch verbosity _ _ _ _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++fetch verbosity packageDBs repos comp conf+      globalFlags fetchFlags userTargets = do++    mapM_ checkTarget userTargets++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos++    pkgSpecifiers <- resolveUserTargets verbosity+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       userTargets++    pkgs  <- planPackages+               verbosity comp fetchFlags+               installedPkgIndex sourcePkgDb pkgSpecifiers++    pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs+    if null pkgs'+      --TODO: when we add support for remote tarballs then this message+      -- will need to be changed because for remote tarballs we fetch them+      -- at the earlier phase.+      then notice verbosity $ "No packages need to be fetched. "+                           ++ "All the requested packages are already local "+                           ++ "or cached locally."+      else if dryRun+             then notice verbosity $ unlines $+                     "The following packages would be fetched:"+                   : map (display . packageId) pkgs'++             else mapM_ (fetchPackage verbosity . packageSource) pkgs'++  where+    dryRun = fromFlag (fetchDryRun fetchFlags)++planPackages :: Verbosity+             -> Compiler+             -> FetchFlags+             -> PackageIndex InstalledPackage+             -> SourcePackageDb+             -> [PackageSpecifier SourcePackage]+             -> IO [SourcePackage]+planPackages verbosity comp fetchFlags+             installedPkgIndex sourcePkgDb pkgSpecifiers++  | includeDependencies = do+      notice verbosity "Resolving dependencies..."+      installPlan <- foldProgress logMsg die return $+                       resolveDependencies+                         buildPlatform (compilerId comp)+                         resolverParams++      -- The packages we want to fetch are those packages the 'InstallPlan'+      -- that are in the 'InstallPlan.Configured' state.+      return+        [ pkg+        | (InstallPlan.Configured (InstallPlan.ConfiguredPackage pkg _ _))+            <- InstallPlan.toList installPlan ]++  | otherwise =+      either (die . unlines . map show) return $+        resolveWithoutDependencies resolverParams++  where+    resolverParams =++        -- Reinstall the targets given on the command line so that the dep+        -- resolver will decide that they need fetching, even if they're+        -- already installed. Sicne we want to get the source packages of+        -- things we might have installed (but not have the sources for).+        reinstallTargets++      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers++    includeDependencies = fromFlag (fetchDeps fetchFlags)+    logMsg message rest = debug verbosity message >> rest+++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+    UserTargetRemoteTarball _uri+      -> die $ "The 'fetch' command does not yet support remote tarballs. "+            ++ "In the meantime you can use the 'unpack' commands."+    _ -> return ()++fetchPackage :: Verbosity -> PackageLocation a -> IO ()+fetchPackage verbosity pkgsrc = case pkgsrc of+    LocalUnpackedPackage _dir  -> return ()+    LocalTarballPackage  _file -> return ()++    RemoteTarballPackage _uri _ ->+      die $ "The 'fetch' command does not yet support remote tarballs. "+         ++ "In the meantime you can use the 'unpack' commands."++    RepoTarballPackage repo pkgid _ -> do+      _ <- fetchRepoTarball verbosity repo pkgid+      return ()
+ cabal/cabal-install/Distribution/Client/FetchUtils.hs view
@@ -0,0 +1,193 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.FetchUtils+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Functions for fetching packages+-----------------------------------------------------------------------------+module Distribution.Client.FetchUtils (++    -- * fetching packages+    fetchPackage,+    isFetched,+    checkFetched,++    -- ** specifically for repo packages+    fetchRepoTarball,++    -- * fetching other things+    downloadIndex,+  ) where++import Distribution.Client.Types+import Distribution.Client.HttpUtils+         ( downloadURI, isOldHackageURI )++import Distribution.Package+         ( PackageId, packageName, packageVersion )+import Distribution.Simple.Utils+         ( notice, info, setupMessage )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import Data.Maybe+import System.Directory+         ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory )+import System.IO+         ( openTempFile, hClose )+import System.FilePath+         ( (</>), (<.>) )+import qualified System.FilePath.Posix as FilePath.Posix+         ( combine, joinPath )+import Network.URI+         ( URI(uriPath) )++-- ------------------------------------------------------------+-- * Actually fetch things+-- ------------------------------------------------------------++-- | Returns @True@ if the package has already been fetched+-- or does not need fetching.+--+isFetched :: PackageLocation (Maybe FilePath) -> IO Bool+isFetched loc = case loc of+    LocalUnpackedPackage _dir       -> return True+    LocalTarballPackage  _file      -> return True+    RemoteTarballPackage _uri local -> return (isJust local)+    RepoTarballPackage repo pkgid _ -> doesFileExist (packageFile repo pkgid)+++checkFetched :: PackageLocation (Maybe FilePath)+             -> IO (Maybe (PackageLocation FilePath))+checkFetched loc = case loc of+    LocalUnpackedPackage dir  ->+      return (Just $ LocalUnpackedPackage dir)+    LocalTarballPackage  file ->+      return (Just $ LocalTarballPackage  file)+    RemoteTarballPackage uri (Just file) ->+      return (Just $ RemoteTarballPackage uri file)+    RepoTarballPackage repo pkgid (Just file) ->+      return (Just $ RepoTarballPackage repo pkgid file)++    RemoteTarballPackage _uri Nothing -> return Nothing+    RepoTarballPackage repo pkgid Nothing -> do+      let file = packageFile repo pkgid+      exists <- doesFileExist file+      if exists+        then return (Just $ RepoTarballPackage repo pkgid file)+        else return Nothing+++-- | Fetch a package if we don't have it already.+--+fetchPackage :: Verbosity+             -> PackageLocation (Maybe FilePath)+             -> IO (PackageLocation FilePath)+fetchPackage verbosity loc = case loc of+    LocalUnpackedPackage dir  ->+      return (LocalUnpackedPackage dir)+    LocalTarballPackage  file ->+      return (LocalTarballPackage  file)+    RemoteTarballPackage uri (Just file) ->+      return (RemoteTarballPackage uri file)+    RepoTarballPackage repo pkgid (Just file) ->+      return (RepoTarballPackage repo pkgid file)++    RemoteTarballPackage uri Nothing -> do+      path <- downloadTarballPackage uri+      return (RemoteTarballPackage uri path)+    RepoTarballPackage repo pkgid Nothing -> do+      local <- fetchRepoTarball verbosity repo pkgid+      return (RepoTarballPackage repo pkgid local)+  where+    downloadTarballPackage uri = do+      notice verbosity ("Downloading " ++ show uri)+      tmpdir <- getTemporaryDirectory+      (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"+      hClose hnd+      downloadURI verbosity uri path+      return path+++-- | Fetch a repo package if we don't have it already.+--+fetchRepoTarball :: Verbosity -> Repo -> PackageId -> IO FilePath+fetchRepoTarball verbosity repo pkgid = do+  fetched <- doesFileExist (packageFile repo pkgid)+  if fetched+    then do info verbosity $ display pkgid ++ " has already been downloaded."+            return (packageFile repo pkgid)+    else do setupMessage verbosity "Downloading" pkgid+            downloadRepoPackage+  where+    downloadRepoPackage = case repoKind repo of+      Right LocalRepo -> return (packageFile repo pkgid)++      Left remoteRepo -> do+        let uri  = packageURI remoteRepo pkgid+            dir  = packageDir       repo pkgid+            path = packageFile      repo pkgid+        createDirectoryIfMissing True dir+        downloadURI verbosity uri path+        return path++-- | Downloads an index file to [config-dir/packages/serv-id].+--+downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath+downloadIndex verbosity repo cacheDir = do+  let uri = (remoteRepoURI repo) {+              uriPath = uriPath (remoteRepoURI repo)+                          `FilePath.Posix.combine` "00-index.tar.gz"+            }+      path = cacheDir </> "00-index" <.> "tar.gz"+  createDirectoryIfMissing True cacheDir+  downloadURI verbosity uri path+  return path+++-- ------------------------------------------------------------+-- * Path utilities+-- ------------------------------------------------------------++-- | Generate the full path to the locally cached copy of+-- the tarball for a given @PackageIdentifer@.+--+packageFile :: Repo -> PackageId -> FilePath+packageFile repo pkgid = packageDir repo pkgid+                     </> display pkgid+                     <.> "tar.gz"++-- | Generate the full path to the directory where the local cached copy of+-- the tarball for a given @PackageIdentifer@ is stored.+--+packageDir :: Repo -> PackageId -> FilePath+packageDir repo pkgid = repoLocalDir repo+                    </> display (packageName    pkgid)+                    </> display (packageVersion pkgid)++-- | Generate the URI of the tarball for a given package.+--+packageURI :: RemoteRepo -> PackageId -> URI+packageURI repo pkgid | isOldHackageURI (remoteRepoURI repo) =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,display (packageName    pkgid)+      ,display (packageVersion pkgid)+      ,display pkgid <.> "tar.gz"]+  }+packageURI repo pkgid =+  (remoteRepoURI repo) {+    uriPath = FilePath.Posix.joinPath+      [uriPath (remoteRepoURI repo)+      ,"package"+      ,display pkgid <.> "tar.gz"]+  }
+ cabal/cabal-install/Distribution/Client/GZipUtils.hs view
@@ -0,0 +1,44 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.GZipUtils+-- Copyright   :  (c) Dmitry Astapov 2010+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Provides a convenience functions for working with files that may or may not+-- be zipped.+-----------------------------------------------------------------------------+module Distribution.Client.GZipUtils (+    maybeDecompress,+  ) where++import qualified Data.ByteString.Lazy.Internal as BS (ByteString(..))+import Data.ByteString.Lazy (ByteString)+import Codec.Compression.GZip+import Codec.Compression.Zlib.Internal++-- | Attempts to decompress the `bytes' under the assumption that+-- "data format" error at the very beginning of the stream means+-- that it is already decompressed. Caller should make sanity checks+-- to verify that it is not, in fact, garbage.+--+-- This is to deal with http proxies that lie to us and transparently+-- decompress without removing the content-encoding header. See:+-- <http://hackage.haskell.org/trac/hackage/ticket/686>+--+maybeDecompress :: ByteString -> ByteString+maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes+  where+    -- DataError at the beginning of the stream probably means that stream is not compressed.+    -- Returning it as-is.+    -- TODO: alternatively, we might consider looking for the two magic bytes+    -- at the beginning of the gzip header.+    foldStream (StreamError DataError _) = bytes+    foldStream somethingElse = doFold somethingElse++    doFold StreamEnd               = BS.Empty+    doFold (StreamChunk bs stream) = BS.Chunk bs (doFold stream)+    doFold (StreamError _ msg)  = error $ "Codec.Compression.Zlib: " ++ msg
+ cabal/cabal-install/Distribution/Client/Haddock.hs view
@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Haddock+-- Copyright   :  (c) Andrea Vezzosi 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Interfacing with Haddock+--+-----------------------------------------------------------------------------+module Distribution.Client.Haddock +    (+     regenerateHaddockIndex+    )+    where++import Data.Maybe (listToMaybe)+import Data.List (maximumBy)+import Control.Monad (guard)+import System.Directory (createDirectoryIfMissing, doesFileExist,+                         renameFile)+import System.FilePath ((</>), splitFileName)+import Distribution.Package (Package(..))+import Distribution.Simple.Program (haddockProgram, ProgramConfiguration+                                   , rawSystemProgram, requireProgramVersion)+import Distribution.Version (Version(Version), orLaterVersion)+import Distribution.Verbosity (Verbosity)+import Distribution.Text (display)+import Distribution.Client.PackageIndex(PackageIndex, allPackages,+                                        allPackagesByName, fromList)+import Distribution.Simple.Utils+         ( comparing, intercalate, debug+         , installDirectoryContents, withTempDirectory )+import Distribution.InstalledPackageInfo as InstalledPackageInfo +         ( InstalledPackageInfo+         , InstalledPackageInfo_(haddockHTMLs, haddockInterfaces, exposed) )+import Distribution.Client.Types+         ( InstalledPackage(..) )++regenerateHaddockIndex :: Verbosity -> PackageIndex InstalledPackage -> ProgramConfiguration -> FilePath -> IO ()+regenerateHaddockIndex verbosity pkgs conf index = do+      (paths,warns) <- haddockPackagePaths pkgs'+      case warns of+        Nothing -> return ()+        Just m  -> debug verbosity m+      +      (confHaddock, _, _) <-+          requireProgramVersion verbosity haddockProgram+                                    (orLaterVersion (Version [0,6] [])) conf++      createDirectoryIfMissing True destDir++      withTempDirectory verbosity destDir "tmphaddock" $ \tempDir -> do++        let flags = [ "--gen-contents"+                    , "--gen-index"+                    , "--odir=" ++ tempDir+                    , "--title=Haskell modules on this system" ]+                 ++ [ "--read-interface=" ++ html ++ "," ++ interface+                    | (interface, html) <- paths ]+        rawSystemProgram verbosity confHaddock flags+        renameFile (tempDir </> "index.html") (tempDir </> destFile)+        installDirectoryContents verbosity tempDir destDir+      +  where +    (destDir,destFile) = splitFileName index+    pkgs' = map (maximumBy $ comparing packageId) +            . allPackagesByName +            . fromList+            . filter exposed+            . map (\(InstalledPackage pkg _) -> pkg)+            . allPackages+            $ pkgs++haddockPackagePaths :: [InstalledPackageInfo]+                       -> IO ([(FilePath, FilePath)], Maybe String)+haddockPackagePaths pkgs = do+  interfaces <- sequence+    [ case interfaceAndHtmlPath pkg of+        Just (interface, html) -> do+          exists <- doesFileExist interface+          if exists+            then return (pkgid, Just (interface, html))+            else return (pkgid, Nothing)+        Nothing -> return (pkgid, Nothing)+    | pkg <- pkgs, let pkgid = packageId pkg ]++  let missing = [ pkgid | (pkgid, Nothing) <- interfaces ]++      warning = "The documentation for the following packages are not "+             ++ "installed. No links will be generated to these packages: "+             ++ intercalate ", " (map display missing)++      flags = [ x | (_, Just x) <- interfaces ]++  return (flags, if null missing then Nothing else Just warning)++  where+    interfaceAndHtmlPath pkg = do+      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)+      html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)+      guard (not . null $ html)+      return (interface, html)
+ cabal/cabal-install/Distribution/Client/HttpUtils.hs view
@@ -0,0 +1,197 @@+{-# OPTIONS -cpp #-}+-----------------------------------------------------------------------------+-- | Separate module for HTTP actions, using a proxy server if one exists +-----------------------------------------------------------------------------+module Distribution.Client.HttpUtils (+    downloadURI,+    getHTTP,+    proxy,+    isOldHackageURI+  ) where++import Network.HTTP+         ( Request (..), Response (..), RequestMethod (..)+         , Header(..), HeaderName(..) )+import Network.URI+         ( URI (..), URIAuth (..), parseAbsoluteURI )+import Network.Stream+         ( Result, ConnError(..) )+import Network.Browser+         ( Proxy (..), Authority (..), browse+         , setOutHandler, setErrHandler, setProxy, request)+import Control.Monad+         ( mplus, join, liftM2 )+import qualified Data.ByteString.Lazy.Char8 as ByteString+import Data.ByteString.Lazy (ByteString)+#ifdef WIN32+import System.Win32.Types+         ( DWORD, HKEY )+import System.Win32.Registry+         ( hKEY_CURRENT_USER, regOpenKey, regCloseKey+         , regQueryValue, regQueryValueEx )+import Control.Exception+         ( bracket )+import Distribution.Compat.ExceptionCI+         ( handleIO )+import Foreign+         ( toBool, Storable(peek, sizeOf), castPtr, alloca )+#endif+import System.Environment (getEnvironment)++import qualified Paths_cabal_install (version)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils+         ( die, info, warn, debug+         , copyFileVerbose, writeFileAtomic )+import Distribution.Text+         ( display )+import qualified System.FilePath.Posix as FilePath.Posix+         ( splitDirectories )++-- FIXME: all this proxy stuff is far too complicated, especially parsing+-- the proxy strings. Network.Browser should have a way to pick up the+-- proxy settings hiding all this system-dependent stuff below.++-- try to read the system proxy settings on windows or unix+proxyString, envProxyString, registryProxyString :: IO (Maybe String)+#ifdef WIN32+-- read proxy settings from the windows registry+registryProxyString = handleIO (\_ -> return Nothing) $+  bracket (regOpenKey hive path) regCloseKey $ \hkey -> do+    enable <- fmap toBool $ regQueryValueDWORD hkey "ProxyEnable"+    if enable+        then fmap Just $ regQueryValue hkey (Just "ProxyServer")+        else return Nothing+  where+    -- some sources say proxy settings should be at +    -- HKEY_LOCAL_MACHINE\SOFTWARE\Policies\Microsoft\Windows+    --                   \CurrentVersion\Internet Settings\ProxyServer+    -- but if the user sets them with IE connection panel they seem to+    -- end up in the following place:+    hive  = hKEY_CURRENT_USER+    path = "Software\\Microsoft\\Windows\\CurrentVersion\\Internet Settings"++    regQueryValueDWORD :: HKEY -> String -> IO DWORD+    regQueryValueDWORD hkey name = alloca $ \ptr -> do+      regQueryValueEx hkey name (castPtr ptr) (sizeOf (undefined :: DWORD))+      peek ptr+#else+registryProxyString = return Nothing+#endif++-- read proxy settings by looking for an env var+envProxyString = do+  env <- getEnvironment+  return (lookup "http_proxy" env `mplus` lookup "HTTP_PROXY" env)++proxyString = liftM2 mplus envProxyString registryProxyString+++-- |Get the local proxy settings  +proxy :: Verbosity -> IO Proxy+proxy verbosity = do+  mstr <- proxyString+  case mstr of+    Nothing   -> return NoProxy+    Just str  -> case parseHttpProxy str of+      Nothing -> do+        warn verbosity $ "invalid http proxy uri: " ++ show str+        warn verbosity $ "proxy uri must be http with a hostname"+        warn verbosity $ "ignoring http proxy, trying a direct connection"+        return NoProxy+      Just p  -> return p+--TODO: print info message when we're using a proxy++-- | We need to be able to parse non-URIs like @\"wwwcache.example.com:80\"@+-- which lack the @\"http://\"@ URI scheme. The problem is that+-- @\"wwwcache.example.com:80\"@ is in fact a valid URI but with scheme+-- @\"wwwcache.example.com:\"@, no authority part and a path of @\"80\"@.+--+-- So our strategy is to try parsing as normal uri first and if it lacks the+-- 'uriAuthority' then we try parsing again with a @\"http://\"@ prefix.+--+parseHttpProxy :: String -> Maybe Proxy+parseHttpProxy str = join+                   . fmap uri2proxy+                   $ parseHttpURI str+             `mplus` parseHttpURI ("http://" ++ str)+  where+    parseHttpURI str' = case parseAbsoluteURI str' of+      Just uri@URI { uriAuthority = Just _ }+         -> Just (fixUserInfo uri)+      _  -> Nothing++fixUserInfo :: URI -> URI+fixUserInfo uri = uri{ uriAuthority = f `fmap` uriAuthority uri }+    where+      f a@URIAuth{ uriUserInfo = s } =+          a{ uriUserInfo = case reverse s of+                             '@':s' -> reverse s'+                             _      -> s+           }+uri2proxy :: URI -> Maybe Proxy+uri2proxy uri@URI{ uriScheme = "http:"+                 , uriAuthority = Just (URIAuth auth' host port)+                 } = Just (Proxy (host ++ port) auth)+  where auth = if null auth'+                 then Nothing+                 else Just (AuthBasic "" usr pwd uri)+        (usr,pwd') = break (==':') auth'+        pwd        = case pwd' of+                       ':':cs -> cs+                       _      -> pwd'+uri2proxy _ = Nothing++mkRequest :: URI -> Request ByteString+mkRequest uri = Request{ rqURI     = uri+                       , rqMethod  = GET+                       , rqHeaders = [Header HdrUserAgent userAgent]+                       , rqBody    = ByteString.empty }+  where userAgent = "cabal-install/" ++ display Paths_cabal_install.version++-- |Carry out a GET request, using the local proxy settings+getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))+getHTTP verbosity uri = do+                 p   <- proxy verbosity+                 let req = mkRequest uri+                 (_, resp) <- browse $ do+                                setErrHandler (warn verbosity . ("http error: "++))+                                setOutHandler (debug verbosity)+                                setProxy p+                                request req+                 return (Right resp)++downloadURI :: Verbosity+            -> URI      -- ^ What to download+            -> FilePath -- ^ Where to put it+            -> IO ()+downloadURI verbosity uri path | uriScheme uri == "file:" =+  copyFileVerbose verbosity (uriPath uri) path+downloadURI verbosity uri path = do+  result <- getHTTP verbosity uri+  let result' = case result of+        Left  err -> Left err+        Right rsp -> case rspCode rsp of+          (2,0,0) -> Right (rspBody rsp)+          (a,b,c) -> Left err+            where+              err = ErrorMisc $ "Unsucessful HTTP code: "+                             ++ concatMap show [a,b,c]++  case result' of+    Left err   -> die $ "Failed to download " ++ show uri ++ " : " ++ show err+    Right body -> do+      info verbosity ("Downloaded to " ++ path)+      writeFileAtomic path (ByteString.unpack body)+      --FIXME: check the content-length header matches the body length.+      --TODO: stream the download into the file rather than buffering the whole+      --      thing in memory.+      --      remember the ETag so we can not re-download if nothing changed.++-- Utility function for legacy support.+isOldHackageURI :: URI -> Bool+isOldHackageURI uri+    = case uriAuthority uri of+        Just (URIAuth {uriRegName = "hackage.haskell.org"}) ->+            FilePath.Posix.splitDirectories (uriPath uri) == ["/","packages","archive"]+        _ -> False
+ cabal/cabal-install/Distribution/Client/IndexUtils.hs view
@@ -0,0 +1,270 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.IndexUtils+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Extra utils related to the package indexes.+-----------------------------------------------------------------------------+module Distribution.Client.IndexUtils (+  getInstalledPackages,+  getSourcePackages,++  readPackageIndexFile,+  parseRepoIndex,+  ) where++import qualified Distribution.Client.Tar as Tar+import Distribution.Client.Types++import Distribution.Package+         ( PackageId, PackageIdentifier(..), PackageName(..)+         , Package(..), packageVersion+         , Dependency(Dependency), InstalledPackageId(..) )+import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Client.PackageIndex as PackageIndex+import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+import Distribution.PackageDescription+         ( GenericPackageDescription )+import Distribution.PackageDescription.Parse+         ( parsePackageDescription )+import Distribution.Simple.Compiler+         ( Compiler, PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration )+import qualified Distribution.Simple.Configure as Configure+         ( getInstalledPackages )+import Distribution.ParseUtils+         ( ParseResult(..) )+import Distribution.Version+         ( Version(Version), intersectVersionRanges )+import Distribution.Text+         ( simpleParse )+import Distribution.Verbosity+         ( Verbosity, lessVerbose )+import Distribution.Simple.Utils+         ( warn, info, fromUTF8, equating )++import Data.Maybe  (catMaybes, fromMaybe)+import Data.List   (isPrefixOf, groupBy)+import Data.Monoid (Monoid(..))+import qualified Data.Map as Map+import Control.Monad (MonadPlus(mplus), when)+import Control.Exception (evaluate)+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.ByteString.Lazy (ByteString)+import Distribution.Client.GZipUtils (maybeDecompress)+import System.FilePath ((</>), takeExtension, splitDirectories, normalise)+import System.FilePath.Posix as FilePath.Posix+         ( takeFileName )+import System.IO.Error (isDoesNotExistError)+import System.Directory+         ( getModificationTime )+import System.Time+         ( getClockTime, diffClockTimes, normalizeTimeDiff, TimeDiff(tdDay) )++getInstalledPackages :: Verbosity -> Compiler+                     -> PackageDBStack -> ProgramConfiguration+                     -> IO (PackageIndex InstalledPackage)+getInstalledPackages verbosity comp packageDbs conf =+    fmap convert (Configure.getInstalledPackages verbosity'+                                                 comp packageDbs conf)+  where+    --FIXME: make getInstalledPackages use sensible verbosity in the first place+    verbosity'  = lessVerbose verbosity++    convert :: InstalledPackageIndex.PackageIndex -> PackageIndex InstalledPackage+    convert index = PackageIndex.fromList+      -- There can be multiple installed instances of each package version,+      -- like when the same package is installed in the global & user dbs.+      -- InstalledPackageIndex.allPackagesByName gives us the installed+      -- packages with the most preferred instances first, so by picking the+      -- first we should get the user one. This is almost but not quite the+      -- same as what ghc does.+      [ InstalledPackage ipkg (sourceDeps index ipkg)+      | ipkgs <- InstalledPackageIndex.allPackagesByName index+      , (ipkg:_) <- groupBy (equating packageVersion) ipkgs ]++    -- The InstalledPackageInfo only lists dependencies by the+    -- InstalledPackageId, which means we do not directly know the corresponding+    -- source dependency. The only way to find out is to lookup the+    -- InstalledPackageId to get the InstalledPackageInfo and look at its+    -- source PackageId. But if the package is broken because it depends on+    -- other packages that do not exist then we have a problem we cannot find+    -- the original source package id. Instead we make up a bogus package id.+    -- This should have the same effect since it should be a dependency on a+    -- non-existant package.+    sourceDeps index ipkg =+      [ maybe (brokenPackageId depid) packageId mdep+      | let depids = InstalledPackageInfo.depends ipkg+            getpkg = InstalledPackageIndex.lookupInstalledPackageId index+      , (depid, mdep) <- zip depids (map getpkg depids) ]++    brokenPackageId (InstalledPackageId str) =+      PackageIdentifier (PackageName (str ++ "-broken")) (Version [] [])++-- | Read a repository index from disk, from the local files specified by+-- a list of 'Repo's.+--+-- All the 'SourcePackage's are marked as having come from the appropriate+-- 'Repo'.+--+-- This is a higher level wrapper used internally in cabal-install.+--+getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb+getSourcePackages verbosity [] = do+  warn verbosity $ "No remote package servers have been specified. Usually "+                ++ "you would have one specified in the config file."+  return SourcePackageDb {+    packageIndex       = mempty,+    packagePreferences = mempty+  }+getSourcePackages verbosity repos = do+  info verbosity "Reading available packages..."+  pkgss <- mapM (readRepoIndex verbosity) repos+  let (pkgs, prefs) = mconcat pkgss+      prefs' = Map.fromListWith intersectVersionRanges+                 [ (name, range) | Dependency name range <- prefs ]+  _ <- evaluate pkgs+  _ <- evaluate prefs'+  return SourcePackageDb {+    packageIndex       = pkgs,+    packagePreferences = prefs'+  }++-- | Read a repository index from disk, from the local file specified by+-- the 'Repo'.+--+-- All the 'SourcePackage's are marked as having come from the given 'Repo'.+--+-- This is a higher level wrapper used internally in cabal-install.+--+readRepoIndex :: Verbosity -> Repo+              -> IO (PackageIndex SourcePackage, [Dependency])+readRepoIndex verbosity repo = handleNotFound $ do+  let indexFile = repoLocalDir repo </> "00-index.tar"+  (pkgs, prefs) <- either fail return+                 . foldlTarball extract ([], [])+               =<< BS.readFile indexFile++  pkgIndex <- evaluate $ PackageIndex.fromList+    [ SourcePackage {+        packageInfoId      = pkgid,+        packageDescription = pkg,+        packageSource      = RepoTarballPackage repo pkgid Nothing+      }+    | (pkgid, pkg) <- pkgs]++  warnIfIndexIsOld indexFile+  return (pkgIndex, prefs)++  where+    extract (pkgs, prefs) entry = fromMaybe (pkgs, prefs) $+              (do pkg <- extractPkg entry; return (pkg:pkgs, prefs))+      `mplus` (do prefs' <- extractPrefs entry; return (pkgs, prefs'++prefs))++    extractPrefs :: Tar.Entry -> Maybe [Dependency]+    extractPrefs entry = case Tar.entryContent entry of+    {-+     -- get rid of hackage's preferred-versions+     -- I'd like to have bleeding-edge packages in system and I don't fear of+     -- broken packages with improper depends+      Tar.NormalFile content _+         | takeFileName (Tar.entryPath entry) == "preferred-versions"+        -> Just . parsePreferredVersions+         . BS.Char8.unpack $ content+    -}+      _ -> Nothing++    handleNotFound action = catch action $ \e -> if isDoesNotExistError e+      then do+        case repoKind repo of+          Left  remoteRepo -> warn verbosity $+               "The package list for '" ++ remoteRepoName remoteRepo+            ++ "' does not exist. Run 'hackport update' to download it."+          Right _localRepo -> warn verbosity $+               "The package list for the local repo '" ++ repoLocalDir repo+            ++ "' is missing. The repo is invalid."+        return mempty+      else ioError e++    isOldThreshold = 15 --days+    warnIfIndexIsOld indexFile = do+      indexTime   <- getModificationTime indexFile+      currentTime <- getClockTime+      let diff = normalizeTimeDiff (diffClockTimes currentTime indexTime)+      when (tdDay diff >= isOldThreshold) $ case repoKind repo of+        Left  remoteRepo -> warn verbosity $+             "The package list for '" ++ remoteRepoName remoteRepo+          ++ "' is " ++ show (tdDay diff)  ++ " days old.\nRun "+          ++ "'hackport update' to get the latest list of available packages."+        Right _localRepo -> return ()++parsePreferredVersions :: String -> [Dependency]+parsePreferredVersions = catMaybes+                       . map simpleParse+                       . filter (not . isPrefixOf "--")+                       . lines++-- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'.+--+-- This is supposed to be an \"all in one\" way to easily get at the info in+-- the hackage package index.+--+-- It takes a function to map a 'GenericPackageDescription' into any more+-- specific instance of 'Package' that you might want to use. In the simple+-- case you can just use @\_ p -> p@ here.+--+readPackageIndexFile :: Package pkg+                     => (PackageId -> GenericPackageDescription -> pkg)+                     -> FilePath -> IO (PackageIndex pkg)+readPackageIndexFile mkPkg indexFile = do+  pkgs <- either fail return+        . parseRepoIndex+        . maybeDecompress+      =<< BS.readFile indexFile+  +  evaluate $ PackageIndex.fromList+   [ mkPkg pkgid pkg | (pkgid, pkg) <- pkgs]++-- | Parse an uncompressed \"00-index.tar\" repository index file represented+-- as a 'ByteString'.+--+parseRepoIndex :: ByteString+               -> Either String [(PackageId, GenericPackageDescription)]+parseRepoIndex = foldlTarball (\pkgs -> maybe pkgs (:pkgs) . extractPkg) []++extractPkg :: Tar.Entry -> Maybe (PackageId, GenericPackageDescription)+extractPkg entry = case Tar.entryContent entry of+  Tar.NormalFile content _+     | takeExtension fileName == ".cabal"+    -> case splitDirectories (normalise fileName) of+        [pkgname,vers,_] -> case simpleParse vers of+          Just ver -> Just (pkgid, descr)+            where+              pkgid  = PackageIdentifier (PackageName pkgname) ver+              parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack+                                               $ content+              descr  = case parsed of+                ParseOk _ d -> d+                _           -> error $ "Couldn't read cabal file "+                                    ++ show fileName+          _ -> Nothing+        _ -> Nothing+  _ -> Nothing+  where+    fileName = Tar.entryPath entry++foldlTarball :: (a -> Tar.Entry -> a) -> a+             -> ByteString -> Either String a+foldlTarball f z = either Left (Right . foldl f z) . check [] . Tar.read+  where+    check _  (Tar.Fail err)  = Left  err+    check ok Tar.Done        = Right ok+    check ok (Tar.Next e es) = check (e:ok) es
+ cabal/cabal-install/Distribution/Client/Init.hs view
@@ -0,0 +1,603 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init+-- Copyright   :  (c) Brent Yorgey 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Implementation of the 'cabal init' command, which creates an initial .cabal+-- file for a project.+--+-----------------------------------------------------------------------------++module Distribution.Client.Init (++    -- * Commands+    initCabal++  ) where++import System.IO+  ( hSetBuffering, stdout, BufferMode(..) )+import System.Directory+  ( getCurrentDirectory )+import Data.Time+  ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone )++import Data.List+  ( intersperse, (\\) )+import Data.Maybe+  ( fromMaybe, isJust )+import Data.Traversable+  ( traverse )+import Control.Monad+  ( when )+#if MIN_VERSION_base(3,0,0)+import Control.Monad+  ( (>=>), join )+#endif++import Text.PrettyPrint.HughesPJ hiding (mode, cat)++import Data.Version+  ( Version(..) )+import Distribution.Version+  ( orLaterVersion )++import Distribution.Client.Init.Types+  ( InitFlags(..), PackageType(..), Category(..) )+import Distribution.Client.Init.Licenses+  ( bsd3, gplv2, gplv3, lgpl2, lgpl3 )+import Distribution.Client.Init.Heuristics+  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms )++import Distribution.License+  ( License(..), knownLicenses )+import Distribution.ModuleName+  ( ) -- for the Text instance++import Distribution.ReadE+  ( runReadE, readP_to_E )+import Distribution.Simple.Setup+  ( Flag(..), flagToMaybe )+import Distribution.Text+  ( display, Text(..) )++initCabal :: InitFlags -> IO ()+initCabal initFlags = do+  hSetBuffering stdout NoBuffering++  initFlags' <- extendFlags initFlags++  writeLicense initFlags'+  writeSetupFile initFlags'+  success <- writeCabalFile initFlags'++  when success $ generateWarnings initFlags'++---------------------------------------------------------------------------+--  Flag acquisition  -----------------------------------------------------+---------------------------------------------------------------------------++-- | Fill in more details by guessing, discovering, or prompting the+--   user.+extendFlags :: InitFlags -> IO InitFlags+extendFlags =  getPackageName+           >=> getVersion+           >=> getLicense+           >=> getAuthorInfo+           >=> getHomepage+           >=> getSynopsis+           >=> getCategory+           >=> getLibOrExec+           >=> getGenComments+           >=> getSrcDir+           >=> getModulesAndBuildTools++-- | Combine two actions which may return a value, preferring the first. That+--   is, run the second action only if the first doesn't return a value.+infixr 1 ?>>+(?>>) :: IO (Maybe a) -> IO (Maybe a) -> IO (Maybe a)+f ?>> g = do+  ma <- f+  if isJust ma+    then return ma+    else g++-- | Witness the isomorphism between Maybe and Flag.+maybeToFlag :: Maybe a -> Flag a+maybeToFlag = maybe NoFlag Flag++-- | Get the package name: use the package directory (supplied, or the current+--   directory by default) as a guess.+getPackageName :: InitFlags -> IO InitFlags+getPackageName flags = do+  guess    <-     traverse guessPackageName (flagToMaybe $ packageDir flags)+              ?>> Just `fmap` (getCurrentDirectory >>= guessPackageName)++  pkgName' <-     return (flagToMaybe $ packageName flags)+              ?>> maybePrompt flags (promptStr "Package name" guess)+              ?>> return guess++  return $ flags { packageName = maybeToFlag pkgName' }++-- | Package version: use 0.1 as a last resort, but try prompting the user if+--   possible.+getVersion :: InitFlags -> IO InitFlags+getVersion flags = do+  let v = Just $ Version { versionBranch = [0,1], versionTags = [] }+  v' <-     return (flagToMaybe $ version flags)+        ?>> maybePrompt flags (prompt "Package version" v)+        ?>> return v+  return $ flags { version = maybeToFlag v' }++-- | Choose a license.+getLicense :: InitFlags -> IO InitFlags+getLicense flags = do+  lic <-     return (flagToMaybe $ license flags)+         ?>> fmap (fmap (either UnknownLicense id) . join)+                  (maybePrompt flags+                    (promptListOptional "Please choose a license" listedLicenses))+  return $ flags { license = maybeToFlag lic }+  where+    listedLicenses =+      knownLicenses \\ [GPL Nothing, LGPL Nothing, OtherLicense]++-- | The author's name and email. Prompt, or try to guess from an existing+--   darcs repo.+getAuthorInfo :: InitFlags -> IO InitFlags+getAuthorInfo flags = do+  (authorName, authorEmail)  <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail+  authorName'  <-     return (flagToMaybe $ author flags)+                  ?>> maybePrompt flags (promptStr "Author name" authorName)+                  ?>> return authorName++  authorEmail' <-     return (flagToMaybe $ email flags)+                  ?>> maybePrompt flags (promptStr "Maintainer email" authorEmail)+                  ?>> return authorEmail++  return $ flags { author = maybeToFlag authorName'+                 , email  = maybeToFlag authorEmail'+                 }++-- | Prompt for a homepage URL.+getHomepage :: InitFlags -> IO InitFlags+getHomepage flags = do+  hp  <- queryHomepage+  hp' <-     return (flagToMaybe $ homepage flags)+         ?>> maybePrompt flags (promptStr "Project homepage/repo URL" hp)+         ?>> return hp++  return $ flags { homepage = maybeToFlag hp' }++-- | Right now this does nothing, but it could be changed to do some+--   intelligent guessing.+queryHomepage :: IO (Maybe String)+queryHomepage = return Nothing     -- get default remote darcs repo?++-- | Prompt for a project synopsis.+getSynopsis :: InitFlags -> IO InitFlags+getSynopsis flags = do+  syn <-     return (flagToMaybe $ synopsis flags)+         ?>> maybePrompt flags (promptStr "Project synopsis" Nothing)++  return $ flags { synopsis = maybeToFlag syn }++-- | Prompt for a package category.+--   Note that it should be possible to do some smarter guessing here too, i.e.+--   look at the name of the top level source directory.+getCategory :: InitFlags -> IO InitFlags+getCategory flags = do+  cat <-     return (flagToMaybe $ category flags)+         ?>> fmap join (maybePrompt flags+                         (promptListOptional "Project category" [Codec ..]))+  return $ flags { category = maybeToFlag cat }++-- | Ask whether the project builds a library or executable.+getLibOrExec :: InitFlags -> IO InitFlags+getLibOrExec flags = do+  isLib <-     return (flagToMaybe $ packageType flags)+           ?>> maybePrompt flags (either (const Library) id `fmap`+                                   (promptList "What does the package build"+                                               [Library, Executable]+                                               Nothing display False))+           ?>> return (Just Library)++  return $ flags { packageType = maybeToFlag isLib }++-- | Ask whether to generate explanitory comments.+getGenComments :: InitFlags -> IO InitFlags+getGenComments flags = do+  genComments <-     return (flagToMaybe $ noComments flags)+                 ?>> maybePrompt flags (promptYesNo promptMsg (Just False))+                 ?>> return (Just False)+  return $ flags { noComments = maybeToFlag (fmap not genComments) }+  where+    promptMsg = "Include documentation on what each field means y/n"++-- | Try to guess the source root directory (don't prompt the user).+getSrcDir :: InitFlags -> IO InitFlags+getSrcDir flags = do+  srcDirs <-     return (sourceDirs flags)+             ?>> guessSourceDirs++  return $ flags { sourceDirs = srcDirs }++-- XXX+-- | Try to guess source directories.+guessSourceDirs :: IO (Maybe [String])+guessSourceDirs = return Nothing++-- | Get the list of exposed modules and extra tools needed to build them.+getModulesAndBuildTools :: InitFlags -> IO InitFlags+getModulesAndBuildTools flags = do+  dir <- fromMaybe getCurrentDirectory+                   (fmap return . flagToMaybe $ packageDir flags)++  -- XXX really should use guessed source roots.+  sourceFiles <- scanForModules dir++  mods <-      return (exposedModules flags)+           ?>> (return . Just . map moduleName $ sourceFiles)++  tools <-     return (buildTools flags)+           ?>> (return . Just . neededBuildPrograms $ sourceFiles)++  return $ flags { exposedModules = mods+                 , buildTools     = tools }++---------------------------------------------------------------------------+--  Prompting/user interaction  -------------------------------------------+---------------------------------------------------------------------------++-- | Run a prompt or not based on the nonInteractive flag of the+--   InitFlags structure.+maybePrompt :: InitFlags -> IO t -> IO (Maybe t)+maybePrompt flags p =+  case nonInteractive flags of+    Flag True -> return Nothing+    _         -> Just `fmap` p++-- | Create a prompt with optional default value that returns a+--   String.+promptStr :: String -> Maybe String -> IO String+promptStr = promptDefault' Just id++-- | Create a yes/no prompt with optional default value.+--+promptYesNo :: String -> Maybe Bool -> IO Bool+promptYesNo =+    promptDefault' recogniseYesNo showYesNo+  where+    recogniseYesNo s | s == "y" || s == "Y" = Just True+                     | s == "n" || s == "N" = Just False+                     | otherwise            = Nothing+    showYesNo True  = "y"+    showYesNo False = "n"++-- | Create a prompt with optional default value that returns a value+--   of some Text instance.+prompt :: Text t => String -> Maybe t -> IO t+prompt = promptDefault'+           (either (const Nothing) Just . runReadE (readP_to_E id parse))+           display++-- | Create a prompt with an optional default value.+promptDefault' :: (String -> Maybe t)       -- ^ parser+               -> (t -> String)             -- ^ pretty-printer+               -> String                    -- ^ prompt message+               -> Maybe t                   -- ^ optional default value+               -> IO t+promptDefault' parser pretty pr def = do+  putStr $ mkDefPrompt pr (pretty `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d)  -> return d+    _  -> case parser inp of+            Just t  -> return t+            Nothing -> do putStrLn $ "Couldn't parse " ++ inp ++ ", please try again!"+                          promptDefault' parser pretty pr def++-- | Create a prompt from a prompt string and a String representation+--   of an optional default value.+mkDefPrompt :: String -> Maybe String -> String+mkDefPrompt pr def = pr ++ "?" ++ defStr def+  where defStr Nothing  = " "+        defStr (Just s) = " [default: " ++ s ++ "] "++promptListOptional :: (Text t, Eq t)+                   => String            -- ^ prompt+                   -> [t]               -- ^ choices+                   -> IO (Maybe (Either String t))+promptListOptional pr choices =+    fmap rearrange+  $ promptList pr (Nothing : map Just choices) (Just Nothing)+               (maybe "(none)" display) True+  where+    rearrange = either (Just . Left) (maybe Nothing (Just . Right))++-- | Create a prompt from a list of items.+promptList :: Eq t+           => String            -- ^ prompt+           -> [t]               -- ^ choices+           -> Maybe t           -- ^ optional default value+           -> (t -> String)     -- ^ show an item+           -> Bool              -- ^ whether to allow an 'other' option+           -> IO (Either String t)+promptList pr choices def displayItem other = do+  putStrLn $ pr ++ ":"+  let options1 = map (\c -> (Just c == def, displayItem c)) choices+      options2 = zip ([1..]::[Int])+                     (options1 ++ if other then [(False, "Other (specify)")]+                                           else [])+  mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2+  promptList' displayItem (length options2) choices def other+ where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest+                      | otherwise = " " ++ star i ++ rest+                  where rest = show n ++ ") "+                        star True = "*"+                        star False = " "++promptList' :: (t -> String) -> Int -> [t] -> Maybe t -> Bool -> IO (Either String t)+promptList' displayItem numChoices choices def other = do+  putStr $ mkDefPrompt "Your choice" (displayItem `fmap` def)+  inp <- getLine+  case (inp, def) of+    ("", Just d) -> return $ Right d+    _  -> case readMaybe inp of+            Nothing -> invalidChoice inp+            Just n  -> getChoice n+ where invalidChoice inp = do putStrLn $ inp ++ " is not a valid choice."+                              promptList' displayItem numChoices choices def other+       getChoice n | n < 1 || n > numChoices = invalidChoice (show n)+                   | n < numChoices ||+                     (n == numChoices && not other)+                                  = return . Right $ choices !! (n-1)+                   | otherwise    = Left `fmap` promptStr "Please specify" Nothing++readMaybe :: (Read a) => String -> Maybe a+readMaybe s = case reads s of+                [(a,"")] -> Just a+                _        -> Nothing++---------------------------------------------------------------------------+--  File generation  ------------------------------------------------------+---------------------------------------------------------------------------++writeLicense :: InitFlags -> IO ()+writeLicense flags = do+  message flags "Generating LICENSE..."+  year <- getYear+  let licenseFile =+        case license flags of+          Flag BSD3 -> Just $ bsd3 (fromMaybe "???"+                                  . flagToMaybe+                                  . author+                                  $ flags)+                              (show year)++          Flag (GPL (Just (Version {versionBranch = [2]})))+            -> Just gplv2++          Flag (GPL (Just (Version {versionBranch = [3]})))+            -> Just gplv3++          Flag (LGPL (Just (Version {versionBranch = [2]})))+            -> Just lgpl2++          Flag (LGPL (Just (Version {versionBranch = [3]})))+            -> Just lgpl3++          _ -> Nothing++  case licenseFile of+    Just licenseText -> writeFile "LICENSE" licenseText+    Nothing -> message flags "Warning: unknown license type, you must put a copy in LICENSE yourself."++getYear :: IO Integer+getYear = do+  u <- getCurrentTime+  z <- getCurrentTimeZone+  let l = utcToLocalTime z u+      (y, _, _) = toGregorian $ localDay l+  return y++writeSetupFile :: InitFlags -> IO ()+writeSetupFile flags = do+  message flags "Generating Setup.hs..."+  writeFile "Setup.hs" setupFile+ where+  setupFile = unlines+    [ "import Distribution.Simple"+    , "main = defaultMain"+    ]++writeCabalFile :: InitFlags -> IO Bool+writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do+  message flags "Error: no package name provided."+  return False+writeCabalFile flags@(InitFlags{packageName = Flag p}) = do+  let cabalFileName = p ++ ".cabal"+  message flags $ "Generating " ++ cabalFileName ++ "..."+  writeFile cabalFileName (generateCabalFile cabalFileName flags)+  return True++-- | Generate a .cabal file from an InitFlags structure.  NOTE: this+--   is rather ad-hoc!  What we would REALLY like is to have a+--   standard low-level AST type representing .cabal files, which+--   preserves things like comments, and to write an *inverse*+--   parser/pretty-printer pair between .cabal files and this AST.+--   Then instead of this ad-hoc code we could just map an InitFlags+--   structure onto a low-level AST structure and use the existing+--   pretty-printing code to generate the file.+generateCabalFile :: String -> InitFlags -> String+generateCabalFile fileName c =+  renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $+  (if (minimal c /= Flag True)+    then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "+                          ++ "init.  For further documentation, see "+                          ++ "http://haskell.org/cabal/users-guide/")+         $$ text ""+    else empty)+  $$+  vcat [ fieldS "name"          (packageName   c)+                (Just "The name of the package.")+                True++       , field  "version"       (version       c)+                (Just "The package version.  See the Haskell package versioning policy (http://www.haskell.org/haskellwiki/Package_versioning_policy) for standards guiding when and how versions should be incremented.")+                True++       , fieldS "synopsis"      (synopsis      c)+                (Just "A short (one-line) description of the package.")+                True++       , fieldS "description"   NoFlag+                (Just "A longer description of the package.")+                True++       , fieldS "homepage"      (homepage     c)+                (Just "URL for the project homepage or repository.")+                False++       , fieldS "bug-reports"   NoFlag+                (Just "A URL where users can report bugs.")+                False++       , field  "license"       (license      c)+                (Just "The license under which the package is released.")+                True++       , fieldS "license-file" (Flag "LICENSE")+                (Just "The file containing the license text.")+                True++       , fieldS "author"        (author       c)+                (Just "The package author(s).")+                True++       , fieldS "maintainer"    (email        c)+                (Just "An email address to which users can send suggestions, bug reports, and patches.")+                True++       , fieldS "copyright"     NoFlag+                (Just "A copyright notice.")+                True++       , fieldS "category"      (either id display `fmap` category c)+                Nothing+                True++       , fieldS "build-type"    (Flag "Simple")+                Nothing+                True++       , fieldS "extra-source-files" NoFlag+                (Just "Extra files to be distributed with the package, such as examples or a README.")+                False++       , field  "cabal-version" (Flag $ orLaterVersion (Version [1,8] []))+                (Just "Constraint on the version of Cabal needed to build this package.")+                False++       , case packageType c of+           Flag Executable ->+             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat+             [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True++             , generateBuildInfo Executable c+             ])+           Flag Library    -> text "\nlibrary" $$ (nest 2 $ vcat+             [ fieldS "exposed-modules" (listField (exposedModules c))+                      (Just "Modules exported by the library.")+                      True++             , generateBuildInfo Library c+             ])+           _               -> empty+       ]+ where+   generateBuildInfo :: PackageType -> InitFlags -> Doc+   generateBuildInfo pkgtype c' = vcat+     [ fieldS "other-modules" (listField (otherModules c'))+              (Just $ case pkgtype of+                 Library    -> "Modules included in this library but not exported."+                 Executable -> "Modules included in this executable, other than Main.")+              True++     , fieldS "build-depends" (listField (dependencies c'))+              (Just "Other library packages from which modules are imported.")+              True++     , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))+              (Just "Directories containing source files.")+              False++     , fieldS "build-tools" (listFieldS (buildTools c'))+              (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")+              False+     ]++   listField :: Text s => Maybe [s] -> Flag String+   listField = listFieldS . fmap (map display)++   listFieldS :: Maybe [String] -> Flag String+   listFieldS = Flag . maybe "" (concat . intersperse ", ")++   field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc+   field s f = fieldS s (fmap display f)++   fieldS :: String        -- ^ Name of the field+          -> Flag String   -- ^ Field contents+          -> Maybe String  -- ^ Comment to explain the field+          -> Bool          -- ^ Should the field be included (commented out) even if blank?+          -> Doc+   fieldS _ NoFlag _    inc | not inc || (minimal c == Flag True) = empty+   fieldS _ (Flag "") _ inc | not inc || (minimal c == Flag True) = empty+   fieldS s f com _ = case (isJust com, noComments c, minimal c) of+                        (_, _, Flag True) -> id+                        (_, Flag True, _) -> id+                        (True, _, _)      -> (showComment com $$) . ($$ text "")+                        (False, _, _)     -> ($$ text "")+                      $+                      comment f <> text s <> colon+                                <> text (take (20 - length s) (repeat ' '))+                                <> text (fromMaybe "" . flagToMaybe $ f)+   comment NoFlag    = text "-- "+   comment (Flag "") = text "-- "+   comment _         = text ""++   showComment :: Maybe String -> Doc+   showComment (Just t) = vcat . map text+                        . map ("-- "++) . lines+                        . renderStyle style {+                            lineLength = 76,+                            ribbonsPerLine = 1.05+                          }+                        . fsep . map text . words $ t+   showComment Nothing  = text ""++-- | Generate warnings for missing fields etc.+generateWarnings :: InitFlags -> IO ()+generateWarnings flags = do+  message flags ""+  when (synopsis flags `elem` [NoFlag, Flag ""])+       (message flags "Warning: no synopsis given. You should edit the .cabal file and add one.")++  message flags "You may want to edit the .cabal file and add a Description field."++-- | Possibly generate a message to stdout, taking into account the+--   --quiet flag.+message :: InitFlags -> String -> IO ()+message (InitFlags{quiet = Flag True}) _ = return ()+message _ s = putStrLn s++#if MIN_VERSION_base(3,0,0)+#else+(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)+f >=> g     = \x -> f x >>= g+#endif
+ cabal/cabal-install/Distribution/Client/Init/Heuristics.hs view
@@ -0,0 +1,191 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Heuristics+-- Copyright   :  (c) Benedikt Huber 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Heuristics for creating initial cabal files.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.Heuristics (+    guessPackageName,+    scanForModules,     SourceFileEntry(..),+    neededBuildPrograms,+    guessAuthorNameMail,+    knownCategories,+) where+import Distribution.Simple.Setup(Flag(..))+import Distribution.ModuleName ( ModuleName, fromString )+import Distribution.Client.PackageIndex+    ( allPackagesByName )+import qualified Distribution.PackageDescription as PD+    ( category, packageDescription )+import Distribution.Simple.Utils+         ( intercalate )++import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )+import Control.Monad (liftM )+import Data.Char   ( isUpper, isLower, isSpace )+#if MIN_VERSION_base(3,0,3)+import Data.Either ( partitionEithers )+#endif+import Data.Maybe  ( catMaybes )+import Data.Monoid ( mempty, mappend )+import qualified Data.Set as Set ( fromList, toList )+import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist,+                          getHomeDirectory, canonicalizePath )+import System.Environment ( getEnvironment )+import System.FilePath ( takeExtension, takeBaseName, dropExtension,+                         (</>), splitDirectories, makeRelative )++-- |Guess the package name based on the given root directory+guessPackageName :: FilePath -> IO String+guessPackageName = liftM (last . splitDirectories) . canonicalizePath++-- |Data type of source files found in the working directory+data SourceFileEntry = SourceFileEntry+    { relativeSourcePath :: FilePath+    , moduleName :: ModuleName+    , fileExtension :: String+    } deriving Show++-- |Search for source files in the given directory+-- and return pairs of guessed haskell source path and+-- module names.+scanForModules :: FilePath -> IO [SourceFileEntry]+scanForModules rootDir = scanForModulesIn rootDir rootDir++scanForModulesIn :: FilePath -> FilePath -> IO [SourceFileEntry]+scanForModulesIn projectRoot srcRoot = scan srcRoot []+  where+    scan dir hierarchy = do+        entries <- getDirectoryContents (projectRoot </> dir)+        (files, dirs) <- liftM partitionEithers (mapM (tagIsDir dir) entries)+        let modules = catMaybes [ guessModuleName hierarchy file+                                | file <- files+                                , isUpper (head file) ]+        recMods <- mapM (scanRecursive dir hierarchy) dirs+        return $ concat (modules : recMods)+    tagIsDir parent entry = do+        isDir <- doesDirectoryExist (parent </> entry)+        return $ (if isDir then Right else Left) entry+    guessModuleName hierarchy entry+        | takeBaseName entry == "Setup" = Nothing+        | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext+        | otherwise = Nothing+      where+        relRoot = makeRelative projectRoot srcRoot+        unqualModName = dropExtension entry+        modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy)+        ext = case takeExtension entry of '.':e -> e; e -> e+    scanRecursive parent hierarchy entry+      | isUpper (head entry) = scan (parent </> entry) (entry : hierarchy)+      | isLower (head entry) && not (ignoreDir entry) =+          scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy)+      | otherwise = return []+    ignoreDir ('.':_)  = True+    ignoreDir dir      = dir `elem` ["dist", "_darcs"]++-- Unfortunately we cannot use the version exported by Distribution.Simple.Program+knownSuffixHandlers :: [(String,String)]+knownSuffixHandlers =+  [ ("gc",     "greencard")+  , ("chs",    "chs")+  , ("hsc",    "hsc2hs")+  , ("x",      "alex")+  , ("y",      "happy")+  , ("ly",     "happy")+  , ("cpphs",  "cpp")+  ]++sourceExtensions :: [String]+sourceExtensions = "hs" : "lhs" : map fst knownSuffixHandlers++neededBuildPrograms :: [SourceFileEntry] -> [String]+neededBuildPrograms entries =+    [ handler+    | ext <- nubSet (map fileExtension entries)+    , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers)+    ]++-- |Guess author and email+guessAuthorNameMail :: IO (Flag String, Flag String)+guessAuthorNameMail =+  update (readFromFile authorRepoFile) mempty >>=+  update (getAuthorHome >>= readFromFile) >>=+  update readFromEnvironment+  where+    update _ info@(Flag _, Flag _) = return info+    update extract info = liftM (`mappend` info) extract -- prefer info+    readFromFile file = do+      exists <- doesFileExist file+      if exists then liftM nameAndMail (readFile file) else return mempty+    readFromEnvironment = fmap extractFromEnvironment getEnvironment+    extractFromEnvironment env =+        let darcsEmailEnv = maybe mempty nameAndMail (lookup "DARCS_EMAIL" env)+            emailEnv      = maybe mempty (\e -> (mempty, Flag e)) (lookup "EMAIL" env)+        in darcsEmailEnv `mappend` emailEnv+    getAuthorHome   = liftM (</> (".darcs" </> "author")) getHomeDirectory+    authorRepoFile  = "_darcs" </> "prefs" </> "author"++-- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached+knownCategories :: SourcePackageDb -> [String]+knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $+    [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)+          , let catList = (PD.category . PD.packageDescription . packageDescription) pkg+          , cat <- splitString ',' catList+    ]++-- Parse name and email, from darcs pref files or environment variable+nameAndMail :: String -> (Flag String, Flag String)+nameAndMail str+  | all isSpace nameOrEmail = mempty+  | null erest = (mempty, Flag $ trim nameOrEmail)+  | otherwise  = (Flag $ trim nameOrEmail, Flag email)+  where+    (nameOrEmail,erest) = break (== '<') str+    (email,_)           = break (== '>') (tail erest)+    trim                = removeLeadingSpace . reverse . removeLeadingSpace . reverse+    removeLeadingSpace  = dropWhile isSpace++-- split string at given character, and remove whitespaces+splitString :: Char -> String -> [String]+splitString sep str = go str where+    go s = if null s' then [] else tok : go rest where+      s' = dropWhile (\c -> c == sep || isSpace c) s+      (tok,rest) = break (==sep) s'++nubSet :: (Ord a) => [a] -> [a]+nubSet = Set.toList . Set.fromList++{-+test db testProjectRoot = do+  putStrLn "Guessed package name"+  (guessPackageName >=> print) testProjectRoot+  putStrLn "Guessed name and email"+  guessAuthorNameMail >>= print++  mods <- scanForModules testProjectRoot++  putStrLn "Guessed modules"+  mapM_ print mods+  putStrLn "Needed build programs"+  print (neededBuildPrograms mods)++  putStrLn "List of known categories"+  print $ knownCategories db+-}++#if MIN_VERSION_base(3,0,3)+#else+partitionEithers :: [Either a b] -> ([a],[b])+partitionEithers = foldr (either left right) ([],[])+ where+   left  a (l, r) = (a:l, r)+   right a (l, r) = (l, a:r)+#endif
+ cabal/cabal-install/Distribution/Client/Init/Licenses.hs view
@@ -0,0 +1,1722 @@+module Distribution.Client.Init.Licenses+  ( License+  , bsd3+  , gplv2+  , gplv3+  , lgpl2+  , lgpl3++  ) where++type License = String++bsd3 :: String -> String -> License+bsd3 authors year = unlines+    [ "Copyright (c) " ++ year ++ ", " ++ authors+    , ""+    , "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 " ++ authors ++ " 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."+    ]++gplv2 :: License+gplv2 = unlines+    [ "             GNU GENERAL PUBLIC LICENSE"+    , "                Version 2, June 1991"+    , ""+    , " Copyright (C) 1989, 1991 Free Software Foundation, Inc.,"+    , " 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "                     Preamble"+    , ""+    , "  The licenses for most software are designed to take away your"+    , "freedom to share and change it.  By contrast, the GNU General Public"+    , "License is intended to guarantee your freedom to share and change free"+    , "software--to make sure the software is free for all its users.  This"+    , "General Public License applies to most of the Free Software"+    , "Foundation's software and to any other program whose authors commit to"+    , "using it.  (Some other Free Software Foundation software is covered by"+    , "the GNU Lesser General Public License instead.)  You can apply it to"+    , "your programs, too."+    , ""+    , "  When we speak of free software, we are referring to freedom, not"+    , "price.  Our General Public Licenses are designed to make sure that you"+    , "have the freedom to distribute copies of free software (and charge for"+    , "this service if you wish), that you receive source code or can get it"+    , "if you want it, that you can change the software or use pieces of it"+    , "in new free programs; and that you know you can do these things."+    , ""+    , "  To protect your rights, we need to make restrictions that forbid"+    , "anyone to deny you these rights or to ask you to surrender the rights."+    , "These restrictions translate to certain responsibilities for you if you"+    , "distribute copies of the software, or if you modify it."+    , ""+    , "  For example, if you distribute copies of such a program, whether"+    , "gratis or for a fee, you must give the recipients all the rights that"+    , "you have.  You must make sure that they, too, receive or can get the"+    , "source code.  And you must show them these terms so they know their"+    , "rights."+    , ""+    , "  We protect your rights with two steps: (1) copyright the software, and"+    , "(2) offer you this license which gives you legal permission to copy,"+    , "distribute and/or modify the software."+    , ""+    , "  Also, for each author's protection and ours, we want to make certain"+    , "that everyone understands that there is no warranty for this free"+    , "software.  If the software is modified by someone else and passed on, we"+    , "want its recipients to know that what they have is not the original, so"+    , "that any problems introduced by others will not reflect on the original"+    , "authors' reputations."+    , ""+    , "  Finally, any free program is threatened constantly by software"+    , "patents.  We wish to avoid the danger that redistributors of a free"+    , "program will individually obtain patent licenses, in effect making the"+    , "program proprietary.  To prevent this, we have made it clear that any"+    , "patent must be licensed for everyone's free use or not licensed at all."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "             GNU GENERAL PUBLIC LICENSE"+    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"+    , ""+    , "  0. This License applies to any program or other work which contains"+    , "a notice placed by the copyright holder saying it may be distributed"+    , "under the terms of this General Public License.  The \"Program\", below,"+    , "refers to any such program or work, and a \"work based on the Program\""+    , "means either the Program or any derivative work under copyright law:"+    , "that is to say, a work containing the Program or a portion of it,"+    , "either verbatim or with modifications and/or translated into another"+    , "language.  (Hereinafter, translation is included without limitation in"+    , "the term \"modification\".)  Each licensee is addressed as \"you\"."+    , ""+    , "Activities other than copying, distribution and modification are not"+    , "covered by this License; they are outside its scope.  The act of"+    , "running the Program is not restricted, and the output from the Program"+    , "is covered only if its contents constitute a work based on the"+    , "Program (independent of having been made by running the Program)."+    , "Whether that is true depends on what the Program does."+    , ""+    , "  1. You may copy and distribute verbatim copies of the Program's"+    , "source code as you receive it, in any medium, provided that you"+    , "conspicuously and appropriately publish on each copy an appropriate"+    , "copyright notice and disclaimer of warranty; keep intact all the"+    , "notices that refer to this License and to the absence of any warranty;"+    , "and give any other recipients of the Program a copy of this License"+    , "along with the Program."+    , ""+    , "You may charge a fee for the physical act of transferring a copy, and"+    , "you may at your option offer warranty protection in exchange for a fee."+    , ""+    , "  2. You may modify your copy or copies of the Program or any portion"+    , "of it, thus forming a work based on the Program, and copy and"+    , "distribute such modifications or work under the terms of Section 1"+    , "above, provided that you also meet all of these conditions:"+    , ""+    , "    a) You must cause the modified files to carry prominent notices"+    , "    stating that you changed the files and the date of any change."+    , ""+    , "    b) You must cause any work that you distribute or publish, that in"+    , "    whole or in part contains or is derived from the Program or any"+    , "    part thereof, to be licensed as a whole at no charge to all third"+    , "    parties under the terms of this License."+    , ""+    , "    c) If the modified program normally reads commands interactively"+    , "    when run, you must cause it, when started running for such"+    , "    interactive use in the most ordinary way, to print or display an"+    , "    announcement including an appropriate copyright notice and a"+    , "    notice that there is no warranty (or else, saying that you provide"+    , "    a warranty) and that users may redistribute the program under"+    , "    these conditions, and telling the user how to view a copy of this"+    , "    License.  (Exception: if the Program itself is interactive but"+    , "    does not normally print such an announcement, your work based on"+    , "    the Program is not required to print an announcement.)"+    , ""+    , "These requirements apply to the modified work as a whole.  If"+    , "identifiable sections of that work are not derived from the Program,"+    , "and can be reasonably considered independent and separate works in"+    , "themselves, then this License, and its terms, do not apply to those"+    , "sections when you distribute them as separate works.  But when you"+    , "distribute the same sections as part of a whole which is a work based"+    , "on the Program, the distribution of the whole must be on the terms of"+    , "this License, whose permissions for other licensees extend to the"+    , "entire whole, and thus to each and every part regardless of who wrote it."+    , ""+    , "Thus, it is not the intent of this section to claim rights or contest"+    , "your rights to work written entirely by you; rather, the intent is to"+    , "exercise the right to control the distribution of derivative or"+    , "collective works based on the Program."+    , ""+    , "In addition, mere aggregation of another work not based on the Program"+    , "with the Program (or with a work based on the Program) on a volume of"+    , "a storage or distribution medium does not bring the other work under"+    , "the scope of this License."+    , ""+    , "  3. You may copy and distribute the Program (or a work based on it,"+    , "under Section 2) in object code or executable form under the terms of"+    , "Sections 1 and 2 above provided that you also do one of the following:"+    , ""+    , "    a) Accompany it with the complete corresponding machine-readable"+    , "    source code, which must be distributed under the terms of Sections"+    , "    1 and 2 above on a medium customarily used for software interchange; or,"+    , ""+    , "    b) Accompany it with a written offer, valid for at least three"+    , "    years, to give any third party, for a charge no more than your"+    , "    cost of physically performing source distribution, a complete"+    , "    machine-readable copy of the corresponding source code, to be"+    , "    distributed under the terms of Sections 1 and 2 above on a medium"+    , "    customarily used for software interchange; or,"+    , ""+    , "    c) Accompany it with the information you received as to the offer"+    , "    to distribute corresponding source code.  (This alternative is"+    , "    allowed only for noncommercial distribution and only if you"+    , "    received the program in object code or executable form with such"+    , "    an offer, in accord with Subsection b above.)"+    , ""+    , "The source code for a work means the preferred form of the work for"+    , "making modifications to it.  For an executable work, complete source"+    , "code means all the source code for all modules it contains, plus any"+    , "associated interface definition files, plus the scripts used to"+    , "control compilation and installation of the executable.  However, as a"+    , "special exception, the source code distributed need not include"+    , "anything that is normally distributed (in either source or binary"+    , "form) with the major components (compiler, kernel, and so on) of the"+    , "operating system on which the executable runs, unless that component"+    , "itself accompanies the executable."+    , ""+    , "If distribution of executable or object code is made by offering"+    , "access to copy from a designated place, then offering equivalent"+    , "access to copy the source code from the same place counts as"+    , "distribution of the source code, even though third parties are not"+    , "compelled to copy the source along with the object code."+    , ""+    , "  4. You may not copy, modify, sublicense, or distribute the Program"+    , "except as expressly provided under this License.  Any attempt"+    , "otherwise to copy, modify, sublicense or distribute the Program is"+    , "void, and will automatically terminate your rights under this License."+    , "However, parties who have received copies, or rights, from you under"+    , "this License will not have their licenses terminated so long as such"+    , "parties remain in full compliance."+    , ""+    , "  5. You are not required to accept this License, since you have not"+    , "signed it.  However, nothing else grants you permission to modify or"+    , "distribute the Program or its derivative works.  These actions are"+    , "prohibited by law if you do not accept this License.  Therefore, by"+    , "modifying or distributing the Program (or any work based on the"+    , "Program), you indicate your acceptance of this License to do so, and"+    , "all its terms and conditions for copying, distributing or modifying"+    , "the Program or works based on it."+    , ""+    , "  6. Each time you redistribute the Program (or any work based on the"+    , "Program), the recipient automatically receives a license from the"+    , "original licensor to copy, distribute or modify the Program subject to"+    , "these terms and conditions.  You may not impose any further"+    , "restrictions on the recipients' exercise of the rights granted herein."+    , "You are not responsible for enforcing compliance by third parties to"+    , "this License."+    , ""+    , "  7. If, as a consequence of a court judgment or allegation of patent"+    , "infringement or for any other reason (not limited to patent issues),"+    , "conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot"+    , "distribute so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you"+    , "may not distribute the Program at all.  For example, if a patent"+    , "license would not permit royalty-free redistribution of the Program by"+    , "all those who receive copies directly or indirectly through you, then"+    , "the only way you could satisfy both it and this License would be to"+    , "refrain entirely from distribution of the Program."+    , ""+    , "If any portion of this section is held invalid or unenforceable under"+    , "any particular circumstance, the balance of the section is intended to"+    , "apply and the section as a whole is intended to apply in other"+    , "circumstances."+    , ""+    , "It is not the purpose of this section to induce you to infringe any"+    , "patents or other property right claims or to contest validity of any"+    , "such claims; this section has the sole purpose of protecting the"+    , "integrity of the free software distribution system, which is"+    , "implemented by public license practices.  Many people have made"+    , "generous contributions to the wide range of software distributed"+    , "through that system in reliance on consistent application of that"+    , "system; it is up to the author/donor to decide if he or she is willing"+    , "to distribute software through any other system and a licensee cannot"+    , "impose that choice."+    , ""+    , "This section is intended to make thoroughly clear what is believed to"+    , "be a consequence of the rest of this License."+    , ""+    , "  8. If the distribution and/or use of the Program is restricted in"+    , "certain countries either by patents or by copyrighted interfaces, the"+    , "original copyright holder who places the Program under this License"+    , "may add an explicit geographical distribution limitation excluding"+    , "those countries, so that distribution is permitted only in or among"+    , "countries not thus excluded.  In such case, this License incorporates"+    , "the limitation as if written in the body of this License."+    , ""+    , "  9. The Free Software Foundation may publish revised and/or new versions"+    , "of the General Public License from time to time.  Such new versions will"+    , "be similar in spirit to the present version, but may differ in detail to"+    , "address new problems or concerns."+    , ""+    , "Each version is given a distinguishing version number.  If the Program"+    , "specifies a version number of this License which applies to it and \"any"+    , "later version\", you have the option of following the terms and conditions"+    , "either of that version or of any later version published by the Free"+    , "Software Foundation.  If the Program does not specify a version number of"+    , "this License, you may choose any version ever published by the Free Software"+    , "Foundation."+    , ""+    , "  10. If you wish to incorporate parts of the Program into other free"+    , "programs whose distribution conditions are different, write to the author"+    , "to ask for permission.  For software which is copyrighted by the Free"+    , "Software Foundation, write to the Free Software Foundation; we sometimes"+    , "make exceptions for this.  Our decision will be guided by the two goals"+    , "of preserving the free status of all derivatives of our free software and"+    , "of promoting the sharing and reuse of software generally."+    , ""+    , "                     NO WARRANTY"+    , ""+    , "  11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY"+    , "FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW.  EXCEPT WHEN"+    , "OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES"+    , "PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED"+    , "OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF"+    , "MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE.  THE ENTIRE RISK AS"+    , "TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU.  SHOULD THE"+    , "PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING,"+    , "REPAIR OR CORRECTION."+    , ""+    , "  12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR"+    , "REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES,"+    , "INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING"+    , "OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED"+    , "TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY"+    , "YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER"+    , "PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE"+    , "POSSIBILITY OF SUCH DAMAGES."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "     How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "convey the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program is free software; you can redistribute it and/or modify"+    , "    it under the terms of the GNU General Public License as published by"+    , "    the Free Software Foundation; either version 2 of the License, or"+    , "    (at your option) any later version."+    , ""+    , "    This program is distributed in the hope that it will be useful,"+    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"+    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"+    , "    GNU General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU General Public License along"+    , "    with this program; if not, write to the Free Software Foundation, Inc.,"+    , "    51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA."+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "If the program is interactive, make it output a short notice like this"+    , "when it starts in an interactive mode:"+    , ""+    , "    Gnomovision version 69, Copyright (C) year name of author"+    , "    Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'."+    , "    This is free software, and you are welcome to redistribute it"+    , "    under certain conditions; type `show c' for details."+    , ""+    , "The hypothetical commands `show w' and `show c' should show the appropriate"+    , "parts of the General Public License.  Of course, the commands you use may"+    , "be called something other than `show w' and `show c'; they could even be"+    , "mouse-clicks or menu items--whatever suits your program."+    , ""+    , "You should also get your employer (if you work as a programmer) or your"+    , "school, if any, to sign a \"copyright disclaimer\" for the program, if"+    , "necessary.  Here is a sample; alter the names:"+    , ""+    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the program"+    , "  `Gnomovision' (which makes passes at compilers) written by James Hacker."+    , ""+    , "  <signature of Ty Coon>, 1 April 1989"+    , "  Ty Coon, President of Vice"+    , ""+    , "This General Public License does not permit incorporating your program into"+    , "proprietary programs.  If your program is a subroutine library, you may"+    , "consider it more useful to permit linking proprietary applications with the"+    , "library.  If this is what you want to do, use the GNU Lesser General"+    , "Public License instead of this License."+    ]++gplv3 :: License+gplv3 = unlines+    [ "              GNU GENERAL PUBLIC LICENSE"+    , "                Version 3, 29 June 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "                     Preamble"+    , ""+    , "  The GNU General Public License is a free, copyleft license for"+    , "software and other kinds of works."+    , ""+    , "  The licenses for most software and other practical works are designed"+    , "to take away your freedom to share and change the works.  By contrast,"+    , "the GNU General Public License is intended to guarantee your freedom to"+    , "share and change all versions of a program--to make sure it remains free"+    , "software for all its users.  We, the Free Software Foundation, use the"+    , "GNU General Public License for most of our software; it applies also to"+    , "any other work released this way by its authors.  You can apply it to"+    , "your programs, too."+    , ""+    , "  When we speak of free software, we are referring to freedom, not"+    , "price.  Our General Public Licenses are designed to make sure that you"+    , "have the freedom to distribute copies of free software (and charge for"+    , "them if you wish), that you receive source code or can get it if you"+    , "want it, that you can change the software or use pieces of it in new"+    , "free programs, and that you know you can do these things."+    , ""+    , "  To protect your rights, we need to prevent others from denying you"+    , "these rights or asking you to surrender the rights.  Therefore, you have"+    , "certain responsibilities if you distribute copies of the software, or if"+    , "you modify it: responsibilities to respect the freedom of others."+    , ""+    , "  For example, if you distribute copies of such a program, whether"+    , "gratis or for a fee, you must pass on to the recipients the same"+    , "freedoms that you received.  You must make sure that they, too, receive"+    , "or can get the source code.  And you must show them these terms so they"+    , "know their rights."+    , ""+    , "  Developers that use the GNU GPL protect your rights with two steps:"+    , "(1) assert copyright on the software, and (2) offer you this License"+    , "giving you legal permission to copy, distribute and/or modify it."+    , ""+    , "  For the developers' and authors' protection, the GPL clearly explains"+    , "that there is no warranty for this free software.  For both users' and"+    , "authors' sake, the GPL requires that modified versions be marked as"+    , "changed, so that their problems will not be attributed erroneously to"+    , "authors of previous versions."+    , ""+    , "  Some devices are designed to deny users access to install or run"+    , "modified versions of the software inside them, although the manufacturer"+    , "can do so.  This is fundamentally incompatible with the aim of"+    , "protecting users' freedom to change the software.  The systematic"+    , "pattern of such abuse occurs in the area of products for individuals to"+    , "use, which is precisely where it is most unacceptable.  Therefore, we"+    , "have designed this version of the GPL to prohibit the practice for those"+    , "products.  If such problems arise substantially in other domains, we"+    , "stand ready to extend this provision to those domains in future versions"+    , "of the GPL, as needed to protect the freedom of users."+    , ""+    , "  Finally, every program is threatened constantly by software patents."+    , "States should not allow patents to restrict development and use of"+    , "software on general-purpose computers, but in those that do, we wish to"+    , "avoid the special danger that patents applied to a free program could"+    , "make it effectively proprietary.  To prevent this, the GPL assures that"+    , "patents cannot be used to render the program non-free."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow."+    , ""+    , "                TERMS AND CONDITIONS"+    , ""+    , "  0. Definitions."+    , ""+    , "  \"This License\" refers to version 3 of the GNU General Public License."+    , ""+    , "  \"Copyright\" also means copyright-like laws that apply to other kinds of"+    , "works, such as semiconductor masks."+    , " "+    , "  \"The Program\" refers to any copyrightable work licensed under this"+    , "License.  Each licensee is addressed as \"you\".  \"Licensees\" and"+    , "\"recipients\" may be individuals or organizations."+    , ""+    , "  To \"modify\" a work means to copy from or adapt all or part of the work"+    , "in a fashion requiring copyright permission, other than the making of an"+    , "exact copy.  The resulting work is called a \"modified version\" of the"+    , "earlier work or a work \"based on\" the earlier work."+    , ""+    , "  A \"covered work\" means either the unmodified Program or a work based"+    , "on the Program."+    , ""+    , "  To \"propagate\" a work means to do anything with it that, without"+    , "permission, would make you directly or secondarily liable for"+    , "infringement under applicable copyright law, except executing it on a"+    , "computer or modifying a private copy.  Propagation includes copying,"+    , "distribution (with or without modification), making available to the"+    , "public, and in some countries other activities as well."+    , ""+    , "  To \"convey\" a work means any kind of propagation that enables other"+    , "parties to make or receive copies.  Mere interaction with a user through"+    , "a computer network, with no transfer of a copy, is not conveying."+    , ""+    , "  An interactive user interface displays \"Appropriate Legal Notices\""+    , "to the extent that it includes a convenient and prominently visible"+    , "feature that (1) displays an appropriate copyright notice, and (2)"+    , "tells the user that there is no warranty for the work (except to the"+    , "extent that warranties are provided), that licensees may convey the"+    , "work under this License, and how to view a copy of this License.  If"+    , "the interface presents a list of user commands or options, such as a"+    , "menu, a prominent item in the list meets this criterion."+    , ""+    , "  1. Source Code."+    , ""+    , "  The \"source code\" for a work means the preferred form of the work"+    , "for making modifications to it.  \"Object code\" means any non-source"+    , "form of a work."+    , ""+    , "  A \"Standard Interface\" means an interface that either is an official"+    , "standard defined by a recognized standards body, or, in the case of"+    , "interfaces specified for a particular programming language, one that"+    , "is widely used among developers working in that language."+    , ""+    , "  The \"System Libraries\" of an executable work include anything, other"+    , "than the work as a whole, that (a) is included in the normal form of"+    , "packaging a Major Component, but which is not part of that Major"+    , "Component, and (b) serves only to enable use of the work with that"+    , "Major Component, or to implement a Standard Interface for which an"+    , "implementation is available to the public in source code form.  A"+    , "\"Major Component\", in this context, means a major essential component"+    , "(kernel, window system, and so on) of the specific operating system"+    , "(if any) on which the executable work runs, or a compiler used to"+    , "produce the work, or an object code interpreter used to run it."+    , ""+    , "  The \"Corresponding Source\" for a work in object code form means all"+    , "the source code needed to generate, install, and (for an executable"+    , "work) run the object code and to modify the work, including scripts to"+    , "control those activities.  However, it does not include the work's"+    , "System Libraries, or general-purpose tools or generally available free"+    , "programs which are used unmodified in performing those activities but"+    , "which are not part of the work.  For example, Corresponding Source"+    , "includes interface definition files associated with source files for"+    , "the work, and the source code for shared libraries and dynamically"+    , "linked subprograms that the work is specifically designed to require,"+    , "such as by intimate data communication or control flow between those"+    , "subprograms and other parts of the work."+    , ""+    , "  The Corresponding Source need not include anything that users"+    , "can regenerate automatically from other parts of the Corresponding"+    , "Source."+    , ""+    , "  The Corresponding Source for a work in source code form is that"+    , "same work."+    , ""+    , "  2. Basic Permissions."+    , ""+    , "  All rights granted under this License are granted for the term of"+    , "copyright on the Program, and are irrevocable provided the stated"+    , "conditions are met.  This License explicitly affirms your unlimited"+    , "permission to run the unmodified Program.  The output from running a"+    , "covered work is covered by this License only if the output, given its"+    , "content, constitutes a covered work.  This License acknowledges your"+    , "rights of fair use or other equivalent, as provided by copyright law."+    , ""+    , "  You may make, run and propagate covered works that you do not"+    , "convey, without conditions so long as your license otherwise remains"+    , "in force.  You may convey covered works to others for the sole purpose"+    , "of having them make modifications exclusively for you, or provide you"+    , "with facilities for running those works, provided that you comply with"+    , "the terms of this License in conveying all material for which you do"+    , "not control copyright.  Those thus making or running the covered works"+    , "for you must do so exclusively on your behalf, under your direction"+    , "and control, on terms that prohibit them from making any copies of"+    , "your copyrighted material outside their relationship with you."+    , ""+    , "  Conveying under any other circumstances is permitted solely under"+    , "the conditions stated below.  Sublicensing is not allowed; section 10"+    , "makes it unnecessary."+    , ""+    , "  3. Protecting Users' Legal Rights From Anti-Circumvention Law."+    , ""+    , "  No covered work shall be deemed part of an effective technological"+    , "measure under any applicable law fulfilling obligations under article"+    , "11 of the WIPO copyright treaty adopted on 20 December 1996, or"+    , "similar laws prohibiting or restricting circumvention of such"+    , "measures."+    , ""+    , "  When you convey a covered work, you waive any legal power to forbid"+    , "circumvention of technological measures to the extent such circumvention"+    , "is effected by exercising rights under this License with respect to"+    , "the covered work, and you disclaim any intention to limit operation or"+    , "modification of the work as a means of enforcing, against the work's"+    , "users, your or third parties' legal rights to forbid circumvention of"+    , "technological measures."+    , ""+    , "  4. Conveying Verbatim Copies."+    , ""+    , "  You may convey verbatim copies of the Program's source code as you"+    , "receive it, in any medium, provided that you conspicuously and"+    , "appropriately publish on each copy an appropriate copyright notice;"+    , "keep intact all notices stating that this License and any"+    , "non-permissive terms added in accord with section 7 apply to the code;"+    , "keep intact all notices of the absence of any warranty; and give all"+    , "recipients a copy of this License along with the Program."+    , ""+    , "  You may charge any price or no price for each copy that you convey,"+    , "and you may offer support or warranty protection for a fee."+    , ""+    , "  5. Conveying Modified Source Versions."+    , ""+    , "  You may convey a work based on the Program, or the modifications to"+    , "produce it from the Program, in the form of source code under the"+    , "terms of section 4, provided that you also meet all of these conditions:"+    , ""+    , "    a) The work must carry prominent notices stating that you modified"+    , "    it, and giving a relevant date."+    , ""+    , "    b) The work must carry prominent notices stating that it is"+    , "    released under this License and any conditions added under section"+    , "    7.  This requirement modifies the requirement in section 4 to"+    , "    \"keep intact all notices\"."+    , ""+    , "    c) You must license the entire work, as a whole, under this"+    , "    License to anyone who comes into possession of a copy.  This"+    , "    License will therefore apply, along with any applicable section 7"+    , "    additional terms, to the whole of the work, and all its parts,"+    , "    regardless of how they are packaged.  This License gives no"+    , "    permission to license the work in any other way, but it does not"+    , "    invalidate such permission if you have separately received it."+    , ""+    , "    d) If the work has interactive user interfaces, each must display"+    , "    Appropriate Legal Notices; however, if the Program has interactive"+    , "    interfaces that do not display Appropriate Legal Notices, your"+    , "    work need not make them do so."+    , ""+    , "  A compilation of a covered work with other separate and independent"+    , "works, which are not by their nature extensions of the covered work,"+    , "and which are not combined with it such as to form a larger program,"+    , "in or on a volume of a storage or distribution medium, is called an"+    , "\"aggregate\" if the compilation and its resulting copyright are not"+    , "used to limit the access or legal rights of the compilation's users"+    , "beyond what the individual works permit.  Inclusion of a covered work"+    , "in an aggregate does not cause this License to apply to the other"+    , "parts of the aggregate."+    , ""+    , "  6. Conveying Non-Source Forms."+    , ""+    , "  You may convey a covered work in object code form under the terms"+    , "of sections 4 and 5, provided that you also convey the"+    , "machine-readable Corresponding Source under the terms of this License,"+    , "in one of these ways:"+    , ""+    , "    a) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by the"+    , "    Corresponding Source fixed on a durable physical medium"+    , "    customarily used for software interchange."+    , ""+    , "    b) Convey the object code in, or embodied in, a physical product"+    , "    (including a physical distribution medium), accompanied by a"+    , "    written offer, valid for at least three years and valid for as"+    , "    long as you offer spare parts or customer support for that product"+    , "    model, to give anyone who possesses the object code either (1) a"+    , "    copy of the Corresponding Source for all the software in the"+    , "    product that is covered by this License, on a durable physical"+    , "    medium customarily used for software interchange, for a price no"+    , "    more than your reasonable cost of physically performing this"+    , "    conveying of source, or (2) access to copy the"+    , "    Corresponding Source from a network server at no charge."+    , ""+    , "    c) Convey individual copies of the object code with a copy of the"+    , "    written offer to provide the Corresponding Source.  This"+    , "    alternative is allowed only occasionally and noncommercially, and"+    , "    only if you received the object code with such an offer, in accord"+    , "    with subsection 6b."+    , ""+    , "    d) Convey the object code by offering access from a designated"+    , "    place (gratis or for a charge), and offer equivalent access to the"+    , "    Corresponding Source in the same way through the same place at no"+    , "    further charge.  You need not require recipients to copy the"+    , "    Corresponding Source along with the object code.  If the place to"+    , "    copy the object code is a network server, the Corresponding Source"+    , "    may be on a different server (operated by you or a third party)"+    , "    that supports equivalent copying facilities, provided you maintain"+    , "    clear directions next to the object code saying where to find the"+    , "    Corresponding Source.  Regardless of what server hosts the"+    , "    Corresponding Source, you remain obligated to ensure that it is"+    , "    available for as long as needed to satisfy these requirements."+    , ""+    , "    e) Convey the object code using peer-to-peer transmission, provided"+    , "    you inform other peers where the object code and Corresponding"+    , "    Source of the work are being offered to the general public at no"+    , "    charge under subsection 6d."+    , ""+    , "  A separable portion of the object code, whose source code is excluded"+    , "from the Corresponding Source as a System Library, need not be"+    , "included in conveying the object code work."+    , ""+    , "  A \"User Product\" is either (1) a \"consumer product\", which means any"+    , "tangible personal property which is normally used for personal, family,"+    , "or household purposes, or (2) anything designed or sold for incorporation"+    , "into a dwelling.  In determining whether a product is a consumer product,"+    , "doubtful cases shall be resolved in favor of coverage.  For a particular"+    , "product received by a particular user, \"normally used\" refers to a"+    , "typical or common use of that class of product, regardless of the status"+    , "of the particular user or of the way in which the particular user"+    , "actually uses, or expects or is expected to use, the product.  A product"+    , "is a consumer product regardless of whether the product has substantial"+    , "commercial, industrial or non-consumer uses, unless such uses represent"+    , "the only significant mode of use of the product."+    , ""+    , "  \"Installation Information\" for a User Product means any methods,"+    , "procedures, authorization keys, or other information required to install"+    , "and execute modified versions of a covered work in that User Product from"+    , "a modified version of its Corresponding Source.  The information must"+    , "suffice to ensure that the continued functioning of the modified object"+    , "code is in no case prevented or interfered with solely because"+    , "modification has been made."+    , ""+    , "  If you convey an object code work under this section in, or with, or"+    , "specifically for use in, a User Product, and the conveying occurs as"+    , "part of a transaction in which the right of possession and use of the"+    , "User Product is transferred to the recipient in perpetuity or for a"+    , "fixed term (regardless of how the transaction is characterized), the"+    , "Corresponding Source conveyed under this section must be accompanied"+    , "by the Installation Information.  But this requirement does not apply"+    , "if neither you nor any third party retains the ability to install"+    , "modified object code on the User Product (for example, the work has"+    , "been installed in ROM)."+    , ""+    , "  The requirement to provide Installation Information does not include a"+    , "requirement to continue to provide support service, warranty, or updates"+    , "for a work that has been modified or installed by the recipient, or for"+    , "the User Product in which it has been modified or installed.  Access to a"+    , "network may be denied when the modification itself materially and"+    , "adversely affects the operation of the network or violates the rules and"+    , "protocols for communication across the network."+    , ""+    , "  Corresponding Source conveyed, and Installation Information provided,"+    , "in accord with this section must be in a format that is publicly"+    , "documented (and with an implementation available to the public in"+    , "source code form), and must require no special password or key for"+    , "unpacking, reading or copying."+    , ""+    , "  7. Additional Terms."+    , ""+    , "  \"Additional permissions\" are terms that supplement the terms of this"+    , "License by making exceptions from one or more of its conditions."+    , "Additional permissions that are applicable to the entire Program shall"+    , "be treated as though they were included in this License, to the extent"+    , "that they are valid under applicable law.  If additional permissions"+    , "apply only to part of the Program, that part may be used separately"+    , "under those permissions, but the entire Program remains governed by"+    , "this License without regard to the additional permissions."+    , ""+    , "  When you convey a copy of a covered work, you may at your option"+    , "remove any additional permissions from that copy, or from any part of"+    , "it.  (Additional permissions may be written to require their own"+    , "removal in certain cases when you modify the work.)  You may place"+    , "additional permissions on material, added by you to a covered work,"+    , "for which you have or can give appropriate copyright permission."+    , ""+    , "  Notwithstanding any other provision of this License, for material you"+    , "add to a covered work, you may (if authorized by the copyright holders of"+    , "that material) supplement the terms of this License with terms:"+    , ""+    , "    a) Disclaiming warranty or limiting liability differently from the"+    , "    terms of sections 15 and 16 of this License; or"+    , ""+    , "    b) Requiring preservation of specified reasonable legal notices or"+    , "    author attributions in that material or in the Appropriate Legal"+    , "    Notices displayed by works containing it; or"+    , ""+    , "    c) Prohibiting misrepresentation of the origin of that material, or"+    , "    requiring that modified versions of such material be marked in"+    , "    reasonable ways as different from the original version; or"+    , ""+    , "    d) Limiting the use for publicity purposes of names of licensors or"+    , "    authors of the material; or"+    , ""+    , "    e) Declining to grant rights under trademark law for use of some"+    , "    trade names, trademarks, or service marks; or"+    , ""+    , "    f) Requiring indemnification of licensors and authors of that"+    , "    material by anyone who conveys the material (or modified versions of"+    , "    it) with contractual assumptions of liability to the recipient, for"+    , "    any liability that these contractual assumptions directly impose on"+    , "    those licensors and authors."+    , ""+    , "  All other non-permissive additional terms are considered \"further"+    , "restrictions\" within the meaning of section 10.  If the Program as you"+    , "received it, or any part of it, contains a notice stating that it is"+    , "governed by this License along with a term that is a further"+    , "restriction, you may remove that term.  If a license document contains"+    , "a further restriction but permits relicensing or conveying under this"+    , "License, you may add to a covered work material governed by the terms"+    , "of that license document, provided that the further restriction does"+    , "not survive such relicensing or conveying."+    , ""+    , "  If you add terms to a covered work in accord with this section, you"+    , "must place, in the relevant source files, a statement of the"+    , "additional terms that apply to those files, or a notice indicating"+    , "where to find the applicable terms."+    , ""+    , "  Additional terms, permissive or non-permissive, may be stated in the"+    , "form of a separately written license, or stated as exceptions;"+    , "the above requirements apply either way."+    , ""+    , "  8. Termination."+    , ""+    , "  You may not propagate or modify a covered work except as expressly"+    , "provided under this License.  Any attempt otherwise to propagate or"+    , "modify it is void, and will automatically terminate your rights under"+    , "this License (including any patent licenses granted under the third"+    , "paragraph of section 11)."+    , ""+    , "  However, if you cease all violation of this License, then your"+    , "license from a particular copyright holder is reinstated (a)"+    , "provisionally, unless and until the copyright holder explicitly and"+    , "finally terminates your license, and (b) permanently, if the copyright"+    , "holder fails to notify you of the violation by some reasonable means"+    , "prior to 60 days after the cessation."+    , ""+    , "  Moreover, your license from a particular copyright holder is"+    , "reinstated permanently if the copyright holder notifies you of the"+    , "violation by some reasonable means, this is the first time you have"+    , "received notice of violation of this License (for any work) from that"+    , "copyright holder, and you cure the violation prior to 30 days after"+    , "your receipt of the notice."+    , ""+    , "  Termination of your rights under this section does not terminate the"+    , "licenses of parties who have received copies or rights from you under"+    , "this License.  If your rights have been terminated and not permanently"+    , "reinstated, you do not qualify to receive new licenses for the same"+    , "material under section 10."+    , ""+    , "  9. Acceptance Not Required for Having Copies."+    , ""+    , "  You are not required to accept this License in order to receive or"+    , "run a copy of the Program.  Ancillary propagation of a covered work"+    , "occurring solely as a consequence of using peer-to-peer transmission"+    , "to receive a copy likewise does not require acceptance.  However,"+    , "nothing other than this License grants you permission to propagate or"+    , "modify any covered work.  These actions infringe copyright if you do"+    , "not accept this License.  Therefore, by modifying or propagating a"+    , "covered work, you indicate your acceptance of this License to do so."+    , ""+    , "  10. Automatic Licensing of Downstream Recipients."+    , ""+    , "  Each time you convey a covered work, the recipient automatically"+    , "receives a license from the original licensors, to run, modify and"+    , "propagate that work, subject to this License.  You are not responsible"+    , "for enforcing compliance by third parties with this License."+    , ""+    , "  An \"entity transaction\" is a transaction transferring control of an"+    , "organization, or substantially all assets of one, or subdividing an"+    , "organization, or merging organizations.  If propagation of a covered"+    , "work results from an entity transaction, each party to that"+    , "transaction who receives a copy of the work also receives whatever"+    , "licenses to the work the party's predecessor in interest had or could"+    , "give under the previous paragraph, plus a right to possession of the"+    , "Corresponding Source of the work from the predecessor in interest, if"+    , "the predecessor has it or can get it with reasonable efforts."+    , ""+    , "  You may not impose any further restrictions on the exercise of the"+    , "rights granted or affirmed under this License.  For example, you may"+    , "not impose a license fee, royalty, or other charge for exercise of"+    , "rights granted under this License, and you may not initiate litigation"+    , "(including a cross-claim or counterclaim in a lawsuit) alleging that"+    , "any patent claim is infringed by making, using, selling, offering for"+    , "sale, or importing the Program or any portion of it."+    , ""+    , "  11. Patents."+    , ""+    , "  A \"contributor\" is a copyright holder who authorizes use under this"+    , "License of the Program or a work on which the Program is based.  The"+    , "work thus licensed is called the contributor's \"contributor version\"."+    , ""+    , "  A contributor's \"essential patent claims\" are all patent claims"+    , "owned or controlled by the contributor, whether already acquired or"+    , "hereafter acquired, that would be infringed by some manner, permitted"+    , "by this License, of making, using, or selling its contributor version,"+    , "but do not include claims that would be infringed only as a"+    , "consequence of further modification of the contributor version.  For"+    , "purposes of this definition, \"control\" includes the right to grant"+    , "patent sublicenses in a manner consistent with the requirements of"+    , "this License."+    , ""+    , "  Each contributor grants you a non-exclusive, worldwide, royalty-free"+    , "patent license under the contributor's essential patent claims, to"+    , "make, use, sell, offer for sale, import and otherwise run, modify and"+    , "propagate the contents of its contributor version."+    , ""+    , "  In the following three paragraphs, a \"patent license\" is any express"+    , "agreement or commitment, however denominated, not to enforce a patent"+    , "(such as an express permission to practice a patent or covenant not to"+    , "sue for patent infringement).  To \"grant\" such a patent license to a"+    , "party means to make such an agreement or commitment not to enforce a"+    , "patent against the party."+    , ""+    , "  If you convey a covered work, knowingly relying on a patent license,"+    , "and the Corresponding Source of the work is not available for anyone"+    , "to copy, free of charge and under the terms of this License, through a"+    , "publicly available network server or other readily accessible means,"+    , "then you must either (1) cause the Corresponding Source to be so"+    , "available, or (2) arrange to deprive yourself of the benefit of the"+    , "patent license for this particular work, or (3) arrange, in a manner"+    , "consistent with the requirements of this License, to extend the patent"+    , "license to downstream recipients.  \"Knowingly relying\" means you have"+    , "actual knowledge that, but for the patent license, your conveying the"+    , "covered work in a country, or your recipient's use of the covered work"+    , "in a country, would infringe one or more identifiable patents in that"+    , "country that you have reason to believe are valid."+    , "  "+    , "  If, pursuant to or in connection with a single transaction or"+    , "arrangement, you convey, or propagate by procuring conveyance of, a"+    , "covered work, and grant a patent license to some of the parties"+    , "receiving the covered work authorizing them to use, propagate, modify"+    , "or convey a specific copy of the covered work, then the patent license"+    , "you grant is automatically extended to all recipients of the covered"+    , "work and works based on it."+    , ""+    , "  A patent license is \"discriminatory\" if it does not include within"+    , "the scope of its coverage, prohibits the exercise of, or is"+    , "conditioned on the non-exercise of one or more of the rights that are"+    , "specifically granted under this License.  You may not convey a covered"+    , "work if you are a party to an arrangement with a third party that is"+    , "in the business of distributing software, under which you make payment"+    , "to the third party based on the extent of your activity of conveying"+    , "the work, and under which the third party grants, to any of the"+    , "parties who would receive the covered work from you, a discriminatory"+    , "patent license (a) in connection with copies of the covered work"+    , "conveyed by you (or copies made from those copies), or (b) primarily"+    , "for and in connection with specific products or compilations that"+    , "contain the covered work, unless you entered into that arrangement,"+    , "or that patent license was granted, prior to 28 March 2007."+    , ""+    , "  Nothing in this License shall be construed as excluding or limiting"+    , "any implied license or other defenses to infringement that may"+    , "otherwise be available to you under applicable patent law."+    , ""+    , "  12. No Surrender of Others' Freedom."+    , ""+    , "  If conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot convey a"+    , "covered work so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you may"+    , "not convey it at all.  For example, if you agree to terms that obligate you"+    , "to collect a royalty for further conveying from those to whom you convey"+    , "the Program, the only way you could satisfy both those terms and this"+    , "License would be to refrain entirely from conveying the Program."+    , ""+    , "  13. Use with the GNU Affero General Public License."+    , ""+    , "  Notwithstanding any other provision of this License, you have"+    , "permission to link or combine any covered work with a work licensed"+    , "under version 3 of the GNU Affero General Public License into a single"+    , "combined work, and to convey the resulting work.  The terms of this"+    , "License will continue to apply to the part which is the covered work,"+    , "but the special requirements of the GNU Affero General Public License,"+    , "section 13, concerning interaction through a network will apply to the"+    , "combination as such."+    , ""+    , "  14. Revised Versions of this License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions of"+    , "the GNU General Public License from time to time.  Such new versions will"+    , "be similar in spirit to the present version, but may differ in detail to"+    , "address new problems or concerns."+    , ""+    , "  Each version is given a distinguishing version number.  If the"+    , "Program specifies that a certain numbered version of the GNU General"+    , "Public License \"or any later version\" applies to it, you have the"+    , "option of following the terms and conditions either of that numbered"+    , "version or of any later version published by the Free Software"+    , "Foundation.  If the Program does not specify a version number of the"+    , "GNU General Public License, you may choose any version ever published"+    , "by the Free Software Foundation."+    , ""+    , "  If the Program specifies that a proxy can decide which future"+    , "versions of the GNU General Public License can be used, that proxy's"+    , "public statement of acceptance of a version permanently authorizes you"+    , "to choose that version for the Program."+    , ""+    , "  Later license versions may give you additional or different"+    , "permissions.  However, no additional obligations are imposed on any"+    , "author or copyright holder as a result of your choosing to follow a"+    , "later version."+    , ""+    , "  15. Disclaimer of Warranty."+    , ""+    , "  THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY"+    , "APPLICABLE LAW.  EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT"+    , "HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM \"AS IS\" WITHOUT WARRANTY"+    , "OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO,"+    , "THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM"+    , "IS WITH YOU.  SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF"+    , "ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. Limitation of Liability."+    , ""+    , "  IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING"+    , "WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MODIFIES AND/OR CONVEYS"+    , "THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY"+    , "GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE"+    , "USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF"+    , "DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD"+    , "PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS),"+    , "EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF"+    , "SUCH DAMAGES."+    , ""+    , "  17. Interpretation of Sections 15 and 16."+    , ""+    , "  If the disclaimer of warranty and limitation of liability provided"+    , "above cannot be given local legal effect according to their terms,"+    , "reviewing courts shall apply local law that most closely approximates"+    , "an absolute waiver of all civil liability in connection with the"+    , "Program, unless a warranty or assumption of liability accompanies a"+    , "copy of the Program in return for a fee."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "     How to Apply These Terms to Your New Programs"+    , ""+    , "  If you develop a new program, and you want it to be of the greatest"+    , "possible use to the public, the best way to achieve this is to make it"+    , "free software which everyone can redistribute and change under these terms."+    , ""+    , "  To do so, attach the following notices to the program.  It is safest"+    , "to attach them to the start of each source file to most effectively"+    , "state the exclusion of warranty; and each file should have at least"+    , "the \"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the program's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This program is free software: you can redistribute it and/or modify"+    , "    it under the terms of the GNU General Public License as published by"+    , "    the Free Software Foundation, either version 3 of the License, or"+    , "    (at your option) any later version."+    , ""+    , "    This program is distributed in the hope that it will be useful,"+    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"+    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the"+    , "    GNU General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU General Public License"+    , "    along with this program.  If not, see <http://www.gnu.org/licenses/>."+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "  If the program does terminal interaction, make it output a short"+    , "notice like this when it starts in an interactive mode:"+    , ""+    , "    <program>  Copyright (C) <year>  <name of author>"+    , "    This program comes with ABSOLUTELY NO WARRANTY; for details type `show w'."+    , "    This is free software, and you are welcome to redistribute it"+    , "    under certain conditions; type `show c' for details."+    , ""+    , "The hypothetical commands `show w' and `show c' should show the appropriate"+    , "parts of the General Public License.  Of course, your program's commands"+    , "might be different; for a GUI interface, you would use an \"about box\"."+    , ""+    , "  You should also get your employer (if you work as a programmer) or school,"+    , "if any, to sign a \"copyright disclaimer\" for the program, if necessary."+    , "For more information on this, and how to apply and follow the GNU GPL, see"+    , "<http://www.gnu.org/licenses/>."+    , ""+    , "  The GNU General Public License does not permit incorporating your program"+    , "into proprietary programs.  If your program is a subroutine library, you"+    , "may consider it more useful to permit linking proprietary applications with"+    , "the library.  If this is what you want to do, use the GNU Lesser General"+    , "Public License instead of this License.  But first, please read"+    , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."+    , ""+    ]++lgpl2 :: License+lgpl2 = unlines+    [ "           GNU LIBRARY GENERAL PUBLIC LICENSE"+    , "                 Version 2, June 1991"+    , ""+    , " Copyright (C) 1991 Free Software Foundation, Inc."+    , " 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , "[This is the first released version of the library GPL.  It is"+    , " numbered 2 because it goes with version 2 of the ordinary GPL.]"+    , ""+    , "                     Preamble"+    , ""+    , "  The licenses for most software are designed to take away your"+    , "freedom to share and change it.  By contrast, the GNU General Public"+    , "Licenses are intended to guarantee your freedom to share and change"+    , "free software--to make sure the software is free for all its users."+    , ""+    , "  This license, the Library General Public License, applies to some"+    , "specially designated Free Software Foundation software, and to any"+    , "other libraries whose authors decide to use it.  You can use it for"+    , "your libraries, too."+    , ""+    , "  When we speak of free software, we are referring to freedom, not"+    , "price.  Our General Public Licenses are designed to make sure that you"+    , "have the freedom to distribute copies of free software (and charge for"+    , "this service if you wish), that you receive source code or can get it"+    , "if you want it, that you can change the software or use pieces of it"+    , "in new free programs; and that you know you can do these things."+    , ""+    , "  To protect your rights, we need to make restrictions that forbid"+    , "anyone to deny you these rights or to ask you to surrender the rights."+    , "These restrictions translate to certain responsibilities for you if"+    , "you distribute copies of the library, or if you modify it."+    , ""+    , "  For example, if you distribute copies of the library, whether gratis"+    , "or for a fee, you must give the recipients all the rights that we gave"+    , "you.  You must make sure that they, too, receive or can get the source"+    , "code.  If you link a program with the library, you must provide"+    , "complete object files to the recipients so that they can relink them"+    , "with the library, after making changes to the library and recompiling"+    , "it.  And you must show them these terms so they know their rights."+    , ""+    , "  Our method of protecting your rights has two steps: (1) copyright"+    , "the library, and (2) offer you this license which gives you legal"+    , "permission to copy, distribute and/or modify the library."+    , ""+    , "  Also, for each distributor's protection, we want to make certain"+    , "that everyone understands that there is no warranty for this free"+    , "library.  If the library is modified by someone else and passed on, we"+    , "want its recipients to know that what they have is not the original"+    , "version, so that any problems introduced by others will not reflect on"+    , "the original authors' reputations."+    , ""+    , "  Finally, any free program is threatened constantly by software"+    , "patents.  We wish to avoid the danger that companies distributing free"+    , "software will individually obtain patent licenses, thus in effect"+    , "transforming the program into proprietary software.  To prevent this,"+    , "we have made it clear that any patent must be licensed for everyone's"+    , "free use or not licensed at all."+    , ""+    , "  Most GNU software, including some libraries, is covered by the ordinary"+    , "GNU General Public License, which was designed for utility programs.  This"+    , "license, the GNU Library General Public License, applies to certain"+    , "designated libraries.  This license is quite different from the ordinary"+    , "one; be sure to read it in full, and don't assume that anything in it is"+    , "the same as in the ordinary license."+    , ""+    , "  The reason we have a separate public license for some libraries is that"+    , "they blur the distinction we usually make between modifying or adding to a"+    , "program and simply using it.  Linking a program with a library, without"+    , "changing the library, is in some sense simply using the library, and is"+    , "analogous to running a utility program or application program.  However, in"+    , "a textual and legal sense, the linked executable is a combined work, a"+    , "derivative of the original library, and the ordinary General Public License"+    , "treats it as such."+    , ""+    , "  Because of this blurred distinction, using the ordinary General"+    , "Public License for libraries did not effectively promote software"+    , "sharing, because most developers did not use the libraries.  We"+    , "concluded that weaker conditions might promote sharing better."+    , ""+    , "  However, unrestricted linking of non-free programs would deprive the"+    , "users of those programs of all benefit from the free status of the"+    , "libraries themselves.  This Library General Public License is intended to"+    , "permit developers of non-free programs to use free libraries, while"+    , "preserving your freedom as a user of such programs to change the free"+    , "libraries that are incorporated in them.  (We have not seen how to achieve"+    , "this as regards changes in header files, but we have achieved it as regards"+    , "changes in the actual functions of the Library.)  The hope is that this"+    , "will lead to faster development of free libraries."+    , ""+    , "  The precise terms and conditions for copying, distribution and"+    , "modification follow.  Pay close attention to the difference between a"+    , "\"work based on the library\" and a \"work that uses the library\".  The"+    , "former contains code derived from the library, while the latter only"+    , "works together with the library."+    , ""+    , "  Note that it is possible for a library to be covered by the ordinary"+    , "General Public License rather than by this special one."+    , ""+    , "              GNU LIBRARY GENERAL PUBLIC LICENSE"+    , "   TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION"+    , ""+    , "  0. This License Agreement applies to any software library which"+    , "contains a notice placed by the copyright holder or other authorized"+    , "party saying it may be distributed under the terms of this Library"+    , "General Public License (also called \"this License\").  Each licensee is"+    , "addressed as \"you\"."+    , ""+    , "  A \"library\" means a collection of software functions and/or data"+    , "prepared so as to be conveniently linked with application programs"+    , "(which use some of those functions and data) to form executables."+    , ""+    , "  The \"Library\", below, refers to any such software library or work"+    , "which has been distributed under these terms.  A \"work based on the"+    , "Library\" means either the Library or any derivative work under"+    , "copyright law: that is to say, a work containing the Library or a"+    , "portion of it, either verbatim or with modifications and/or translated"+    , "straightforwardly into another language.  (Hereinafter, translation is"+    , "included without limitation in the term \"modification\".)"+    , ""+    , "  \"Source code\" for a work means the preferred form of the work for"+    , "making modifications to it.  For a library, complete source code means"+    , "all the source code for all modules it contains, plus any associated"+    , "interface definition files, plus the scripts used to control compilation"+    , "and installation of the library."+    , ""+    , "  Activities other than copying, distribution and modification are not"+    , "covered by this License; they are outside its scope.  The act of"+    , "running a program using the Library is not restricted, and output from"+    , "such a program is covered only if its contents constitute a work based"+    , "on the Library (independent of the use of the Library in a tool for"+    , "writing it).  Whether that is true depends on what the Library does"+    , "and what the program that uses the Library does."+    , "  "+    , "  1. You may copy and distribute verbatim copies of the Library's"+    , "complete source code as you receive it, in any medium, provided that"+    , "you conspicuously and appropriately publish on each copy an"+    , "appropriate copyright notice and disclaimer of warranty; keep intact"+    , "all the notices that refer to this License and to the absence of any"+    , "warranty; and distribute a copy of this License along with the"+    , "Library."+    , ""+    , "  You may charge a fee for the physical act of transferring a copy,"+    , "and you may at your option offer warranty protection in exchange for a"+    , "fee."+    , ""+    , "  2. You may modify your copy or copies of the Library or any portion"+    , "of it, thus forming a work based on the Library, and copy and"+    , "distribute such modifications or work under the terms of Section 1"+    , "above, provided that you also meet all of these conditions:"+    , ""+    , "    a) The modified work must itself be a software library."+    , ""+    , "    b) You must cause the files modified to carry prominent notices"+    , "    stating that you changed the files and the date of any change."+    , ""+    , "    c) You must cause the whole of the work to be licensed at no"+    , "    charge to all third parties under the terms of this License."+    , ""+    , "    d) If a facility in the modified Library refers to a function or a"+    , "    table of data to be supplied by an application program that uses"+    , "    the facility, other than as an argument passed when the facility"+    , "    is invoked, then you must make a good faith effort to ensure that,"+    , "    in the event an application does not supply such function or"+    , "    table, the facility still operates, and performs whatever part of"+    , "    its purpose remains meaningful."+    , ""+    , "    (For example, a function in a library to compute square roots has"+    , "    a purpose that is entirely well-defined independent of the"+    , "    application.  Therefore, Subsection 2d requires that any"+    , "    application-supplied function or table used by this function must"+    , "    be optional: if the application does not supply it, the square"+    , "    root function must still compute square roots.)"+    , ""+    , "These requirements apply to the modified work as a whole.  If"+    , "identifiable sections of that work are not derived from the Library,"+    , "and can be reasonably considered independent and separate works in"+    , "themselves, then this License, and its terms, do not apply to those"+    , "sections when you distribute them as separate works.  But when you"+    , "distribute the same sections as part of a whole which is a work based"+    , "on the Library, the distribution of the whole must be on the terms of"+    , "this License, whose permissions for other licensees extend to the"+    , "entire whole, and thus to each and every part regardless of who wrote"+    , "it."+    , ""+    , "Thus, it is not the intent of this section to claim rights or contest"+    , "your rights to work written entirely by you; rather, the intent is to"+    , "exercise the right to control the distribution of derivative or"+    , "collective works based on the Library."+    , ""+    , "In addition, mere aggregation of another work not based on the Library"+    , "with the Library (or with a work based on the Library) on a volume of"+    , "a storage or distribution medium does not bring the other work under"+    , "the scope of this License."+    , ""+    , "  3. You may opt to apply the terms of the ordinary GNU General Public"+    , "License instead of this License to a given copy of the Library.  To do"+    , "this, you must alter all the notices that refer to this License, so"+    , "that they refer to the ordinary GNU General Public License, version 2,"+    , "instead of to this License.  (If a newer version than version 2 of the"+    , "ordinary GNU General Public License has appeared, then you can specify"+    , "that version instead if you wish.)  Do not make any other change in"+    , "these notices."+    , ""+    , "  Once this change is made in a given copy, it is irreversible for"+    , "that copy, so the ordinary GNU General Public License applies to all"+    , "subsequent copies and derivative works made from that copy."+    , ""+    , "  This option is useful when you wish to copy part of the code of"+    , "the Library into a program that is not a library."+    , ""+    , "  4. You may copy and distribute the Library (or a portion or"+    , "derivative of it, under Section 2) in object code or executable form"+    , "under the terms of Sections 1 and 2 above provided that you accompany"+    , "it with the complete corresponding machine-readable source code, which"+    , "must be distributed under the terms of Sections 1 and 2 above on a"+    , "medium customarily used for software interchange."+    , ""+    , "  If distribution of object code is made by offering access to copy"+    , "from a designated place, then offering equivalent access to copy the"+    , "source code from the same place satisfies the requirement to"+    , "distribute the source code, even though third parties are not"+    , "compelled to copy the source along with the object code."+    , ""+    , "  5. A program that contains no derivative of any portion of the"+    , "Library, but is designed to work with the Library by being compiled or"+    , "linked with it, is called a \"work that uses the Library\".  Such a"+    , "work, in isolation, is not a derivative work of the Library, and"+    , "therefore falls outside the scope of this License."+    , ""+    , "  However, linking a \"work that uses the Library\" with the Library"+    , "creates an executable that is a derivative of the Library (because it"+    , "contains portions of the Library), rather than a \"work that uses the"+    , "library\".  The executable is therefore covered by this License."+    , "Section 6 states terms for distribution of such executables."+    , ""+    , "  When a \"work that uses the Library\" uses material from a header file"+    , "that is part of the Library, the object code for the work may be a"+    , "derivative work of the Library even though the source code is not."+    , "Whether this is true is especially significant if the work can be"+    , "linked without the Library, or if the work is itself a library.  The"+    , "threshold for this to be true is not precisely defined by law."+    , ""+    , "  If such an object file uses only numerical parameters, data"+    , "structure layouts and accessors, and small macros and small inline"+    , "functions (ten lines or less in length), then the use of the object"+    , "file is unrestricted, regardless of whether it is legally a derivative"+    , "work.  (Executables containing this object code plus portions of the"+    , "Library will still fall under Section 6.)"+    , ""+    , "  Otherwise, if the work is a derivative of the Library, you may"+    , "distribute the object code for the work under the terms of Section 6."+    , "Any executables containing that work also fall under Section 6,"+    , "whether or not they are linked directly with the Library itself."+    , ""+    , "  6. As an exception to the Sections above, you may also compile or"+    , "link a \"work that uses the Library\" with the Library to produce a"+    , "work containing portions of the Library, and distribute that work"+    , "under terms of your choice, provided that the terms permit"+    , "modification of the work for the customer's own use and reverse"+    , "engineering for debugging such modifications."+    , ""+    , "  You must give prominent notice with each copy of the work that the"+    , "Library is used in it and that the Library and its use are covered by"+    , "this License.  You must supply a copy of this License.  If the work"+    , "during execution displays copyright notices, you must include the"+    , "copyright notice for the Library among them, as well as a reference"+    , "directing the user to the copy of this License.  Also, you must do one"+    , "of these things:"+    , ""+    , "    a) Accompany the work with the complete corresponding"+    , "    machine-readable source code for the Library including whatever"+    , "    changes were used in the work (which must be distributed under"+    , "    Sections 1 and 2 above); and, if the work is an executable linked"+    , "    with the Library, with the complete machine-readable \"work that"+    , "    uses the Library\", as object code and/or source code, so that the"+    , "    user can modify the Library and then relink to produce a modified"+    , "    executable containing the modified Library.  (It is understood"+    , "    that the user who changes the contents of definitions files in the"+    , "    Library will not necessarily be able to recompile the application"+    , "    to use the modified definitions.)"+    , ""+    , "    b) Accompany the work with a written offer, valid for at"+    , "    least three years, to give the same user the materials"+    , "    specified in Subsection 6a, above, for a charge no more"+    , "    than the cost of performing this distribution."+    , ""+    , "    c) If distribution of the work is made by offering access to copy"+    , "    from a designated place, offer equivalent access to copy the above"+    , "    specified materials from the same place."+    , ""+    , "    d) Verify that the user has already received a copy of these"+    , "    materials or that you have already sent this user a copy."+    , ""+    , "  For an executable, the required form of the \"work that uses the"+    , "Library\" must include any data and utility programs needed for"+    , "reproducing the executable from it.  However, as a special exception,"+    , "the source code distributed need not include anything that is normally"+    , "distributed (in either source or binary form) with the major"+    , "components (compiler, kernel, and so on) of the operating system on"+    , "which the executable runs, unless that component itself accompanies"+    , "the executable."+    , ""+    , "  It may happen that this requirement contradicts the license"+    , "restrictions of other proprietary libraries that do not normally"+    , "accompany the operating system.  Such a contradiction means you cannot"+    , "use both them and the Library together in an executable that you"+    , "distribute."+    , ""+    , "  7. You may place library facilities that are a work based on the"+    , "Library side-by-side in a single library together with other library"+    , "facilities not covered by this License, and distribute such a combined"+    , "library, provided that the separate distribution of the work based on"+    , "the Library and of the other library facilities is otherwise"+    , "permitted, and provided that you do these two things:"+    , ""+    , "    a) Accompany the combined library with a copy of the same work"+    , "    based on the Library, uncombined with any other library"+    , "    facilities.  This must be distributed under the terms of the"+    , "    Sections above."+    , ""+    , "    b) Give prominent notice with the combined library of the fact"+    , "    that part of it is a work based on the Library, and explaining"+    , "    where to find the accompanying uncombined form of the same work."+    , ""+    , "  8. You may not copy, modify, sublicense, link with, or distribute"+    , "the Library except as expressly provided under this License.  Any"+    , "attempt otherwise to copy, modify, sublicense, link with, or"+    , "distribute the Library is void, and will automatically terminate your"+    , "rights under this License.  However, parties who have received copies,"+    , "or rights, from you under this License will not have their licenses"+    , "terminated so long as such parties remain in full compliance."+    , ""+    , "  9. You are not required to accept this License, since you have not"+    , "signed it.  However, nothing else grants you permission to modify or"+    , "distribute the Library or its derivative works.  These actions are"+    , "prohibited by law if you do not accept this License.  Therefore, by"+    , "modifying or distributing the Library (or any work based on the"+    , "Library), you indicate your acceptance of this License to do so, and"+    , "all its terms and conditions for copying, distributing or modifying"+    , "the Library or works based on it."+    , ""+    , "  10. Each time you redistribute the Library (or any work based on the"+    , "Library), the recipient automatically receives a license from the"+    , "original licensor to copy, distribute, link with or modify the Library"+    , "subject to these terms and conditions.  You may not impose any further"+    , "restrictions on the recipients' exercise of the rights granted herein."+    , "You are not responsible for enforcing compliance by third parties to"+    , "this License."+    , ""+    , "  11. If, as a consequence of a court judgment or allegation of patent"+    , "infringement or for any other reason (not limited to patent issues),"+    , "conditions are imposed on you (whether by court order, agreement or"+    , "otherwise) that contradict the conditions of this License, they do not"+    , "excuse you from the conditions of this License.  If you cannot"+    , "distribute so as to satisfy simultaneously your obligations under this"+    , "License and any other pertinent obligations, then as a consequence you"+    , "may not distribute the Library at all.  For example, if a patent"+    , "license would not permit royalty-free redistribution of the Library by"+    , "all those who receive copies directly or indirectly through you, then"+    , "the only way you could satisfy both it and this License would be to"+    , "refrain entirely from distribution of the Library."+    , ""+    , "If any portion of this section is held invalid or unenforceable under any"+    , "particular circumstance, the balance of the section is intended to apply,"+    , "and the section as a whole is intended to apply in other circumstances."+    , ""+    , "It is not the purpose of this section to induce you to infringe any"+    , "patents or other property right claims or to contest validity of any"+    , "such claims; this section has the sole purpose of protecting the"+    , "integrity of the free software distribution system which is"+    , "implemented by public license practices.  Many people have made"+    , "generous contributions to the wide range of software distributed"+    , "through that system in reliance on consistent application of that"+    , "system; it is up to the author/donor to decide if he or she is willing"+    , "to distribute software through any other system and a licensee cannot"+    , "impose that choice."+    , ""+    , "This section is intended to make thoroughly clear what is believed to"+    , "be a consequence of the rest of this License."+    , ""+    , "  12. If the distribution and/or use of the Library is restricted in"+    , "certain countries either by patents or by copyrighted interfaces, the"+    , "original copyright holder who places the Library under this License may add"+    , "an explicit geographical distribution limitation excluding those countries,"+    , "so that distribution is permitted only in or among countries not thus"+    , "excluded.  In such case, this License incorporates the limitation as if"+    , "written in the body of this License."+    , ""+    , "  13. The Free Software Foundation may publish revised and/or new"+    , "versions of the Library General Public License from time to time."+    , "Such new versions will be similar in spirit to the present version,"+    , "but may differ in detail to address new problems or concerns."+    , ""+    , "Each version is given a distinguishing version number.  If the Library"+    , "specifies a version number of this License which applies to it and"+    , "\"any later version\", you have the option of following the terms and"+    , "conditions either of that version or of any later version published by"+    , "the Free Software Foundation.  If the Library does not specify a"+    , "license version number, you may choose any version ever published by"+    , "the Free Software Foundation."+    , ""+    , "  14. If you wish to incorporate parts of the Library into other free"+    , "programs whose distribution conditions are incompatible with these,"+    , "write to the author to ask for permission.  For software which is"+    , "copyrighted by the Free Software Foundation, write to the Free"+    , "Software Foundation; we sometimes make exceptions for this.  Our"+    , "decision will be guided by the two goals of preserving the free status"+    , "of all derivatives of our free software and of promoting the sharing"+    , "and reuse of software generally."+    , ""+    , "                     NO WARRANTY"+    , ""+    , "  15. BECAUSE THE LIBRARY IS LICENSED FREE OF CHARGE, THERE IS NO"+    , "WARRANTY FOR THE LIBRARY, TO THE EXTENT PERMITTED BY APPLICABLE LAW."+    , "EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR"+    , "OTHER PARTIES PROVIDE THE LIBRARY \"AS IS\" WITHOUT WARRANTY OF ANY"+    , "KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE"+    , "IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR"+    , "PURPOSE.  THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE"+    , "LIBRARY IS WITH YOU.  SHOULD THE LIBRARY PROVE DEFECTIVE, YOU ASSUME"+    , "THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION."+    , ""+    , "  16. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN"+    , "WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY"+    , "AND/OR REDISTRIBUTE THE LIBRARY AS PERMITTED ABOVE, BE LIABLE TO YOU"+    , "FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR"+    , "CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE"+    , "LIBRARY (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING"+    , "RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A"+    , "FAILURE OF THE LIBRARY TO OPERATE WITH ANY OTHER SOFTWARE), EVEN IF"+    , "SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH"+    , "DAMAGES."+    , ""+    , "              END OF TERMS AND CONDITIONS"+    , ""+    , "           How to Apply These Terms to Your New Libraries"+    , ""+    , "  If you develop a new library, and you want it to be of the greatest"+    , "possible use to the public, we recommend making it free software that"+    , "everyone can redistribute and change.  You can do so by permitting"+    , "redistribution under these terms (or, alternatively, under the terms of the"+    , "ordinary General Public License)."+    , ""+    , "  To apply these terms, attach the following notices to the library.  It is"+    , "safest to attach them to the start of each source file to most effectively"+    , "convey the exclusion of warranty; and each file should have at least the"+    , "\"copyright\" line and a pointer to where the full notice is found."+    , ""+    , "    <one line to give the library's name and a brief idea of what it does.>"+    , "    Copyright (C) <year>  <name of author>"+    , ""+    , "    This library is free software; you can redistribute it and/or"+    , "    modify it under the terms of the GNU Library General Public"+    , "    License as published by the Free Software Foundation; either"+    , "    version 2 of the License, or (at your option) any later version."+    , ""+    , "    This library is distributed in the hope that it will be useful,"+    , "    but WITHOUT ANY WARRANTY; without even the implied warranty of"+    , "    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU"+    , "    Library General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU Library General Public"+    , "    License along with this library; if not, write to the Free"+    , "    Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA"+    , ""+    , "Also add information on how to contact you by electronic and paper mail."+    , ""+    , "You should also get your employer (if you work as a programmer) or your"+    , "school, if any, to sign a \"copyright disclaimer\" for the library, if"+    , "necessary.  Here is a sample; alter the names:"+    , ""+    , "  Yoyodyne, Inc., hereby disclaims all copyright interest in the"+    , "  library `Frob' (a library for tweaking knobs) written by James Random Hacker."+    , ""+    , "  <signature of Ty Coon>, 1 April 1990"+    , "  Ty Coon, President of Vice"+    , ""+    , "That's all there is to it!"+    ]++lgpl3 :: License+lgpl3 = unlines+    [ "                  GNU LESSER GENERAL PUBLIC LICENSE"+    , "                       Version 3, 29 June 2007"+    , ""+    , " Copyright (C) 2007 Free Software Foundation, Inc. <http://fsf.org/>"+    , " Everyone is permitted to copy and distribute verbatim copies"+    , " of this license document, but changing it is not allowed."+    , ""+    , ""+    , "  This version of the GNU Lesser General Public License incorporates"+    , "the terms and conditions of version 3 of the GNU General Public"+    , "License, supplemented by the additional permissions listed below."+    , ""+    , "  0. Additional Definitions. "+    , ""+    , "  As used herein, \"this License\" refers to version 3 of the GNU Lesser"+    , "General Public License, and the \"GNU GPL\" refers to version 3 of the GNU"+    , "General Public License."+    , ""+    , "  \"The Library\" refers to a covered work governed by this License,"+    , "other than an Application or a Combined Work as defined below."+    , ""+    , "  An \"Application\" is any work that makes use of an interface provided"+    , "by the Library, but which is not otherwise based on the Library."+    , "Defining a subclass of a class defined by the Library is deemed a mode"+    , "of using an interface provided by the Library."+    , ""+    , "  A \"Combined Work\" is a work produced by combining or linking an"+    , "Application with the Library.  The particular version of the Library"+    , "with which the Combined Work was made is also called the \"Linked"+    , "Version\"."+    , ""+    , "  The \"Minimal Corresponding Source\" for a Combined Work means the"+    , "Corresponding Source for the Combined Work, excluding any source code"+    , "for portions of the Combined Work that, considered in isolation, are"+    , "based on the Application, and not on the Linked Version."+    , ""+    , "  The \"Corresponding Application Code\" for a Combined Work means the"+    , "object code and/or source code for the Application, including any data"+    , "and utility programs needed for reproducing the Combined Work from the"+    , "Application, but excluding the System Libraries of the Combined Work."+    , ""+    , "  1. Exception to Section 3 of the GNU GPL."+    , ""+    , "  You may convey a covered work under sections 3 and 4 of this License"+    , "without being bound by section 3 of the GNU GPL."+    , ""+    , "  2. Conveying Modified Versions."+    , ""+    , "  If you modify a copy of the Library, and, in your modifications, a"+    , "facility refers to a function or data to be supplied by an Application"+    , "that uses the facility (other than as an argument passed when the"+    , "facility is invoked), then you may convey a copy of the modified"+    , "version:"+    , ""+    , "   a) under this License, provided that you make a good faith effort to"+    , "   ensure that, in the event an Application does not supply the"+    , "   function or data, the facility still operates, and performs"+    , "   whatever part of its purpose remains meaningful, or"+    , ""+    , "   b) under the GNU GPL, with none of the additional permissions of"+    , "   this License applicable to that copy."+    , ""+    , "  3. Object Code Incorporating Material from Library Header Files."+    , ""+    , "  The object code form of an Application may incorporate material from"+    , "a header file that is part of the Library.  You may convey such object"+    , "code under terms of your choice, provided that, if the incorporated"+    , "material is not limited to numerical parameters, data structure"+    , "layouts and accessors, or small macros, inline functions and templates"+    , "(ten or fewer lines in length), you do both of the following:"+    , ""+    , "   a) Give prominent notice with each copy of the object code that the"+    , "   Library is used in it and that the Library and its use are"+    , "   covered by this License."+    , ""+    , "   b) Accompany the object code with a copy of the GNU GPL and this license"+    , "   document."+    , ""+    , "  4. Combined Works."+    , ""+    , "  You may convey a Combined Work under terms of your choice that,"+    , "taken together, effectively do not restrict modification of the"+    , "portions of the Library contained in the Combined Work and reverse"+    , "engineering for debugging such modifications, if you also do each of"+    , "the following:"+    , ""+    , "   a) Give prominent notice with each copy of the Combined Work that"+    , "   the Library is used in it and that the Library and its use are"+    , "   covered by this License."+    , ""+    , "   b) Accompany the Combined Work with a copy of the GNU GPL and this license"+    , "   document."+    , ""+    , "   c) For a Combined Work that displays copyright notices during"+    , "   execution, include the copyright notice for the Library among"+    , "   these notices, as well as a reference directing the user to the"+    , "   copies of the GNU GPL and this license document."+    , ""+    , "   d) Do one of the following:"+    , ""+    , "       0) Convey the Minimal Corresponding Source under the terms of this"+    , "       License, and the Corresponding Application Code in a form"+    , "       suitable for, and under terms that permit, the user to"+    , "       recombine or relink the Application with a modified version of"+    , "       the Linked Version to produce a modified Combined Work, in the"+    , "       manner specified by section 6 of the GNU GPL for conveying"+    , "       Corresponding Source."+    , ""+    , "       1) Use a suitable shared library mechanism for linking with the"+    , "       Library.  A suitable mechanism is one that (a) uses at run time"+    , "       a copy of the Library already present on the user's computer"+    , "       system, and (b) will operate properly with a modified version"+    , "       of the Library that is interface-compatible with the Linked"+    , "       Version. "+    , ""+    , "   e) Provide Installation Information, but only if you would otherwise"+    , "   be required to provide such information under section 6 of the"+    , "   GNU GPL, and only to the extent that such information is"+    , "   necessary to install and execute a modified version of the"+    , "   Combined Work produced by recombining or relinking the"+    , "   Application with a modified version of the Linked Version. (If"+    , "   you use option 4d0, the Installation Information must accompany"+    , "   the Minimal Corresponding Source and Corresponding Application"+    , "   Code. If you use option 4d1, you must provide the Installation"+    , "   Information in the manner specified by section 6 of the GNU GPL"+    , "   for conveying Corresponding Source.)"+    , ""+    , "  5. Combined Libraries."+    , ""+    , "  You may place library facilities that are a work based on the"+    , "Library side by side in a single library together with other library"+    , "facilities that are not Applications and are not covered by this"+    , "License, and convey such a combined library under terms of your"+    , "choice, if you do both of the following:"+    , ""+    , "   a) Accompany the combined library with a copy of the same work based"+    , "   on the Library, uncombined with any other library facilities,"+    , "   conveyed under the terms of this License."+    , ""+    , "   b) Give prominent notice with the combined library that part of it"+    , "   is a work based on the Library, and explaining where to find the"+    , "   accompanying uncombined form of the same work."+    , ""+    , "  6. Revised Versions of the GNU Lesser General Public License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions"+    , "of the GNU Lesser General Public License from time to time. Such new"+    , "versions will be similar in spirit to the present version, but may"+    , "differ in detail to address new problems or concerns."+    , ""+    , "  Each version is given a distinguishing version number. If the"+    , "Library as you received it specifies that a certain numbered version"+    , "of the GNU Lesser General Public License \"or any later version\""+    , "applies to it, you have the option of following the terms and"+    , "conditions either of that published version or of any later version"+    , "published by the Free Software Foundation. If the Library as you"+    , "received it does not specify a version number of the GNU Lesser"+    , "General Public License, you may choose any version of the GNU Lesser"+    , "General Public License ever published by the Free Software Foundation."+    , ""+    , "  If the Library as you received it specifies that a proxy can decide"+    , "whether future versions of the GNU Lesser General Public License shall"+    , "apply, that proxy's public statement of acceptance of any version is"+    , "permanent authorization for you to choose that version for the"+    , "Library."+    ]+
+ cabal/cabal-install/Distribution/Client/Init/Types.hs view
@@ -0,0 +1,152 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Init.Types+-- Copyright   :  (c) Brent Yorgey, Benedikt Huber 2009+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Some types used by the 'cabal init' command.+--+-----------------------------------------------------------------------------+module Distribution.Client.Init.Types where++import Distribution.Simple.Setup+  ( Flag(..) )++import Distribution.Version+import qualified Distribution.Package as P+import Distribution.License+import Distribution.ModuleName++import qualified Text.PrettyPrint as Disp+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Text++import Data.Monoid++-- | InitFlags is really just a simple type to represent certain+--   portions of a .cabal file.  Rather than have a flag for EVERY+--   possible field, we just have one for each field that the user is+--   likely to want and/or that we are likely to be able to+--   intelligently guess.+data InitFlags =+    InitFlags { nonInteractive :: Flag Bool+              , quiet          :: Flag Bool+              , packageDir     :: Flag FilePath+              , noComments     :: Flag Bool+              , minimal        :: Flag Bool++              , packageName  :: Flag String+              , version      :: Flag Version+              , cabalVersion :: Flag VersionRange+              , license      :: Flag License+              , author       :: Flag String+              , email        :: Flag String+              , homepage     :: Flag String++              , synopsis     :: Flag String+              , category     :: Flag (Either String Category)++              , packageType  :: Flag PackageType++              , exposedModules :: Maybe [ModuleName]+              , otherModules   :: Maybe [ModuleName]++              , dependencies :: Maybe [P.Dependency]+              , sourceDirs   :: Maybe [String]+              , buildTools   :: Maybe [String]+              }+  deriving (Show)++data PackageType = Library | Executable+  deriving (Show, Read, Eq)++instance Text PackageType where+  disp = Disp.text . show+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Library, Executable]++instance Monoid InitFlags where+  mempty = InitFlags+    { nonInteractive = mempty+    , quiet          = mempty+    , packageDir     = mempty+    , noComments     = mempty+    , minimal        = mempty+    , packageName    = mempty+    , version        = mempty+    , cabalVersion   = mempty+    , license        = mempty+    , author         = mempty+    , email          = mempty+    , homepage       = mempty+    , synopsis       = mempty+    , category       = mempty+    , packageType    = mempty+    , exposedModules = mempty+    , otherModules   = mempty+    , dependencies   = mempty+    , sourceDirs     = mempty+    , buildTools     = mempty+    }+  mappend  a b = InitFlags+    { nonInteractive = combine nonInteractive+    , quiet          = combine quiet+    , packageDir     = combine packageDir+    , noComments     = combine noComments+    , minimal        = combine minimal+    , packageName    = combine packageName+    , version        = combine version+    , cabalVersion   = combine cabalVersion+    , license        = combine license+    , author         = combine author+    , email          = combine email+    , homepage       = combine homepage+    , synopsis       = combine synopsis+    , category       = combine category+    , packageType    = combine packageType+    , exposedModules = combine exposedModules+    , otherModules   = combine otherModules+    , dependencies   = combine dependencies+    , sourceDirs     = combine sourceDirs+    , buildTools     = combine buildTools+    }+    where combine field = field a `mappend` field b++-- | Some common package categories.+data Category+    = Codec+    | Concurrency+    | Control+    | Data+    | Database+    | Development+    | Distribution+    | Game+    | Graphics+    | Language+    | Math+    | Network+    | Sound+    | System+    | Testing+    | Text+    | Web+    deriving (Read, Show, Eq, Ord, Bounded, Enum)++instance Text Category where+  disp  = Disp.text . show+  parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ]++#if MIN_VERSION_base(3,0,0)+#else+-- Compat instance for ghc-6.6 era+instance Monoid a => Monoid (Maybe a) where+  mempty = Nothing+  Nothing `mappend` m = m+  m `mappend` Nothing = m+  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)+#endif
+ cabal/cabal-install/Distribution/Client/Install.hs view
@@ -0,0 +1,891 @@+{-# LANGUAGE CPP #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Install+-- Copyright   :  (c) 2005 David Himmelstrup+--                    2007 Bjorn Bringert+--                    2007-2010 Duncan Coutts+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- High level interface to package installation.+-----------------------------------------------------------------------------+module Distribution.Client.Install (+    install,+    upgrade,+  ) where++import Data.List+         ( unfoldr, find, nub, sort )+import Data.Maybe+         ( isJust, fromMaybe )+import Control.Exception as Exception+         ( handleJust )+#if MIN_VERSION_base(4,0,0)+import Control.Exception as Exception+         ( Exception(toException), catches, Handler(Handler), IOException )+import System.Exit+         ( ExitCode )+#else+import Control.Exception as Exception+         ( Exception(IOException, ExitException) )+#endif+import Distribution.Compat.ExceptionCI+         ( SomeException, catchIO, catchExit )+import Control.Monad+         ( when, unless )+import System.Directory+         ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )+import System.FilePath+         ( (</>), (<.>), takeDirectory )+import System.IO+         ( openFile, IOMode(AppendMode) )+import System.IO.Error+         ( isDoesNotExistError, ioeGetFileName )++import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.FetchUtils+import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)+-- import qualified Distribution.Client.Info as Info+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Setup+         ( GlobalFlags(..)+         , ConfigFlags(..), configureCommand, filterConfigureFlags+         , ConfigExFlags(..), InstallFlags(..) )+import Distribution.Client.Config+         ( defaultCabalDir )+import Distribution.Client.Tar (extractTarGzFile)+import Distribution.Client.Types as Source+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import qualified Distribution.Client.BuildReports.Anonymous as BuildReports+import qualified Distribution.Client.BuildReports.Storage as BuildReports+         ( storeAnonymous, storeLocal, fromInstallPlan )+import qualified Distribution.Client.InstallSymlink as InstallSymlink+         ( symlinkBinaries )+import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import qualified Distribution.Client.World as World+import Paths_cabal_install (getBinDir)++import Distribution.Simple.Compiler+         ( CompilerId(..), Compiler(compilerId), compilerFlavor+         , PackageDB(..), PackageDBStack )+import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)+import qualified Distribution.Simple.InstallDirs as InstallDirs+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Simple.Setup+         ( haddockCommand, HaddockFlags(..), emptyHaddockFlags+         , buildCommand, BuildFlags(..), emptyBuildFlags+         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.Setup as Cabal+         ( installCommand, InstallFlags(..), emptyInstallFlags )+import Distribution.Simple.Utils+         ( rawSystemExit, comparing )+import Distribution.Simple.InstallDirs as InstallDirs+         ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate+         , initialPathTemplateEnv, installDirsTemplateEnv )+import Distribution.Package+         ( PackageIdentifier, packageName, packageVersion+         , Package(..), PackageFixedDeps(..)+         , Dependency(..), thisPackageVersion )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription, GenericPackageDescription(..), TestSuite(..) )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription, mapTreeData )+import Distribution.Version+         ( Version, anyVersion, thisVersion )+import Distribution.Simple.Utils as Utils+         ( notice, info, debug, warn, die, intercalate, withTempDirectory )+import Distribution.Client.Utils+         ( inDir, mergeBy, MergeResult(..) )+import Distribution.System+         ( Platform, buildPlatform, OS(Windows), buildOS )+import Distribution.Text+         ( display )+import Distribution.Verbosity as Verbosity+         ( Verbosity, showForCabal, verbose )+import Distribution.Simple.BuildPaths ( exeExtension )++--TODO:+-- * assign flags to packages individually+--   * complain about flags that do not apply to any package given as target+--     so flags do not apply to dependencies, only listed, can use flag+--     constraints for dependencies+--   * only record applicable flags in world file+-- * allow flag constraints+-- * allow installed constraints+-- * allow flag and installed preferences+-- * change world file to use cabal section syntax+--   * allow persistent configure flags for each package individually++-- ------------------------------------------------------------+-- * Top level user actions+-- ------------------------------------------------------------++-- | Installs the packages needed to satisfy a list of dependencies.+--+install, upgrade+  :: Verbosity+  -> PackageDBStack+  -> [Repo]+  -> Compiler+  -> ProgramConfiguration+  -> GlobalFlags+  -> ConfigFlags+  -> ConfigExFlags+  -> InstallFlags+  -> [UserTarget]+  -> IO ()+install verbosity packageDBs repos comp conf+  globalFlags configFlags configExFlags installFlags userTargets0 = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos++    let -- For install, if no target is given it means we use the+        -- current directory as the single target+        userTargets | null userTargets0 = [UserTargetLocalDir "."]+                    | otherwise         = userTargets0++    pkgSpecifiers <- resolveUserTargets verbosity+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       userTargets++    notice verbosity "Resolving dependencies..."+    installPlan   <- foldProgress logMsg die return $+                       planPackages+                         comp configFlags configExFlags installFlags+                         installedPkgIndex sourcePkgDb pkgSpecifiers++    printPlanMessages verbosity installedPkgIndex installPlan dryRun++    unless dryRun $ do+      installPlan' <- performInstallations verbosity+                        context installedPkgIndex installPlan+      postInstallActions verbosity context userTargets installPlan'++  where+    context :: InstallContext+    context = (packageDBs, repos, comp, conf,+               globalFlags, configFlags, configExFlags, installFlags)++    dryRun      = fromFlag (installDryRun installFlags)+    logMsg message rest = debug verbosity message >> rest+++upgrade _ _ _ _ _ _ _ _ _ _ = die $+    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"+ ++ "You can install the latest version of a package using 'cabal install'. "+ ++ "The 'cabal upgrade' command has been removed because people found it "+ ++ "confusing and it often led to broken packages.\n"+ ++ "If you want the old upgrade behaviour then use the install command "+ ++ "with the --upgrade-dependencies flag (but check first with --dry-run "+ ++ "to see what would happen). This will try to pick the latest versions "+ ++ "of all dependencies, rather than the usual behaviour of trying to pick "+ ++ "installed versions of all dependencies. If you do use "+ ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "+ ++ "packages (e.g. by using appropriate --constraint= flags)."++type InstallContext = ( PackageDBStack+                      , [Repo]+                      , Compiler+                      , ProgramConfiguration+                      , GlobalFlags+                      , ConfigFlags+                      , ConfigExFlags+                      , InstallFlags )++-- ------------------------------------------------------------+-- * Installation planning+-- ------------------------------------------------------------++planPackages :: Compiler+             -> ConfigFlags+             -> ConfigExFlags+             -> InstallFlags+             -> PackageIndex InstalledPackage+             -> SourcePackageDb+             -> [PackageSpecifier SourcePackage]+             -> Progress String String InstallPlan+planPackages comp configFlags configExFlags installFlags+             installedPkgIndex sourcePkgDb pkgSpecifiers =++        resolveDependencies+          buildPlatform (compilerId comp)+          resolverParams++    >>= if onlyDeps then adjustPlanOnlyDeps else return++  where+    resolverParams =++        setPreferenceDefault (if upgradeDeps then PreferAllLatest+                                             else PreferLatestForSelected)++      . addPreferences+          -- preferences from the config file or command line+          [ PackageVersionPreference name ver+          | Dependency name ver <- configPreferences configExFlags ]++      . addConstraints+          -- version constraints from the config file or command line+            (map userToPackageConstraint (configExConstraints configExFlags))++      . addConstraints+          --FIXME: this just applies all flags to all targets which+          -- is silly. We should check if the flags are appropriate+          [ PackageConstraintFlags (pkgSpecifierTarget pkgSpecifier) flags+          | let flags = configConfigurationsFlags configFlags+          , not (null flags)+          , pkgSpecifier <- pkgSpecifiers' ]++      . (if reinstall then reinstallTargets else id)++      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers'++    -- Mark test suites as enabled if invoked with '--enable-tests'. This+    -- ensures that test suite dependencies are included.+    pkgSpecifiers' = map enableTests pkgSpecifiers+    testsEnabled = fromFlagOrDefault False $ configTests configFlags+    enableTests (SpecificSourcePackage pkg) =+        let pkgDescr = Source.packageDescription pkg+            suites = condTestSuites pkgDescr+            enable = mapTreeData (\t -> t { testEnabled = testsEnabled })+        in SpecificSourcePackage $ pkg { Source.packageDescription = pkgDescr+            { condTestSuites = map (\(n, t) -> (n, enable t)) suites } }+    enableTests x = x+++    --TODO: this is a general feature and should be moved to D.C.Dependency+    -- Also, the InstallPlan.remove should return info more precise to the+    -- problem, rather than the very general PlanProblem type.+    adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan+    adjustPlanOnlyDeps =+        either (Fail . explain) Done+      . InstallPlan.remove isTarget+      where+        isTarget pkg = packageName pkg `elem` targetnames+        targetnames  = map pkgSpecifierTarget pkgSpecifiers+        +        explain :: [InstallPlan.PlanProblem] -> String+        explain problems =+            "Cannot select only the dependencies (as requested by the "+         ++ "'--only-dependencies' flag), "+         ++ (case pkgids of+               [pkgid] -> "the package " ++ display pkgid ++ " is "+               _       -> "the packages "+                       ++ intercalate ", " (map display pkgids) ++ " are ")+         ++ "required by a dependency of one of the other targets."+          where+            pkgids =+              nub [ depid+                  | InstallPlan.PackageMissingDeps _ depids <- problems+                  , depid <- depids+                  , packageName depid `elem` targetnames ]++    reinstall   = fromFlag (installReinstall installFlags)+    upgradeDeps = fromFlag (installUpgradeDeps installFlags)+    onlyDeps    = fromFlag (installOnlyDeps installFlags)++-- ------------------------------------------------------------+-- * Informational messages+-- ------------------------------------------------------------++printPlanMessages :: Verbosity+                  -> PackageIndex InstalledPackage+                  -> InstallPlan+                  -> Bool+                  -> IO ()+printPlanMessages verbosity installed installPlan dryRun = do++  when nothingToInstall $+    notice verbosity $+         "No packages to be installed. All the requested packages are "+      ++ "already installed.\n If you want to reinstall anyway then use "+      ++ "the --reinstall flag."++  when (dryRun || verbosity >= verbose) $+    printDryRun verbosity installed installPlan++  where+    nothingToInstall = null (InstallPlan.ready installPlan)+++printDryRun :: Verbosity+            -> PackageIndex InstalledPackage+            -> InstallPlan+            -> IO ()+printDryRun verbosity installedPkgIndex plan = case unfoldr next plan of+  []   -> return ()+  pkgs+    | verbosity >= Verbosity.verbose -> notice verbosity $ unlines $+        "In order, the following would be installed:"+      : map showPkgAndReason pkgs+    | otherwise -> notice verbosity $ unlines $+        "In order, the following would be installed (use -v for more details):"+      : map (display . packageId) pkgs+  where+    next plan' = case InstallPlan.ready plan' of+      []      -> Nothing+      (pkg:_) -> Just (pkg, InstallPlan.completed pkgid result plan')+        where pkgid = packageId pkg+              result = BuildOk DocsNotTried TestsNotTried+              --FIXME: This is a bit of a hack,+              -- pretending that each package is installed++    showPkgAndReason pkg' = display (packageId pkg') ++ " " +++          case PackageIndex.lookupPackageName installedPkgIndex+                                              (packageName pkg') of+            [] -> "(new package)"+            ps ->  case find ((==packageId pkg') . packageId) ps of+              Nothing  -> "(new version)"+              Just pkg -> "(reinstall)" ++ case changes pkg pkg' of+                []   -> ""+                diff -> " changes: "  ++ intercalate ", " diff+    changes pkg pkg' = map change . filter changed+                     $ mergeBy (comparing packageName)+                         (nub . sort . depends $ pkg)+                         (nub . sort . depends $ pkg')+    change (OnlyInLeft pkgid)        = display pkgid ++ " removed"+    change (InBoth     pkgid pkgid') = display pkgid ++ " -> "+                                    ++ display (packageVersion pkgid')+    change (OnlyInRight      pkgid') = display pkgid' ++ " added"+    changed (InBoth    pkgid pkgid') = pkgid /= pkgid'+    changed _                        = True++-- ------------------------------------------------------------+-- * Post installation stuff+-- ------------------------------------------------------------++-- | Various stuff we do after successful or unsuccessfully installing a bunch+-- of packages. This includes:+--+--  * build reporting, local and remote+--  * symlinking binaries+--  * updating indexes+--  * updating world file+--  * error reporting+--+postInstallActions :: Verbosity+                   -> InstallContext+                   -> [UserTarget]+                   -> InstallPlan+                   -> IO ()+postInstallActions verbosity+  (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags)+  targets installPlan = do++  unless oneShot $+    World.insert verbosity worldFile+      --FIXME: does not handle flags+      [ World.WorldPkgInfo dep []+      | UserTargetNamed dep <- targets ]++  let buildReports = BuildReports.fromInstallPlan installPlan+  BuildReports.storeLocal (installSummaryFile installFlags) buildReports+  when (reportingLevel >= AnonymousReports) $+    BuildReports.storeAnonymous buildReports+  when (reportingLevel == DetailedReports) $+    storeDetailedBuildReports verbosity logsDir buildReports++  regenerateHaddockIndex verbosity packageDBs comp conf+                         configFlags installFlags installPlan++  symlinkBinaries verbosity configFlags installFlags installPlan++  printBuildFailures installPlan++  where+    reportingLevel = fromFlag (installBuildReports installFlags)+    logsDir        = fromFlag (globalLogsDir globalFlags)+    oneShot        = fromFlag (installOneShot installFlags)+    worldFile      = fromFlag $ globalWorldFile globalFlags++storeDetailedBuildReports :: Verbosity -> FilePath+                          -> [(BuildReports.BuildReport, Repo)] -> IO ()+storeDetailedBuildReports verbosity logsDir reports = sequence_+  [ do dotCabal <- defaultCabalDir+       let logFileName = display (BuildReports.package report) <.> "log"+           logFile     = logsDir </> logFileName+           reportsDir  = dotCabal </> "reports" </> remoteRepoName remoteRepo+           reportFile  = reportsDir </> logFileName++       handleMissingLogFile $ do+         buildLog <- readFile logFile+         createDirectoryIfMissing True reportsDir -- FIXME+         writeFile reportFile (show (BuildReports.show report, buildLog))++  | (report, Repo { repoKind = Left remoteRepo }) <- reports+  , isLikelyToHaveLogFile (BuildReports.installOutcome report) ]++  where+    isLikelyToHaveLogFile BuildReports.ConfigureFailed {} = True+    isLikelyToHaveLogFile BuildReports.BuildFailed     {} = True+    isLikelyToHaveLogFile BuildReports.InstallFailed   {} = True+    isLikelyToHaveLogFile BuildReports.InstallOk       {} = True+    isLikelyToHaveLogFile _                               = False++    handleMissingLogFile = Exception.handleJust missingFile $ \ioe ->+      warn verbosity $ "Missing log file for build report: "+                    ++ fromMaybe ""  (ioeGetFileName ioe)++#if MIN_VERSION_base(4,0,0)+    missingFile ioe+#else+    missingFile (IOException ioe)+#endif+      | isDoesNotExistError ioe  = Just ioe+    missingFile _                = Nothing+++regenerateHaddockIndex :: Verbosity+                       -> [PackageDB]+                       -> Compiler+                       -> ProgramConfiguration+                       -> ConfigFlags+                       -> InstallFlags+                       -> InstallPlan+                       -> IO ()+regenerateHaddockIndex verbosity packageDBs comp conf+                       configFlags installFlags installPlan+  | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do++  defaultDirs <- InstallDirs.defaultInstallDirs+                   (compilerFlavor comp)+                   (fromFlag (configUserInstall configFlags))+                   True+  let indexFileTemplate = fromFlag (installHaddockIndex installFlags)+      indexFile = substHaddockIndexFileName defaultDirs indexFileTemplate++  notice verbosity $+     "Updating documentation index " ++ indexFile++  --TODO: might be nice if the install plan gave us the new InstalledPackageInfo+  installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+  Haddock.regenerateHaddockIndex verbosity installedPkgIndex conf indexFile++  | otherwise = return ()+  where+    haddockIndexFileIsRequested =+         fromFlag (installDocumentation installFlags)+      && isJust (flagToMaybe (installHaddockIndex installFlags))++    -- We want to regenerate the index if some new documentation was actually+    -- installed. Since the index is per-user, we don't do it for global+    -- installs or special cases where we're installing into a specific db.+    shouldRegenerateHaddockIndex = normalUserInstall+                                && someDocsWereInstalled installPlan+      where+        someDocsWereInstalled = any installedDocs . InstallPlan.toList+        normalUserInstall     = (UserPackageDB `elem` packageDBs)+                             && all (not . isSpecificPackageDB) packageDBs++        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True+        installedDocs _                                            = False+        isSpecificPackageDB (SpecificPackageDB _) = True+        isSpecificPackageDB _                     = False++    substHaddockIndexFileName defaultDirs = fromPathTemplate+                                          . substPathTemplate env+      where+        env  = env0 ++ installDirsTemplateEnv absoluteDirs+        env0 = InstallDirs.compilerTemplateEnv (compilerId comp)+            ++ InstallDirs.platformTemplateEnv (buildPlatform)+        absoluteDirs = InstallDirs.substituteInstallDirTemplates+                         env0 templateDirs+        templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault+                         defaultDirs (configInstallDirs configFlags)+++symlinkBinaries :: Verbosity+                -> ConfigFlags+                -> InstallFlags+                -> InstallPlan -> IO ()+symlinkBinaries verbosity configFlags installFlags plan = do+  failed <- InstallSymlink.symlinkBinaries configFlags installFlags plan+  case failed of+    [] -> return ()+    [(_, exe, path)] ->+      warn verbosity $+           "could not create a symlink in " ++ bindir ++ " for "+        ++ exe ++ " because the file exists there already but is not "+        ++ "managed by cabal. You can create a symlink for this executable "+        ++ "manually if you wish. The executable file has been installed at "+        ++ path+    exes ->+      warn verbosity $+           "could not create symlinks in " ++ bindir ++ " for "+        ++ intercalate ", " [ exe | (_, exe, _) <- exes ]+        ++ " because the files exist there already and are not "+        ++ "managed by cabal. You can create symlinks for these executables "+        ++ "manually if you wish. The executable files have been installed at "+        ++ intercalate ", " [ path | (_, _, path) <- exes ]+  where+    bindir = fromFlag (installSymlinkBinDir installFlags)+++printBuildFailures :: InstallPlan -> IO ()+printBuildFailures plan =+  case [ (pkg, reason)+       | InstallPlan.Failed pkg reason <- InstallPlan.toList plan ] of+    []     -> return ()+    failed -> die . unlines+            $ "Error: some packages failed to install:"+            : [ display (packageId pkg) ++ printFailureReason reason+              | (pkg, reason) <- failed ]+  where+    printFailureReason reason = case reason of+      DependentFailed pkgid -> " depends on " ++ display pkgid+                            ++ " which failed to install."+      DownloadFailed  e -> " failed while downloading the package."+                        ++ " The exception was:\n  " ++ show e+      UnpackFailed    e -> " failed while unpacking the package."+                        ++ " The exception was:\n  " ++ show e+      ConfigureFailed e -> " failed during the configure step."+                        ++ " The exception was:\n  " ++ show e+      BuildFailed     e -> " failed during the building phase."+                        ++ " The exception was:\n  " ++ show e+      InstallFailed   e -> " failed during the final install step."+                        ++ " The exception was:\n  " ++ show e+++-- ------------------------------------------------------------+-- * Actually do the installations+-- ------------------------------------------------------------++data InstallMisc = InstallMisc {+    rootCmd    :: Maybe FilePath,+    libVersion :: Maybe Version+  }++performInstallations :: Verbosity+                     -> InstallContext+                     -> PackageIndex InstalledPackage+                     -> InstallPlan+                     -> IO InstallPlan+performInstallations verbosity+  (packageDBs, _, comp, conf,+   globalFlags, configFlags, configExFlags, installFlags)+  installedPkgIndex installPlan = do++  executeInstallPlan installPlan $ \cpkg ->+    installConfiguredPackage platform compid configFlags+                             cpkg $ \configFlags' src pkg ->+      fetchSourcePackage verbosity src $ \src' ->+        installLocalPackage verbosity (packageId pkg) src' $ \mpath ->+          installUnpackedPackage verbosity+                                 (setupScriptOptions installedPkgIndex)+                                 miscOptions configFlags' installFlags+                                 compid pkg mpath useLogFile++  where+    platform = InstallPlan.planPlatform installPlan+    compid   = InstallPlan.planCompiler installPlan++    setupScriptOptions index = SetupScriptOptions {+      useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),+      useCompiler      = Just comp,+      -- Hack: we typically want to allow the UserPackageDB for finding the+      -- Cabal lib when compiling any Setup.hs even if we're doing a global+      -- install. However we also allow looking in a specific package db.+      usePackageDB     = if UserPackageDB `elem` packageDBs+                           then packageDBs+                           else let (db@GlobalPackageDB:dbs) = packageDBs+                                 in db : UserPackageDB : dbs,+                                --TODO: use Ord instance:+                                -- insert UserPackageDB packageDBs+      usePackageIndex  = if UserPackageDB `elem` packageDBs+                           then Just index+                           else Nothing,+      useProgramConfig = conf,+      useDistPref      = fromFlagOrDefault+                           (useDistPref defaultSetupScriptOptions)+                           (configDistPref configFlags),+      useLoggingHandle = Nothing,+      useWorkingDir    = Nothing+    }+    reportingLevel = fromFlag (installBuildReports installFlags)+    logsDir        = fromFlag (globalLogsDir globalFlags)+    useLogFile :: Maybe (PackageIdentifier -> FilePath)+    useLogFile = fmap substLogFileName logFileTemplate+      where+        logFileTemplate :: Maybe PathTemplate+        logFileTemplate --TODO: separate policy from mechanism+          | reportingLevel == DetailedReports+          = Just $ toPathTemplate $ logsDir </> "$pkgid" <.> "log"+          | otherwise+          = flagToMaybe (installLogFile installFlags)+    substLogFileName template pkg = fromPathTemplate+                                  . substPathTemplate env+                                  $ template+      where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)+    miscOptions  = InstallMisc {+      rootCmd    = if fromFlag (configUserInstall configFlags)+                     then Nothing      -- ignore --root-cmd if --user.+                     else flagToMaybe (installRootCmd installFlags),+      libVersion = flagToMaybe (configCabalVersion configExFlags)+    }+++executeInstallPlan :: Monad m+                   => InstallPlan+                   -> (ConfiguredPackage -> m BuildResult)+                   -> m InstallPlan+executeInstallPlan plan installPkg = case InstallPlan.ready plan of+  []       -> return plan+  (pkg: _) -> do buildResult <- installPkg pkg+                 let plan' = updatePlan (packageId pkg) buildResult plan+                 executeInstallPlan plan' installPkg+  where+    updatePlan pkgid (Right buildSuccess) =+      InstallPlan.completed pkgid buildSuccess++    updatePlan pkgid (Left buildFailure) =+      InstallPlan.failed    pkgid buildFailure depsFailure+      where+        depsFailure = DependentFailed pkgid+        -- So this first pkgid failed for whatever reason (buildFailure).+        -- All the other packages that depended on this pkgid, which we+        -- now cannot build, we mark as failing due to 'DependentFailed'+        -- which kind of means it was not their fault.+++-- | Call an installer for an 'SourcePackage' but override the configure+-- flags with the ones given by the 'ConfiguredPackage'. In particular the+-- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- versioned package dependencies. So we ignore any previous partial flag+-- assignment or dependency constraints and use the new ones.+--+installConfiguredPackage :: Platform -> CompilerId+                         ->  ConfigFlags -> ConfiguredPackage+                         -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                                         -> PackageDescription -> a)+                         -> a+installConfiguredPackage platform comp configFlags+  (ConfiguredPackage (SourcePackage _ gpkg source) flags deps)+  installPkg = installPkg configFlags {+    configConfigurationsFlags = flags,+    configConstraints = map thisPackageVersion deps+  } source pkg+  where+    pkg = case finalizePackageDescription flags+           (const True)+           platform comp [] gpkg of+      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Right (desc, _) -> desc++fetchSourcePackage+  :: Verbosity+  -> PackageLocation (Maybe FilePath)+  -> (PackageLocation FilePath -> IO BuildResult)+  -> IO BuildResult+fetchSourcePackage verbosity src installPkg = do+  fetched <- checkFetched src+  case fetched of+    Just src' -> installPkg src'+    Nothing   -> onFailure DownloadFailed $+                   fetchPackage verbosity src >>= installPkg+++installLocalPackage+  :: Verbosity -> PackageIdentifier -> PackageLocation FilePath+  -> (Maybe FilePath -> IO BuildResult)+  -> IO BuildResult+installLocalPackage verbosity pkgid location installPkg = case location of++    LocalUnpackedPackage dir ->+      installPkg (Just dir)++    LocalTarballPackage tarballPath ->+      installLocalTarballPackage verbosity pkgid tarballPath installPkg++    RemoteTarballPackage _ tarballPath ->+      installLocalTarballPackage verbosity pkgid tarballPath installPkg++    RepoTarballPackage _ _ tarballPath ->+      installLocalTarballPackage verbosity pkgid tarballPath installPkg+++installLocalTarballPackage+  :: Verbosity -> PackageIdentifier -> FilePath+  -> (Maybe FilePath -> IO BuildResult)+  -> IO BuildResult+installLocalTarballPackage verbosity pkgid tarballPath installPkg = do+  tmp <- getTemporaryDirectory+  withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->+    onFailure UnpackFailed $ do+      info verbosity $ "Extracting " ++ tarballPath+                    ++ " to " ++ tmpDirPath ++ "..."+      let relUnpackedPath = display pkgid+          absUnpackedPath = tmpDirPath </> relUnpackedPath+          descFilePath = absUnpackedPath+                     </> display (packageName pkgid) <.> "cabal"+      extractTarGzFile tmpDirPath relUnpackedPath tarballPath+      exists <- doesFileExist descFilePath+      when (not exists) $+        die $ "Package .cabal file not found: " ++ show descFilePath+      installPkg (Just absUnpackedPath)+++installUnpackedPackage :: Verbosity+                   -> SetupScriptOptions+                   -> InstallMisc+                   -> ConfigFlags+                   -> InstallFlags+                   -> CompilerId+                   -> PackageDescription+                   -> Maybe FilePath -- ^ Directory to change to before starting the installation.+                   -> Maybe (PackageIdentifier -> FilePath) -- ^ File to log output to (if any)+                   -> IO BuildResult+installUnpackedPackage verbosity scriptOptions miscOptions+                       configFlags installConfigFlags+                       compid pkg workingDir useLogFile =++  -- Configure phase+  onFailure ConfigureFailed $ do+    setup configureCommand configureFlags++  -- Build phase+    onFailure BuildFailed $ do+      setup buildCommand' buildFlags++  -- Doc generation phase+      docsResult <- if shouldHaddock+        then (do setup haddockCommand haddockFlags+                 return DocsOk)+               `catchIO`   (\_ -> return DocsFailed)+               `catchExit` (\_ -> return DocsFailed)+        else return DocsNotTried++  -- Tests phase+      testsResult <- return TestsNotTried  --TODO: add optional tests++  -- Install phase+      onFailure InstallFailed $+        withWin32SelfUpgrade verbosity configFlags compid pkg $ do+          case rootCmd miscOptions of+            (Just cmd) -> reexec cmd+            Nothing    -> setup Cabal.installCommand installFlags+          return (Right (BuildOk docsResult testsResult))++  where+    configureFlags   = filterConfigureFlags configFlags {+      configVerbosity = toFlag verbosity'+    }+    buildCommand'    = buildCommand defaultProgramConfiguration+    buildFlags   _   = emptyBuildFlags {+      buildDistPref  = configDistPref configFlags,+      buildVerbosity = toFlag verbosity'+    }+    shouldHaddock    = fromFlag (installDocumentation installConfigFlags)+    haddockFlags _   = emptyHaddockFlags {+      haddockDistPref  = configDistPref configFlags,+      haddockVerbosity = toFlag verbosity'+    }+    installFlags _   = Cabal.emptyInstallFlags {+      Cabal.installDistPref  = configDistPref configFlags,+      Cabal.installVerbosity = toFlag verbosity'+    }+    verbosity' | isJust useLogFile = max Verbosity.verbose verbosity+               | otherwise         = verbosity+    setup cmd flags  = do+      logFileHandle <- case useLogFile of+        Nothing          -> return Nothing+        Just mkLogFileName -> do+          let logFileName = mkLogFileName (packageId pkg)+              logDir      = takeDirectory logFileName+          unless (null logDir) $ createDirectoryIfMissing True logDir+          logFile <- openFile logFileName AppendMode+          return (Just logFile)++      setupWrapper verbosity+        scriptOptions { useLoggingHandle = logFileHandle+                      , useWorkingDir    = workingDir }+        (Just pkg)+        cmd flags []+    reexec cmd = do+      -- look for our on executable file and re-exec ourselves using+      -- a helper program like sudo to elevate priviledges:+      bindir <- getBinDir+      let self = bindir </> "cabal" <.> exeExtension+      weExist <- doesFileExist self+      if weExist+        then inDir workingDir $+               rawSystemExit verbosity cmd+                 [self, "install", "--only"+                 ,"--verbose=" ++ showForCabal verbosity]+        else die $ "Unable to find cabal executable at: " ++ self+++-- helper+onFailure :: (SomeException -> BuildFailure) -> IO BuildResult -> IO BuildResult+onFailure result action =+#if MIN_VERSION_base(4,0,0)+  action `catches`+    [ Handler $ \ioe  -> handler (ioe  :: IOException)+    , Handler $ \exit -> handler (exit :: ExitCode)+    ]+  where+    handler :: Exception e => e -> IO BuildResult+    handler = return . Left . result . toException+#else+  action+    `catchIO`   (return . Left . result . IOException)+    `catchExit` (return . Left . result . ExitException)+#endif+++-- ------------------------------------------------------------+-- * Wierd windows hacks+-- ------------------------------------------------------------++withWin32SelfUpgrade :: Verbosity+                     -> ConfigFlags+                     -> CompilerId+                     -> PackageDescription+                     -> IO a -> IO a+withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action+withWin32SelfUpgrade verbosity configFlags compid pkg action = do++  defaultDirs <- InstallDirs.defaultInstallDirs+                   compFlavor+                   (fromFlag (configUserInstall configFlags))+                   (PackageDescription.hasLibs pkg)++  Win32SelfUpgrade.possibleSelfUpgrade verbosity+    (exeInstallPaths defaultDirs) action++  where+    pkgid = packageId pkg+    (CompilerId compFlavor _) = compid++    exeInstallPaths defaultDirs =+      [ InstallDirs.bindir absoluteDirs </> exeName <.> exeExtension+      | exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe)+      , let exeName = prefix ++ PackageDescription.exeName exe ++ suffix+            prefix  = substTemplate prefixTemplate+            suffix  = substTemplate suffixTemplate ]+      where+        fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+        prefixTemplate = fromFlagTemplate (configProgPrefix configFlags)+        suffixTemplate = fromFlagTemplate (configProgSuffix configFlags)+        templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)+        absoluteDirs   = InstallDirs.absoluteInstallDirs+                           pkgid compid InstallDirs.NoCopyDest templateDirs+        substTemplate  = InstallDirs.fromPathTemplate+                       . InstallDirs.substPathTemplate env+          where env = InstallDirs.initialPathTemplateEnv pkgid compid
+ cabal/cabal-install/Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,511 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallPlan+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Package installation plan+--+-----------------------------------------------------------------------------+module Distribution.Client.InstallPlan (+  InstallPlan,+  ConfiguredPackage(..),+  PlanPackage(..),++  -- * Operations on 'InstallPlan's+  new,+  toList,+  ready,+  completed,+  failed,+  remove,++  -- ** Query functions+  planPlatform,+  planCompiler,++  -- * Checking valididy of plans+  valid,+  closed,+  consistent,+  acyclic,+  configuredPackageValid,++  -- ** Details on invalid plans+  PlanProblem(..),+  showPlanProblem,+  PackageProblem(..),+  showPackageProblem,+  problems,+  configuredPackageProblems+  ) where++import Distribution.Client.Types+         ( SourcePackage(packageDescription), ConfiguredPackage(..)+         , InstalledPackage+         , BuildFailure, BuildSuccess )+import Distribution.Package+         ( PackageIdentifier(..), PackageName(..), Package(..), packageName+         , PackageFixedDeps(..), Dependency(..) )+import Distribution.Version+         ( Version, withinRange )+import Distribution.PackageDescription+         ( GenericPackageDescription(genPackageFlags)+         , Flag(flagName), FlagName(..) )+import Distribution.Client.PackageUtils+         ( externalBuildDepends )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Client.PackageIndex+         ( PackageIndex )+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Text+         ( display )+import Distribution.System+         ( Platform )+import Distribution.Compiler+         ( CompilerId(..) )+import Distribution.Client.Utils+         ( duplicates, duplicatesBy, mergeBy, MergeResult(..) )+import Distribution.Simple.Utils+         ( comparing, intercalate )++import Data.List+         ( sort, sortBy )+import Data.Maybe+         ( fromMaybe )+import qualified Data.Graph as Graph+import Data.Graph (Graph)+import Control.Exception+         ( assert )++-- When cabal tries to install a number of packages, including all their+-- dependencies it has a non-trivial problem to solve.+--+-- The Problem:+--+-- In general we start with a set of installed packages and a set of source+-- packages.+--+-- Installed packages have fixed dependencies. They have already been built and+-- we know exactly what packages they were built against, including their exact+-- versions. +--+-- Source package have somewhat flexible dependencies. They are specified as+-- version ranges, though really they're predicates. To make matters worse they+-- have conditional flexible dependencies. Configuration flags can affect which+-- packages are required and can place additional constraints on their+-- versions.+--+-- These two sets of package can and usually do overlap. There can be installed+-- packages that are also available as source packages which means they could+-- be re-installed if required, though there will also be packages which are+-- not available as source and cannot be re-installed. Very often there will be+-- extra versions available than are installed. Sometimes we may like to prefer+-- installed packages over source ones or perhaps always prefer the latest+-- available version whether installed or not.+--+-- The goal is to calculate an installation plan that is closed, acyclic and+-- consistent and where every configured package is valid.+--+-- An installation plan is a set of packages that are going to be used+-- together. It will consist of a mixture of installed packages and source+-- packages along with their exact version dependencies. An installation plan+-- is closed if for every package in the set, all of its dependencies are+-- also in the set. It is consistent if for every package in the set, all+-- dependencies which target that package have the same version.++-- Note that plans do not necessarily compose. You might have a valid plan for+-- package A and a valid plan for package B. That does not mean the composition+-- is simultaniously valid for A and B. In particular you're most likely to+-- have problems with inconsistent dependencies.+-- On the other hand it is true that every closed sub plan is valid.++data PlanPackage = PreExisting InstalledPackage+                 | Configured  ConfiguredPackage+                 | Installed   ConfiguredPackage BuildSuccess+                 | Failed      ConfiguredPackage BuildFailure++instance Package PlanPackage where+  packageId (PreExisting pkg) = packageId pkg+  packageId (Configured  pkg) = packageId pkg+  packageId (Installed pkg _) = packageId pkg+  packageId (Failed    pkg _) = packageId pkg++instance PackageFixedDeps PlanPackage where+  depends (PreExisting pkg) = depends pkg+  depends (Configured  pkg) = depends pkg+  depends (Installed pkg _) = depends pkg+  depends (Failed    pkg _) = depends pkg++data InstallPlan = InstallPlan {+    planIndex    :: PackageIndex PlanPackage,+    planGraph    :: Graph,+    planGraphRev :: Graph,+    planPkgOf    :: Graph.Vertex -> PlanPackage,+    planVertexOf :: PackageIdentifier -> Graph.Vertex,+    planPlatform :: Platform,+    planCompiler :: CompilerId+  }++invariant :: InstallPlan -> Bool+invariant plan =+  valid (planPlatform plan) (planCompiler plan) (planIndex plan)++internalError :: String -> a+internalError msg = error $ "InstallPlan: internal error: " ++ msg++-- | Build an installation plan from a valid set of resolved packages.+--+new :: Platform -> CompilerId -> PackageIndex PlanPackage+    -> Either [PlanProblem] InstallPlan+new platform compiler index =+  case problems platform compiler index of+    [] -> Right InstallPlan {+            planIndex    = index,+            planGraph    = graph,+            planGraphRev = Graph.transposeG graph,+            planPkgOf    = vertexToPkgId,+            planVertexOf = fromMaybe noSuchPkgId . pkgIdToVertex,+            planPlatform = platform,+            planCompiler = compiler+          }+      where (graph, vertexToPkgId, pkgIdToVertex) =+              PackageIndex.dependencyGraph index+            noSuchPkgId = internalError "package is not in the graph"+    probs -> Left probs++toList :: InstallPlan -> [PlanPackage]+toList = PackageIndex.allPackages . planIndex++-- | Remove packages from the install plan. This will result in an+-- error if there are remaining packages that depend on any matching+-- package. This is primarily useful for obtaining an install plan for+-- the dependencies of a package or set of packages without actually+-- installing the package itself, as when doing development.+--+remove :: (PlanPackage -> Bool)+       -> InstallPlan+       -> Either [PlanProblem] InstallPlan+remove shouldRemove plan =+    new (planPlatform plan) (planCompiler plan) newIndex+  where+    newIndex = PackageIndex.fromList $+                 filter (not . shouldRemove) (toList plan)++-- | The packages that are ready to be installed. That is they are in the+-- configured state and have all their dependencies installed already.+-- The plan is complete if the result is @[]@.+--+ready :: InstallPlan -> [ConfiguredPackage]+ready plan = assert check readyPackages+  where+    check = if null readyPackages then null configuredPackages else True+    configuredPackages =+      [ pkg | Configured pkg <- PackageIndex.allPackages (planIndex plan) ]+    readyPackages = filter (all isInstalled . depends) configuredPackages+    isInstalled pkg =+      case PackageIndex.lookupPackageId (planIndex plan) pkg of+        Just (Configured  _) -> False+        Just (Failed    _ _) -> internalError depOnFailed+        Just (PreExisting _) -> True+        Just (Installed _ _) -> True+        Nothing              -> internalError incomplete+    incomplete  = "install plan is not closed"+    depOnFailed = "configured package depends on failed package"++-- | Marks a package in the graph as completed. Also saves the build result for+-- the completed package in the plan.+--+-- * The package must exist in the graph.+-- * The package must have had no uninstalled dependent packages.+--+completed :: PackageIdentifier+          -> BuildSuccess+          -> InstallPlan -> InstallPlan+completed pkgid buildResult plan = assert (invariant plan') plan'+  where+    plan'     = plan {+                  planIndex = PackageIndex.insert installed (planIndex plan)+                }+    installed = Installed (lookupConfiguredPackage plan pkgid) buildResult++-- | Marks a package in the graph as having failed. It also marks all the+-- packages that depended on it as having failed.+--+-- * The package must exist in the graph and be in the configured state.+--+failed :: PackageIdentifier -- ^ The id of the package that failed to install+       -> BuildFailure      -- ^ The build result to use for the failed package+       -> BuildFailure      -- ^ The build result to use for its dependencies+       -> InstallPlan+       -> InstallPlan+failed pkgid buildResult buildResult' plan = assert (invariant plan') plan'+  where+    plan'    = plan {+                 planIndex = PackageIndex.merge (planIndex plan) failures+               }+    pkg      = lookupConfiguredPackage plan pkgid+    failures = PackageIndex.fromList+             $ Failed pkg buildResult+             : [ Failed pkg' buildResult'+               | Just pkg' <- map checkConfiguredPackage+                            $ packagesThatDependOn plan pkgid ]++-- | lookup the reachable packages in the reverse dependency graph+--+packagesThatDependOn :: InstallPlan+                     -> PackageIdentifier -> [PlanPackage]+packagesThatDependOn plan = map (planPkgOf plan)+                          . tail+                          . Graph.reachable (planGraphRev plan)+                          . planVertexOf plan++-- | lookup a package that we expect to be in the configured state+--+lookupConfiguredPackage :: InstallPlan+                        -> PackageIdentifier -> ConfiguredPackage+lookupConfiguredPackage plan pkgid =+  case PackageIndex.lookupPackageId (planIndex plan) pkgid of+    Just (Configured pkg) -> pkg+    _  -> internalError $ "not configured or no such pkg " ++ display pkgid++-- | check a package that we expect to be in the configured or failed state+--+checkConfiguredPackage :: PlanPackage -> Maybe ConfiguredPackage+checkConfiguredPackage (Configured pkg) = Just pkg+checkConfiguredPackage (Failed     _ _) = Nothing+checkConfiguredPackage pkg                =+  internalError $ "not configured or no such pkg " ++ display (packageId pkg)++-- ------------------------------------------------------------+-- * Checking valididy of plans+-- ------------------------------------------------------------++-- | A valid installation plan is a set of packages that is 'acyclic',+-- 'closed' and 'consistent'. Also, every 'ConfiguredPackage' in the+-- plan has to have a valid configuration (see 'configuredPackageValid').+--+-- * if the result is @False@ use 'problems' to get a detailed list.+--+valid :: Platform -> CompilerId -> PackageIndex PlanPackage -> Bool+valid platform comp index = null (problems platform comp index)++data PlanProblem =+     PackageInvalid       ConfiguredPackage [PackageProblem]+   | PackageMissingDeps   PlanPackage [PackageIdentifier]+   | PackageCycle         [PlanPackage]+   | PackageInconsistency PackageName [(PackageIdentifier, Version)]+   | PackageStateInvalid  PlanPackage PlanPackage++showPlanProblem :: PlanProblem -> String+showPlanProblem (PackageInvalid pkg packageProblems) =+     "Package " ++ display (packageId pkg)+  ++ " has an invalid configuration, in particular:\n"+  ++ unlines [ "  " ++ showPackageProblem problem+             | problem <- packageProblems ]++showPlanProblem (PackageMissingDeps pkg missingDeps) =+     "Package " ++ display (packageId pkg)+  ++ " depends on the following packages which are missing from the plan "+  ++ intercalate ", " (map display missingDeps)++showPlanProblem (PackageCycle cycleGroup) =+     "The following packages are involved in a dependency cycle "+  ++ intercalate ", " (map (display.packageId) cycleGroup)++showPlanProblem (PackageInconsistency name inconsistencies) =+     "Package " ++ display name+  ++ " is required by several packages,"+  ++ " but they require inconsistent versions:\n"+  ++ unlines [ "  package " ++ display pkg ++ " requires "+                            ++ display (PackageIdentifier name ver)+             | (pkg, ver) <- inconsistencies ]++showPlanProblem (PackageStateInvalid pkg pkg') =+     "Package " ++ display (packageId pkg)+  ++ " is in the " ++ showPlanState pkg+  ++ " state but it depends on package " ++ display (packageId pkg')+  ++ " which is in the " ++ showPlanState pkg'+  ++ " state"+  where+    showPlanState (PreExisting _) = "pre-existing"+    showPlanState (Configured  _) = "configured"+    showPlanState (Installed _ _) = "installed"+    showPlanState (Failed    _ _) = "failed"++-- | For an invalid plan, produce a detailed list of problems as human readable+-- error messages. This is mainly intended for debugging purposes.+-- Use 'showPlanProblem' for a human readable explanation.+--+problems :: Platform -> CompilerId+         -> PackageIndex PlanPackage -> [PlanProblem]+problems platform comp index =+     [ PackageInvalid pkg packageProblems+     | Configured pkg <- PackageIndex.allPackages index+     , let packageProblems = configuredPackageProblems platform comp pkg+     , not (null packageProblems) ]++  ++ [ PackageMissingDeps pkg missingDeps+     | (pkg, missingDeps) <- PackageIndex.brokenPackages index ]++  ++ [ PackageCycle cycleGroup+     | cycleGroup <- PackageIndex.dependencyCycles index ]++  ++ [ PackageInconsistency name inconsistencies+     | (name, inconsistencies) <- PackageIndex.dependencyInconsistencies index ]++  ++ [ PackageStateInvalid pkg pkg'+     | pkg <- PackageIndex.allPackages index+     , Just pkg' <- map (PackageIndex.lookupPackageId index) (depends pkg)+     , not (stateDependencyRelation pkg pkg') ]++-- | The graph of packages (nodes) and dependencies (edges) must be acyclic.+--+-- * if the result is @False@ use 'PackageIndex.dependencyCycles' to find out+--   which packages are involved in dependency cycles.+--+acyclic :: PackageIndex PlanPackage -> Bool+acyclic = null . PackageIndex.dependencyCycles++-- | An installation plan is closed if for every package in the set, all of+-- its dependencies are also in the set. That is, the set is closed under the+-- dependency relation.+--+-- * if the result is @False@ use 'PackageIndex.brokenPackages' to find out+--   which packages depend on packages not in the index.+--+closed :: PackageIndex PlanPackage -> Bool+closed = null . PackageIndex.brokenPackages++-- | An installation plan is consistent if all dependencies that target a+-- single package name, target the same version.+--+-- This is slightly subtle. It is not the same as requiring that there be at+-- most one version of any package in the set. It only requires that of+-- packages which have more than one other package depending on them. We could+-- actually make the condition even more precise and say that different+-- versions are ok so long as they are not both in the transative closure of+-- any other package (or equivalently that their inverse closures do not+-- intersect). The point is we do not want to have any packages depending+-- directly or indirectly on two different versions of the same package. The+-- current definition is just a safe aproximation of that.+--+-- * if the result is @False@ use 'PackageIndex.dependencyInconsistencies' to+--   find out which packages are.+--+consistent :: PackageIndex PlanPackage -> Bool+consistent = null . PackageIndex.dependencyInconsistencies++-- | The states of packages have that depend on each other must respect+-- this relation. That is for very case where package @a@ depends on+-- package @b@ we require that @dependencyStatesOk a b = True@.+--+stateDependencyRelation :: PlanPackage -> PlanPackage -> Bool+stateDependencyRelation (PreExisting _) (PreExisting _) = True++stateDependencyRelation (Configured  _) (PreExisting _) = True+stateDependencyRelation (Configured  _) (Configured  _) = True+stateDependencyRelation (Configured  _) (Installed _ _) = True++stateDependencyRelation (Installed _ _) (PreExisting _) = True+stateDependencyRelation (Installed _ _) (Installed _ _) = True++stateDependencyRelation (Failed    _ _) (PreExisting _) = True+-- failed can depends on configured because a package can depend on+-- several other packages and if one of the deps fail then we fail+-- but we still depend on the other ones that did not fail:+stateDependencyRelation (Failed    _ _) (Configured  _) = True+stateDependencyRelation (Failed    _ _) (Installed _ _) = True+stateDependencyRelation (Failed    _ _) (Failed    _ _) = True++stateDependencyRelation _               _               = False++-- | A 'ConfiguredPackage' is valid if the flag assignment is total and if+-- in the configuration given by the flag assignment, all the package+-- dependencies are satisfied by the specified packages.+--+configuredPackageValid :: Platform -> CompilerId -> ConfiguredPackage -> Bool+configuredPackageValid platform comp pkg =+  null (configuredPackageProblems platform comp pkg)++data PackageProblem = DuplicateFlag FlagName+                    | MissingFlag   FlagName+                    | ExtraFlag     FlagName+                    | DuplicateDeps [PackageIdentifier]+                    | MissingDep    Dependency+                    | ExtraDep      PackageIdentifier+                    | InvalidDep    Dependency PackageIdentifier++showPackageProblem :: PackageProblem -> String+showPackageProblem (DuplicateFlag (FlagName flag)) =+  "duplicate flag in the flag assignment: " ++ flag++showPackageProblem (MissingFlag (FlagName flag)) =+  "missing an assignment for the flag: " ++ flag++showPackageProblem (ExtraFlag (FlagName flag)) =+  "extra flag given that is not used by the package: " ++ flag++showPackageProblem (DuplicateDeps pkgids) =+     "duplicate packages specified as selected dependencies: "+  ++ intercalate ", " (map display pkgids)++showPackageProblem (MissingDep dep) =+     "the package has a dependency " ++ display dep+  ++ " but no package has been selected to satisfy it."++showPackageProblem (ExtraDep pkgid) =+     "the package configuration specifies " ++ display pkgid+  ++ " but (with the given flag assignment) the package does not actually"+  ++ " depend on any version of that package."++showPackageProblem (InvalidDep dep pkgid) =+     "the package depends on " ++ display dep+  ++ " but the configuration specifies " ++ display pkgid+  ++ " which does not satisfy the dependency."++configuredPackageProblems :: Platform -> CompilerId+                          -> ConfiguredPackage -> [PackageProblem]+configuredPackageProblems platform comp+  (ConfiguredPackage pkg specifiedFlags specifiedDeps) =+     [ DuplicateFlag flag | ((flag,_):_) <- duplicates specifiedFlags ]+  ++ [ MissingFlag flag | OnlyInLeft  flag <- mergedFlags ]+  ++ [ ExtraFlag   flag | OnlyInRight flag <- mergedFlags ]+  ++ [ DuplicateDeps pkgs+     | pkgs <- duplicatesBy (comparing packageName) specifiedDeps ]+  ++ [ MissingDep dep       | OnlyInLeft  dep       <- mergedDeps ]+  ++ [ ExtraDep       pkgid | OnlyInRight     pkgid <- mergedDeps ]+  ++ [ InvalidDep dep pkgid | InBoth      dep pkgid <- mergedDeps+                            , not (packageSatisfiesDependency pkgid dep) ]+  where+    mergedFlags = mergeBy compare+      (sort $ map flagName (genPackageFlags (packageDescription pkg)))+      (sort $ map fst specifiedFlags)++    mergedDeps = mergeBy+      (\dep pkgid -> dependencyName dep `compare` packageName pkgid)+      (sortBy (comparing dependencyName) requiredDeps)+      (sortBy (comparing packageName)    specifiedDeps)++    packageSatisfiesDependency+      (PackageIdentifier name  version)+      (Dependency        name' versionRange) = assert (name == name') $+        version `withinRange` versionRange++    dependencyName (Dependency name _) = name++    requiredDeps :: [Dependency]+    requiredDeps =+      --TODO: use something lower level than finalizePackageDescription+      case finalizePackageDescription specifiedFlags+         (const True)+         platform comp+         []+         (packageDescription pkg) of+        Right (resolvedPkg, _) -> externalBuildDepends resolvedPkg+        Left  _ -> error "configuredPackageInvalidDeps internal error"
+ cabal/cabal-install/Distribution/Client/InstallSymlink.hs view
@@ -0,0 +1,238 @@+{-# OPTIONS -cpp #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp  #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.InstallSymlink+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Managing installing binaries with symlinks.+-----------------------------------------------------------------------------+module Distribution.Client.InstallSymlink (+    symlinkBinaries,+    symlinkBinary,+  ) where++#if mingw32_HOST_OS || mingw32_TARGET_OS++import Distribution.Package (PackageIdentifier)+import Distribution.Client.InstallPlan (InstallPlan)+import Distribution.Client.Setup (InstallFlags)+import Distribution.Simple.Setup (ConfigFlags)++symlinkBinaries :: ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> IO [(PackageIdentifier, String, FilePath)]+symlinkBinaries _ _ _ = return []++symlinkBinary :: FilePath -> FilePath -> String -> String -> IO Bool+symlinkBinary _ _ _ _ = fail "Symlinking feature not available on Windows"++#else++import Distribution.Client.Types+         ( SourcePackage(..), ConfiguredPackage(..) )+import Distribution.Client.Setup+         ( InstallFlags(installSymlinkBinDir) )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.InstallPlan (InstallPlan)++import Distribution.Package+         ( PackageIdentifier, Package(packageId) )+import Distribution.Compiler+         ( CompilerId(..) )+import qualified Distribution.PackageDescription as PackageDescription+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Simple.Setup+         ( ConfigFlags(..), fromFlag, fromFlagOrDefault, flagToMaybe )+import qualified Distribution.Simple.InstallDirs as InstallDirs++import System.Posix.Files+         ( getSymbolicLinkStatus, isSymbolicLink, createSymbolicLink+         , removeLink )+import System.Directory+         ( canonicalizePath )+import System.FilePath+         ( (</>), splitPath, joinPath, isAbsolute )++import Prelude hiding (catch, ioError)+import System.IO.Error+         ( catch, isDoesNotExistError, ioError )+import Control.Exception+         ( assert )+import Data.Maybe+         ( catMaybes )++-- | We would like by default to install binaries into some location that is on+-- the user's PATH. For per-user installations on Unix systems that basically+-- means the @~/bin/@ directory. On the majority of platforms the @~/bin/@+-- directory will be on the user's PATH. However some people are a bit nervous+-- about letting a package manager install programs into @~/bin/@.+--+-- A comprimise solution is that instead of installing binaries directly into+-- @~/bin/@, we could install them in a private location under @~/.cabal/bin@+-- and then create symlinks in @~/bin/@. We can be careful when setting up the+-- symlinks that we do not overwrite any binary that the user installed. We can+-- check if it was a symlink we made because it would point to the private dir+-- where we install our binaries. This means we can install normally without+-- worrying and in a later phase set up symlinks, and if that fails then we+-- report it to the user, but even in this case the package is still in an ok+-- installed state.+--+-- This is an optional feature that users can choose to use or not. It is+-- controlled from the config file. Of course it only works on posix systems+-- with symlinks so is not available to Windows users.+--+symlinkBinaries :: ConfigFlags+                -> InstallFlags+                -> InstallPlan+                -> IO [(PackageIdentifier, String, FilePath)]+symlinkBinaries configFlags installFlags plan =+  case flagToMaybe (installSymlinkBinDir installFlags) of+    Nothing            -> return []+    Just symlinkBinDir+           | null exes -> return []+           | otherwise -> do+      publicBinDir  <- canonicalizePath symlinkBinDir+--    TODO: do we want to do this here? :+--      createDirectoryIfMissing True publicBinDir+      fmap catMaybes $ sequence+        [ do privateBinDir <- pkgBinDir pkg+             ok <- symlinkBinary+                     publicBinDir  privateBinDir+                     publicExeName privateExeName+             if ok+               then return Nothing+               else return (Just (pkgid, publicExeName,+                                  privateBinDir </> privateExeName))+        | (pkg, exe) <- exes+        , let publicExeName  = PackageDescription.exeName exe+              privateExeName = prefix ++ publicExeName ++ suffix+              pkgid  = packageId pkg+              prefix = substTemplate pkgid prefixTemplate+              suffix = substTemplate pkgid suffixTemplate ]+  where+    exes =+      [ (pkg, exe)+      | InstallPlan.Installed cpkg _ <- InstallPlan.toList plan+      , let pkg   = pkgDescription cpkg+      , exe <- PackageDescription.executables pkg+      , PackageDescription.buildable (PackageDescription.buildInfo exe) ]++    pkgDescription :: ConfiguredPackage -> PackageDescription+    pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags _) =+      case finalizePackageDescription flags+             (const True)+             platform compilerId [] pkg of+        Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+        Right (desc, _) -> desc++    -- This is sadly rather complicated. We're kind of re-doing part of the+    -- configuration for the package. :-(+    pkgBinDir :: PackageDescription -> IO FilePath+    pkgBinDir pkg = do+      defaultDirs <- InstallDirs.defaultInstallDirs+                       compilerFlavor+                       (fromFlag (configUserInstall configFlags))+                       (PackageDescription.hasLibs pkg)+      let templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault+                           defaultDirs (configInstallDirs configFlags)+          absoluteDirs = InstallDirs.absoluteInstallDirs+                           (packageId pkg) compilerId InstallDirs.NoCopyDest+                           templateDirs+      canonicalizePath (InstallDirs.bindir absoluteDirs)++    substTemplate pkgid = InstallDirs.fromPathTemplate+                        . InstallDirs.substPathTemplate env+      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId++    fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")+    prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)+    suffixTemplate   = fromFlagTemplate (configProgSuffix configFlags)+    platform         = InstallPlan.planPlatform plan+    compilerId@(CompilerId compilerFlavor _) = InstallPlan.planCompiler plan++symlinkBinary :: FilePath -- ^ The canonical path of the public bin dir+                          --   eg @/home/user/bin@+              -> FilePath -- ^ The canonical path of the private bin dir+                          --   eg @/home/user/.cabal/bin@+              -> String   -- ^ The name of the executable to go in the public+                          --   bin dir, eg @foo@+              -> String   -- ^ The name of the executable to in the private bin+                          --   dir, eg @foo-1.0@+              -> IO Bool  -- ^ If creating the symlink was sucessful. @False@+                          --   if there was another file there already that we+                          --   did not own. Other errors like permission errors+                          --   just propagate as exceptions.+symlinkBinary publicBindir privateBindir publicName privateName = do+  ok <- targetOkToOverwrite (publicBindir </> publicName)+                            (privateBindir </> privateName)+  case ok of+    NotOurFile    ->                     return False+    NotExists     ->           mkLink >> return True+    OkToOverwrite -> rmLink >> mkLink >> return True+  where+    relativeBindir = makeRelative publicBindir privateBindir+    mkLink = createSymbolicLink (relativeBindir </> privateName)+                                (publicBindir   </> publicName)+    rmLink = removeLink (publicBindir </> publicName)++-- | Check a filepath of a symlink that we would like to create to see if it+-- is ok. For it to be ok to overwrite it must either not already exist yet or+-- be a symlink to our target (in which case we can assume ownership).+--+targetOkToOverwrite :: FilePath -- ^ The filepath of the symlink to the private+                                -- binary that we would like to create+                    -> FilePath -- ^ The canonical path of the private binary.+                                -- Use 'canonicalizePath' to make this.+                    -> IO SymlinkStatus+targetOkToOverwrite symlink target = handleNotExist $ do+  status <- getSymbolicLinkStatus symlink+  if not (isSymbolicLink status)+    then return NotOurFile+    else do target' <- canonicalizePath symlink+            -- This relies on canonicalizePath handling symlinks+            if target == target'+              then return OkToOverwrite+              else return NotOurFile++  where+    handleNotExist action = catch action $ \ioexception ->+      -- If the target doesn't exist then there's no problem overwriting it!+      if isDoesNotExistError ioexception+        then return NotExists+        else ioError ioexception++data SymlinkStatus+   = NotExists     -- ^ The file doesn't exist so we can make a symlink.+   | OkToOverwrite -- ^ A symlink already exists, though it is ours. We'll+                   -- have to delete it first bemore we make a new symlink.+   | NotOurFile    -- ^ A file already exists and it is not one of our existing+                   -- symlinks (either because it is not a symlink or because+                   -- it points somewhere other than our managed space).+  deriving Show++-- | Take two canonical paths and produce a relative path to get from the first+-- to the second, even if it means adding @..@ path components.+--+makeRelative :: FilePath -> FilePath -> FilePath+makeRelative a b = assert (isAbsolute a && isAbsolute b) $+  let as = splitPath a+      bs = splitPath b+      commonLen = length $ takeWhile id $ zipWith (==) as bs+   in joinPath $ [ ".." | _  <- drop commonLen as ]+              ++ [  b'  | b' <- drop commonLen bs ]++#endif
+ cabal/cabal-install/Distribution/Client/List.hs view
@@ -0,0 +1,530 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.List+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2008-2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+--+-- Search for and print information about packages+-----------------------------------------------------------------------------+module Distribution.Client.List (+  list, info+  ) where++import Distribution.Package+         ( PackageName(..), Package(..), packageName, packageVersion+         , Dependency(..), thisPackageVersion, depends, simplifyDependency )+import Distribution.ModuleName (ModuleName)+import Distribution.License (License)+import qualified Distribution.InstalledPackageInfo as Installed+import qualified Distribution.PackageDescription   as Source+import Distribution.PackageDescription+         ( Flag(..), FlagName(..) )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription )++import Distribution.Simple.Compiler+        ( Compiler, PackageDBStack )+import Distribution.Simple.Program (ProgramConfiguration)+import Distribution.Simple.Utils+        ( equating, comparing, die, notice )+import Distribution.Simple.Setup (fromFlag)+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Version+         ( Version(..), VersionRange, withinRange, anyVersion+         , intersectVersionRanges, simplifyVersionRange )+import Distribution.Verbosity (Verbosity)+import Distribution.Text+         ( Text(disp), display )++import Distribution.Client.Types+         ( SourcePackage(..), Repo, SourcePackageDb(..)+         , InstalledPackage(..) )+import Distribution.Client.Dependency.Types+         ( PackageConstraint(..) )+import Distribution.Client.Targets+         ( UserTarget, resolveUserTargets, PackageSpecifier(..) )+import Distribution.Client.Setup+         ( GlobalFlags(..), ListFlags(..), InfoFlags(..) )+import Distribution.Client.Utils+         ( mergeBy, MergeResult(..) )+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.FetchUtils+         ( isFetched )++import Data.List+         ( sortBy, groupBy, sort, nub, intersperse, maximumBy, partition )+import Data.Maybe+         ( listToMaybe, fromJust, fromMaybe, isJust )+import qualified Data.Map as Map+import Data.Tree as Tree+import Control.Monad+         ( MonadPlus(mplus), join )+import Control.Exception+         ( assert )+import Text.PrettyPrint.HughesPJ as Disp+import System.Directory+         ( doesDirectoryExist )+++-- |Show information about packages+list :: Verbosity+     -> PackageDBStack+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> ListFlags+     -> [String]+     -> IO ()+list verbosity packageDBs repos comp conf listFlags pats = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos+    let sourcePkgIndex = packageIndex sourcePkgDb+        prefs name = fromMaybe anyVersion+                       (Map.lookup name (packagePreferences sourcePkgDb))++        pkgsInfo :: [(PackageName, [InstalledPackage], [SourcePackage])]+        pkgsInfo+            -- gather info for all packages+          | null pats = mergePackages (PackageIndex.allPackages installedPkgIndex)+                                      (PackageIndex.allPackages sourcePkgIndex)++            -- gather info for packages matching search term+          | otherwise = mergePackages (matchingPackages installedPkgIndex)+                                      (matchingPackages sourcePkgIndex)++        matches :: [PackageDisplayInfo]+        matches = [ mergePackageInfo pref+                      installedPkgs sourcePkgs selectedPkg False+                  | (pkgname, installedPkgs, sourcePkgs) <- pkgsInfo+                  , not onlyInstalled || not (null installedPkgs)+                  , let pref        = prefs pkgname+                        selectedPkg = latestWithPref pref sourcePkgs ]++    if simpleOutput+      then putStr $ unlines+             [ display (pkgName pkg) ++ " " ++ display version+             | pkg <- matches+             , version <- if onlyInstalled+                            then              installedVersions pkg+                            else nub . sort $ installedVersions pkg+                                           ++ sourceVersions    pkg ]+             -- Note: this only works because for 'list', one cannot currently+             -- specify any version constraints, so listing all installed+             -- and source ones works.+      else+        if null matches+            then notice verbosity "No matches found."+            else putStr $ unlines (map showPackageSummaryInfo matches)+  where+    onlyInstalled = fromFlag (listInstalled listFlags)+    simpleOutput  = fromFlag (listSimpleOutput listFlags)++    matchingPackages index =+      [ pkg+      | pat <- pats+      , (_, pkgs) <- PackageIndex.searchByNameSubstring index pat+      , pkg <- pkgs ]++info :: Verbosity+     -> PackageDBStack+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> GlobalFlags+     -> InfoFlags+     -> [UserTarget]+     -> IO ()+info verbosity packageDBs repos comp conf+     globalFlags _listFlags userTargets = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb   <- getSourcePackages    verbosity repos+    let sourcePkgIndex = packageIndex sourcePkgDb+        prefs name = fromMaybe anyVersion+                       (Map.lookup name (packagePreferences sourcePkgDb))++        -- Users may specify names of packages that are only installed, not+        -- just available source packages, so we must resolve targets using+        -- the combination of installed and source packages.+    let sourcePkgs' = PackageIndex.fromList+                    $ map packageId (PackageIndex.allPackages installedPkgIndex)+                   ++ map packageId (PackageIndex.allPackages sourcePkgIndex)+    pkgSpecifiers <- resolveUserTargets verbosity+                       (fromFlag $ globalWorldFile globalFlags)+                       sourcePkgs' userTargets++    pkgsinfo      <- sequence+                       [ do pkginfo <- either die return $+                                         gatherPkgInfo prefs+                                           installedPkgIndex sourcePkgIndex+                                           pkgSpecifier+                            updateFileSystemPackageDetails pkginfo+                       | pkgSpecifier <- pkgSpecifiers ]++    putStr $ unlines (map showPackageDetailedInfo pkgsinfo)++  where+    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (NamedPackage name constraints)+      | null (selectedInstalledPkgs) && null (selectedSourcePkgs)+      = Left $ "There is no available version of " ++ display name+            ++ " that satisfies "+            ++ display (simplifyVersionRange verConstraint)++      | otherwise+      = Right $ mergePackageInfo pref installedPkgs+                                 sourcePkgs  selectedSourcePkg+                                 showPkgVersion+      where+        pref           = prefs name+        installedPkgs  = PackageIndex.lookupPackageName installedPkgIndex name+        sourcePkgs     = PackageIndex.lookupPackageName sourcePkgIndex name++        selectedInstalledPkgs = PackageIndex.lookupDependency installedPkgIndex+                                    (Dependency name verConstraint)+        selectedSourcePkgs    = PackageIndex.lookupDependency sourcePkgIndex+                                    (Dependency name verConstraint)+        selectedSourcePkg     = latestWithPref pref selectedSourcePkgs++                         -- display a specific package version if the user+                         -- supplied a non-trivial version constraint+        showPkgVersion = not (null verConstraints)+        verConstraint  = foldr intersectVersionRanges anyVersion verConstraints+        verConstraints = [ vr | PackageConstraintVersion _ vr <- constraints ]++    gatherPkgInfo prefs installedPkgIndex sourcePkgIndex (SpecificSourcePackage pkg) =+        Right $ mergePackageInfo pref installedPkgs sourcePkgs+                                 selectedPkg True+      where+        name          = packageName pkg+        pref          = prefs name+        installedPkgs = PackageIndex.lookupPackageName installedPkgIndex name+        sourcePkgs    = PackageIndex.lookupPackageName sourcePkgIndex name+        selectedPkg   = Just pkg+++-- | The info that we can display for each package. It is information per+-- package name and covers all installed and avilable versions.+--+data PackageDisplayInfo = PackageDisplayInfo {+    pkgName           :: PackageName,+    selectedVersion   :: Maybe Version,+    selectedSourcePkg :: Maybe SourcePackage,+    installedVersions :: [Version],+    sourceVersions    :: [Version],+    preferredVersions :: VersionRange,+    homepage          :: String,+    bugReports        :: String,+    sourceRepo        :: String,+    synopsis          :: String,+    description       :: String,+    category          :: String,+    license           :: License,+    author            :: String,+    maintainer        :: String,+    dependencies      :: [Dependency],+    flags             :: [Flag],+    hasLib            :: Bool,+    hasExe            :: Bool,+    executables       :: [String],+    modules           :: [ModuleName],+    haddockHtml       :: FilePath,+    haveTarball       :: Bool+  }++showPackageSummaryInfo :: PackageDisplayInfo -> String+showPackageSummaryInfo pkginfo =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+     char '*' <+> disp (pkgName pkginfo)+     $+$+     (nest 4 $ vcat [+       maybeShow (synopsis pkginfo) "Synopsis:" reflowParagraphs+     , text "Default available version:" <+>+       case selectedSourcePkg pkginfo of+         Nothing  -> text "[ Not available from any configured repository ]"+         Just pkg -> disp (packageVersion pkg)+     , text "Installed versions:" <+>+       case installedVersions pkginfo of+         []  | hasLib pkginfo -> text "[ Not installed ]"+             | otherwise      -> text "[ Unknown ]"+         versions             -> dispTopVersions 4+                                   (preferredVersions pkginfo) versions+     , maybeShow (homepage pkginfo) "Homepage:" text+     , text "License: " <+> text (display (license pkginfo))+     ])+     $+$ text ""+  where+    maybeShow [] _ _ = empty+    maybeShow l  s f = text s <+> (f l)++showPackageDetailedInfo :: PackageDisplayInfo -> String+showPackageDetailedInfo pkginfo =+  renderStyle (style {lineLength = 80, ribbonsPerLine = 1}) $+   char '*' <+> disp (pkgName pkginfo)+            <>  maybe empty (\v -> char '-' <> disp v) (selectedVersion pkginfo)+            <+> text (replicate (16 - length (display (pkgName pkginfo))) ' ')+            <>  parens pkgkind+   $+$+   (nest 4 $ vcat [+     entry "Synopsis"      synopsis     hideIfNull     reflowParagraphs+   , entry "Versions available" sourceVersions+           (altText null "[ Not available from server ]")+           (dispTopVersions 9 (preferredVersions pkginfo))+   , entry "Versions installed" installedVersions+           (altText null (if hasLib pkginfo then "[ Not installed ]"+                                            else "[ Unknown ]"))+           (dispTopVersions 4 (preferredVersions pkginfo))+   , entry "Homepage"      homepage     orNotSpecified text+   , entry "Bug reports"   bugReports   orNotSpecified text+   , entry "Description"   description  hideIfNull     reflowParagraphs+   , entry "Category"      category     hideIfNull     text+   , entry "License"       license      alwaysShow     disp+   , entry "Author"        author       hideIfNull     reflowLines+   , entry "Maintainer"    maintainer   hideIfNull     reflowLines+   , entry "Source repo"   sourceRepo   orNotSpecified text+   , entry "Executables"   executables  hideIfNull     (commaSep text)+   , entry "Flags"         flags        hideIfNull     (commaSep dispFlag)+   , entry "Dependencies"  dependencies hideIfNull     (commaSep disp)+   , entry "Documentation" haddockHtml  showIfInstalled text+   , entry "Cached"        haveTarball  alwaysShow     dispYesNo+   , if not (hasLib pkginfo) then empty else+     text "Modules:" $+$ nest 4 (vcat (map disp . sort . modules $ pkginfo))+   ])+   $+$ text ""+  where+    entry fname field cond format = case cond (field pkginfo) of+      Nothing           -> label <+> format (field pkginfo)+      Just Nothing      -> empty+      Just (Just other) -> label <+> text other+      where+        label   = text fname <> char ':' <> padding+        padding = text (replicate (13 - length fname ) ' ')++    normal      = Nothing+    hide        = Just Nothing+    replace msg = Just (Just msg)++    alwaysShow = const normal+    hideIfNull v = if null v then hide else normal+    showIfInstalled v+      | not isInstalled = hide+      | null v          = replace "[ Not installed ]"+      | otherwise       = normal+    altText nul msg v = if nul v then replace msg else normal+    orNotSpecified = altText null "[ Not specified ]"++    commaSep f = Disp.fsep . Disp.punctuate (Disp.char ',') . map f+    dispFlag f = case flagName f of FlagName n -> text n+    dispYesNo True  = text "Yes"+    dispYesNo False = text "No"++    isInstalled = not (null (installedVersions pkginfo))+    hasExes = length (executables pkginfo) >= 2+    --TODO: exclude non-buildable exes+    pkgkind | hasLib pkginfo && hasExes        = text "programs and library"+            | hasLib pkginfo && hasExe pkginfo = text "program and library"+            | hasLib pkginfo                   = text "library"+            | hasExes                          = text "programs"+            | hasExe pkginfo                   = text "program"+            | otherwise                        = empty+++reflowParagraphs :: String -> Doc+reflowParagraphs =+    vcat+  . intersperse (text "")                    -- re-insert blank lines+  . map (fsep . map text . concatMap words)  -- reflow paragraphs+  . filter (/= [""])+  . groupBy (\x y -> "" `notElem` [x,y])     -- break on blank lines+  . lines++reflowLines :: String -> Doc+reflowLines = vcat . map text . lines++-- | We get the 'PackageDisplayInfo' by combining the info for the installed+-- and available versions of a package.+--+-- * We're building info about a various versions of a single named package so+-- the input package info records are all supposed to refer to the same+-- package name.+--+mergePackageInfo :: VersionRange+                 -> [InstalledPackage]+                 -> [SourcePackage]+                 -> Maybe SourcePackage+                 -> Bool+                 -> PackageDisplayInfo+mergePackageInfo versionPref installedPkgs sourcePkgs selectedPkg showVer =+  assert (length installedPkgs + length sourcePkgs > 0) $+  PackageDisplayInfo {+    pkgName           = combine packageName source+                                packageName installed,+    selectedVersion   = if showVer then fmap packageVersion selectedPkg+                                   else Nothing,+    selectedSourcePkg = sourceSelected,+    installedVersions = map packageVersion installedPkgs,+    sourceVersions    = map packageVersion sourcePkgs,+    preferredVersions = versionPref,++    license      = combine Source.license       source+                           Installed.license    installed,+    maintainer   = combine Source.maintainer    source+                           Installed.maintainer installed,+    author       = combine Source.author        source+                           Installed.author     installed,+    homepage     = combine Source.homepage      source+                           Installed.homepage   installed,+    bugReports   = maybe "" Source.bugReports source,+    sourceRepo   = fromMaybe "" . join+                 . fmap (uncons Nothing Source.repoLocation+                       . sortBy (comparing Source.repoKind)+                       . Source.sourceRepos)+                 $ source,+                    --TODO: installed package info is missing synopsis+    synopsis     = maybe "" Source.synopsis      source,+    description  = combine Source.description    source+                           Installed.description installed,+    category     = combine Source.category       source+                           Installed.category    installed,+    flags        = maybe [] Source.genPackageFlags sourceGeneric,+    hasLib       = isJust installed+                || fromMaybe False+                   (fmap (isJust . Source.condLibrary) sourceGeneric),+    hasExe       = fromMaybe False+                   (fmap (not . null . Source.condExecutables) sourceGeneric),+    executables  = map fst (maybe [] Source.condExecutables sourceGeneric),+    modules      = combine Installed.exposedModules installed+                           (maybe [] Source.exposedModules+                                   . Source.library) source,+    dependencies = map simplifyDependency+                 $ combine Source.buildDepends source+                           (map thisPackageVersion . depends) installed',+    haddockHtml  = fromMaybe "" . join+                 . fmap (listToMaybe . Installed.haddockHTMLs)+                 $ installed,+    haveTarball  = False+  }+  where+    combine f x g y  = fromJust (fmap f x `mplus` fmap g y)+    installed'       = latestWithPref versionPref installedPkgs+    installed        = fmap (\(InstalledPackage p _) -> p) installed'++    sourceSelected+      | isJust selectedPkg = selectedPkg+      | otherwise          = latestWithPref versionPref sourcePkgs+    sourceGeneric = fmap packageDescription sourceSelected+    source        = fmap flattenPackageDescription sourceGeneric++    uncons :: b -> (a -> b) -> [a] -> b+    uncons z _ []    = z+    uncons _ f (x:_) = f x+++-- | Not all the info is pure. We have to check if the docs really are+-- installed, because the registered package info lies. Similarly we have to+-- check if the tarball has indeed been fetched.+--+updateFileSystemPackageDetails :: PackageDisplayInfo -> IO PackageDisplayInfo+updateFileSystemPackageDetails pkginfo = do+  fetched   <- maybe (return False) (isFetched . packageSource)+                     (selectedSourcePkg pkginfo)+  docsExist <- doesDirectoryExist (haddockHtml pkginfo)+  return pkginfo {+    haveTarball = fetched,+    haddockHtml = if docsExist then haddockHtml pkginfo else ""+  }++latestWithPref :: Package pkg => VersionRange -> [pkg] -> Maybe pkg+latestWithPref _    []   = Nothing+latestWithPref pref pkgs = Just (maximumBy (comparing prefThenVersion) pkgs)+  where+    prefThenVersion pkg = let ver = packageVersion pkg+                           in (withinRange ver pref, ver)+++-- | Rearrange installed and source packages into groups referring to the+-- same package by name. In the result pairs, the lists are guaranteed to not+-- both be empty.+--+mergePackages :: [InstalledPackage]+              -> [SourcePackage]+              -> [( PackageName+                  , [InstalledPackage]+                  , [SourcePackage] )]+mergePackages installedPkgs sourcePkgs =+    map collect+  $ mergeBy (\i a -> fst i `compare` fst a)+            (groupOn packageName installedPkgs)+            (groupOn packageName sourcePkgs)+  where+    collect (OnlyInLeft  (name,is)         ) = (name, is, [])+    collect (    InBoth  (_,is)   (name,as)) = (name, is, as)+    collect (OnlyInRight          (name,as)) = (name, [], as)++groupOn :: Ord key => (a -> key) -> [a] -> [(key,[a])]+groupOn key = map (\xs -> (key (head xs), xs))+            . groupBy (equating key)+            . sortBy (comparing key)++dispTopVersions :: Int -> VersionRange -> [Version] -> Doc+dispTopVersions n pref vs =+         (Disp.fsep . Disp.punctuate (Disp.char ',')+        . map (\ver -> if ispref ver then disp ver else parens (disp ver))+        . sort . take n . interestingVersions ispref+        $ vs)+    <+> trailingMessage++  where+    ispref ver = withinRange ver pref+    extra = length vs - n+    trailingMessage+      | extra <= 0 = Disp.empty+      | otherwise  = Disp.parens $ Disp.text "and"+                               <+> Disp.int (length vs - n)+                               <+> if extra == 1 then Disp.text "other"+                                                 else Disp.text "others"++-- | Reorder a bunch of versions to put the most interesting / significant+-- versions first. A preferred version range is taken into account.+--+-- This may be used in a user interface to select a small number of versions+-- to present to the user, e.g.+--+-- > let selectVersions = sort . take 5 . interestingVersions pref+--+interestingVersions :: (Version -> Bool) -> [Version] -> [Version]+interestingVersions pref =+      map ((\ns -> Version ns []) . fst) . filter snd+    . concat  . Tree.levels+    . swizzleTree+    . reorderTree (\(Node (v,_) _) -> pref (Version v []))+    . reverseTree+    . mkTree+    . map versionBranch++  where+    swizzleTree = unfoldTree (spine [])+      where+        spine ts' (Node x [])     = (x, ts')+        spine ts' (Node x (t:ts)) = spine (Node x ts:ts') t++    reorderTree _ (Node x []) = Node x []+    reorderTree p (Node x ts) = Node x (ts' ++ ts'')+      where+        (ts',ts'') = partition p (map (reorderTree p) ts)++    reverseTree (Node x cs) = Node x (reverse (map reverseTree cs))++    mkTree xs = unfoldTree step (False, [], xs)+      where+        step (node,ns,vs) =+          ( (reverse ns, node)+          , [ (any null vs', n:ns, filter (not . null) vs')+            | (n, vs') <- groups vs ]+          )+        groups = map (\g -> (head (head g), map tail g))+               . groupBy (equating head)
+ cabal/cabal-install/Distribution/Client/PackageIndex.hs view
@@ -0,0 +1,487 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.PackageIndex+-- Copyright   :  (c) David Himmelstrup 2005,+--                    Bjorn Bringert 2007,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- An index of packages.+--+module Distribution.Client.PackageIndex (+  -- * Package index data type+  PackageIndex,++  -- * Creating an index+  fromList,++  -- * Updates+  merge,+  insert,+  deletePackageName,+  deletePackageId,+  deleteDependency,++  -- * Queries++  -- ** Precise lookups+  elemByPackageId,+  elemByPackageName,+  lookupPackageName,+  lookupPackageId,+  lookupDependency,++  -- ** Case-insensitive searches+  searchByName,+  SearchResult(..),+  searchByNameSubstring,++  -- ** Bulk queries+  allPackages,+  allPackagesByName,++  -- ** Special queries+  brokenPackages,+  dependencyClosure,+  reverseDependencyClosure,+  topologicalOrder,+  reverseTopologicalOrder,+  dependencyInconsistencies,+  dependencyCycles,+  dependencyGraph,+  ) where++import Prelude hiding (lookup)+import Control.Exception (assert)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Tree  as Tree+import qualified Data.Graph as Graph+import qualified Data.Array as Array+import Data.Array ((!))+import Data.List (groupBy, sortBy, nub, isInfixOf)+import Data.Monoid (Monoid(..))+import Data.Maybe (isJust, isNothing, fromMaybe)++import Distribution.Package+         ( PackageName(..), PackageIdentifier(..)+         , Package(..), packageName, packageVersion+         , Dependency(Dependency), PackageFixedDeps(..) )+import Distribution.Version+         ( Version, withinRange )+import Distribution.Simple.Utils (lowercase, equating, comparing)+++-- | The collection of information about packages from one or more 'PackageDB's.+--+-- It can be searched effeciently by package name and version.+--+newtype Package pkg => PackageIndex pkg = PackageIndex+  -- This index package names to all the package records matching that package+  -- name case-sensitively. It includes all versions.+  --+  -- This allows us to find all versions satisfying a dependency.+  -- Most queries are a map lookup followed by a linear scan of the bucket.+  --+  (Map PackageName [pkg])++  deriving (Show, Read)++instance Package pkg => Monoid (PackageIndex pkg) where+  mempty  = PackageIndex (Map.empty)+  mappend = merge+  --save one mappend with empty in the common case:+  mconcat [] = mempty+  mconcat xs = foldr1 mappend xs++invariant :: Package pkg => PackageIndex pkg -> Bool+invariant (PackageIndex m) = all (uncurry goodBucket) (Map.toList m)+  where+    goodBucket _    [] = False+    goodBucket name (pkg0:pkgs0) = check (packageId pkg0) pkgs0+      where+        check pkgid []          = packageName pkgid == name+        check pkgid (pkg':pkgs) = packageName pkgid == name+                               && pkgid < pkgid'+                               && check pkgid' pkgs+          where pkgid' = packageId pkg'++--+-- * Internal helpers+--++mkPackageIndex :: Package pkg => Map PackageName [pkg] -> PackageIndex pkg+mkPackageIndex index = assert (invariant (PackageIndex index))+                                         (PackageIndex index)++internalError :: String -> a+internalError name = error ("PackageIndex." ++ name ++ ": internal error")++-- | Lookup a name in the index to get all packages that match that name+-- case-sensitively.+--+lookup :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookup (PackageIndex m) name = fromMaybe [] $ Map.lookup name m++--+-- * Construction+--++-- | Build an index out of a bunch of packages.+--+-- If there are duplicates, later ones mask earlier ones.+--+fromList :: Package pkg => [pkg] -> PackageIndex pkg+fromList pkgs = mkPackageIndex+              . Map.map fixBucket+              . Map.fromListWith (++)+              $ [ (packageName pkg, [pkg])+                | pkg <- pkgs ]+  where+    fixBucket = -- out of groups of duplicates, later ones mask earlier ones+                -- but Map.fromListWith (++) constructs groups in reverse order+                map head+                -- Eq instance for PackageIdentifier is wrong, so use Ord:+              . groupBy (\a b -> EQ == comparing packageId a b)+                -- relies on sortBy being a stable sort so we+                -- can pick consistently among duplicates+              . sortBy (comparing packageId)++--+-- * Updates+--++-- | Merge two indexes.+--+-- Packages from the second mask packages of the same exact name+-- (case-sensitively) from the first.+--+merge :: Package pkg => PackageIndex pkg -> PackageIndex pkg -> PackageIndex pkg+merge i1@(PackageIndex m1) i2@(PackageIndex m2) =+  assert (invariant i1 && invariant i2) $+    mkPackageIndex (Map.unionWith mergeBuckets m1 m2)++-- | Elements in the second list mask those in the first.+mergeBuckets :: Package pkg => [pkg] -> [pkg] -> [pkg]+mergeBuckets []     ys     = ys+mergeBuckets xs     []     = xs+mergeBuckets xs@(x:xs') ys@(y:ys') =+      case packageId x `compare` packageId y of+        GT -> y : mergeBuckets xs  ys'+        EQ -> y : mergeBuckets xs' ys'+        LT -> x : mergeBuckets xs' ys++-- | Inserts a single package into the index.+--+-- This is equivalent to (but slightly quicker than) using 'mappend' or+-- 'merge' with a singleton index.+--+insert :: Package pkg => pkg -> PackageIndex pkg -> PackageIndex pkg+insert pkg (PackageIndex index) = mkPackageIndex $+  Map.insertWith (\_ -> insertNoDup) (packageName pkg) [pkg] index+  where+    pkgid = packageId pkg+    insertNoDup []                = [pkg]+    insertNoDup pkgs@(pkg':pkgs') = case compare pkgid (packageId pkg') of+      LT -> pkg  : pkgs+      EQ -> pkg  : pkgs'+      GT -> pkg' : insertNoDup pkgs'++-- | Internal delete helper.+--+delete :: Package pkg => PackageName -> (pkg -> Bool) -> PackageIndex pkg -> PackageIndex pkg+delete name p (PackageIndex index) = mkPackageIndex $+  Map.update filterBucket name index+  where+    filterBucket = deleteEmptyBucket+                 . filter (not . p)+    deleteEmptyBucket []        = Nothing+    deleteEmptyBucket remaining = Just remaining++-- | Removes a single package from the index.+--+deletePackageId :: Package pkg => PackageIdentifier -> PackageIndex pkg -> PackageIndex pkg+deletePackageId pkgid =+  delete (packageName pkgid) (\pkg -> packageId pkg == pkgid)++-- | Removes all packages with this (case-sensitive) name from the index.+--+deletePackageName :: Package pkg => PackageName -> PackageIndex pkg -> PackageIndex pkg+deletePackageName name =+  delete name (\pkg -> packageName pkg == name)++-- | Removes all packages satisfying this dependency from the index.+--+deleteDependency :: Package pkg => Dependency -> PackageIndex pkg -> PackageIndex pkg+deleteDependency (Dependency name verstionRange) =+  delete name (\pkg -> packageVersion pkg `withinRange` verstionRange)++--+-- * Bulk queries+--++-- | Get all the packages from the index.+--+allPackages :: Package pkg => PackageIndex pkg -> [pkg]+allPackages (PackageIndex m) = concat (Map.elems m)++-- | Get all the packages from the index.+--+-- They are grouped by package name, case-sensitively.+--+allPackagesByName :: Package pkg => PackageIndex pkg -> [[pkg]]+allPackagesByName (PackageIndex m) = Map.elems m++--+-- * Lookups+--++elemByPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Bool+elemByPackageId index = isJust . lookupPackageId index++elemByPackageName :: Package pkg => PackageIndex pkg -> PackageName -> Bool+elemByPackageName index = not . null . lookupPackageName index+++-- | Does a lookup by package id (name & version).+--+-- Since multiple package DBs mask each other case-sensitively by package name,+-- then we get back at most one package.+--+lookupPackageId :: Package pkg => PackageIndex pkg -> PackageIdentifier -> Maybe pkg+lookupPackageId index pkgid =+  case [ pkg | pkg <- lookup index (packageName pkgid)+             , packageId pkg == pkgid ] of+    []    -> Nothing+    [pkg] -> Just pkg+    _     -> internalError "lookupPackageIdentifier"++-- | Does a case-sensitive search by package name.+--+lookupPackageName :: Package pkg => PackageIndex pkg -> PackageName -> [pkg]+lookupPackageName index name =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name ]++-- | Does a case-sensitive search by 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 :: Package pkg => PackageIndex pkg -> Dependency -> [pkg]+lookupDependency index (Dependency name versionRange) =+  [ pkg | pkg <- lookup index name+        , packageName pkg == name+        , packageVersion pkg `withinRange` versionRange ]++--+-- * Case insensitive name lookups+--++-- | Does a case-insensitive search by package name.+--+-- If there is only one package that compares case-insentiviely to this name+-- then the search is unambiguous and we get back all versions of that package.+-- If several match case-insentiviely but one matches exactly then it is also+-- unambiguous.+--+-- If however several match case-insentiviely 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 :: Package pkg => PackageIndex pkg+             -> String -> [(PackageName, [pkg])]+searchByName (PackageIndex m) name =+    [ pkgs+    | pkgs@(PackageName name',_) <- Map.toList m+    , lowercase name' == lname ]+  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 :: Package pkg => PackageIndex pkg+                      -> String -> [(PackageName, [pkg])]+searchByNameSubstring (PackageIndex m) searchterm =+    [ pkgs+    | pkgs@(PackageName name, _) <- Map.toList m+    , lsearchterm `isInfixOf` lowercase name ]+  where+    lsearchterm = lowercase searchterm++--+-- * Special queries+--++-- | All packages that have dependencies that are not in the index.+--+-- Returns such packages along with the dependencies that they're missing.+--+brokenPackages :: PackageFixedDeps pkg+               => PackageIndex pkg+               -> [(pkg, [PackageIdentifier])]+brokenPackages index =+  [ (pkg, missing)+  | pkg  <- allPackages index+  , let missing = [ pkg' | pkg' <- depends pkg+                         , isNothing (lookupPackageId index pkg') ]+  , not (null missing) ]++-- | Tries to take the transative closure of the package dependencies.+--+-- If the transative 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 'PackageIdentifier's do not occur in the index.+--+dependencyClosure :: PackageFixedDeps pkg+                  => PackageIndex pkg+                  -> [PackageIdentifier]+                  -> Either (PackageIndex pkg)+                            [(pkg, [PackageIdentifier])]+dependencyClosure 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 lookupPackageId index pkgid of+      Nothing   -> closure completed (pkgid:failed) pkgids+      Just pkg  -> case lookupPackageId completed (packageId pkg) of+        Just _  -> closure completed  failed pkgids+        Nothing -> closure completed' failed pkgids'+          where completed' = insert pkg completed+                pkgids'    = depends pkg ++ pkgids++-- | Takes the transative closure of the packages reverse dependencies.+--+-- * The given 'PackageIdentifier's must be in the index.+--+reverseDependencyClosure :: PackageFixedDeps pkg+                         => PackageIndex pkg+                         -> [PackageIdentifier]+                         -> [pkg]+reverseDependencyClosure index =+    map vertexToPkg+  . concatMap Tree.flatten+  . Graph.dfs reverseDepGraph+  . map (fromMaybe noSuchPkgId . pkgIdToVertex)++  where+    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index+    reverseDepGraph = Graph.transposeG depGraph+    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"++topologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]+topologicalOrder index = map toPkgId+                       . Graph.topSort+                       $ graph+  where (graph, toPkgId, _) = dependencyGraph index++reverseTopologicalOrder :: PackageFixedDeps pkg => PackageIndex pkg -> [pkg]+reverseTopologicalOrder index = map toPkgId+                              . Graph.topSort+                              . Graph.transposeG+                              $ graph+  where (graph, toPkgId, _) = dependencyGraph index++-- | 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 :: PackageFixedDeps pkg+                          => PackageIndex pkg+                          -> [(PackageName, [(PackageIdentifier, Version)])]+dependencyInconsistencies index =+  [ (name, inconsistencies)+  | (name, uses) <- Map.toList inverseIndex+  , let inconsistencies = duplicatesBy uses+        versions = map snd inconsistencies+  , reallyIsInconsistent name (nub versions) ]++  where inverseIndex = Map.fromListWith (++)+          [ (packageName dep, [(packageId pkg, packageVersion dep)])+          | pkg <- allPackages index+          , dep <- depends pkg ]++        duplicatesBy = (\groups -> if length groups == 1+                                     then []+                                     else concat groups)+                     . groupBy (equating snd)+                     . sortBy (comparing snd)++        reallyIsInconsistent :: PackageName -> [Version] -> Bool+        reallyIsInconsistent _    []       = False+        reallyIsInconsistent name [v1, v2] =+          case (mpkg1, mpkg2) of+            (Just pkg1, Just pkg2) -> pkgid1 `notElem` depends pkg2+                                   && pkgid2 `notElem` depends pkg1+            _ -> True+          where+            pkgid1 = PackageIdentifier name v1+            pkgid2 = PackageIdentifier name v2+            mpkg1 = lookupPackageId index pkgid1+            mpkg2 = lookupPackageId index pkgid2++        reallyIsInconsistent _ _ = True++-- | 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 :: PackageFixedDeps pkg+                 => PackageIndex pkg+                 -> [[pkg]]+dependencyCycles index =+  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]+  where+    adjacencyList = [ (pkg, packageId pkg, depends pkg)+                    | pkg <- allPackages 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 :: PackageFixedDeps pkg+                => PackageIndex pkg+                -> (Graph.Graph,+                    Graph.Vertex -> pkg,+                    PackageIdentifier -> Maybe Graph.Vertex)+dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)+  where+    graph = Array.listArray bounds+              [ [ v | Just v <- map pkgIdToVertex (depends pkg) ]+              | pkg <- pkgs ]+    vertexToPkg vertex = pkgTable ! vertex+    pkgIdToVertex = binarySearch 0 topBound++    pkgTable   = Array.listArray bounds pkgs+    pkgIdTable = Array.listArray bounds (map packageId pkgs)+    pkgs = sortBy (comparing packageId) (allPackages index)+    topBound = length pkgs - 1+    bounds = (0, topBound)++    binarySearch a b key+      | a > b     = Nothing+      | otherwise = case compare key (pkgIdTable ! mid) of+          LT -> binarySearch a (mid-1) key+          EQ -> Just mid+          GT -> binarySearch (mid+1) b key+      where mid = (a + b) `div` 2
+ cabal/cabal-install/Distribution/Client/PackageUtils.hs view
@@ -0,0 +1,34 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.PackageUtils+-- Copyright   :  (c) Duncan Coutts 2010+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Various package description utils that should be in the Cabal lib+-----------------------------------------------------------------------------+module Distribution.Client.PackageUtils (+    externalBuildDepends,+  ) where++import Distribution.Package+         ( packageVersion, packageName, Dependency(..) )+import Distribution.PackageDescription+         ( PackageDescription(..) )+import Distribution.Version+         ( withinRange )++-- | The list of dependencies that refer to external packages+-- rather than internal package components.+--+externalBuildDepends :: PackageDescription -> [Dependency]+externalBuildDepends pkg = filter (not . internal) (buildDepends pkg)+  where+    -- True if this dependency is an internal one (depends on a library+    -- defined in the same package).+    internal (Dependency depName versionRange) =+            depName == packageName pkg &&+            packageVersion pkg `withinRange` versionRange
+ cabal/cabal-install/Distribution/Client/Setup.hs view
@@ -0,0 +1,1023 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Setup+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Setup+    ( globalCommand, GlobalFlags(..), globalRepos+    , configureCommand, ConfigFlags(..), filterConfigureFlags+    , configureExCommand, ConfigExFlags(..), defaultConfigExFlags+                        , configureExOptions+    , installCommand, InstallFlags(..), installOptions, defaultInstallFlags+    , listCommand, ListFlags(..)+    , updateCommand+    , upgradeCommand+    , infoCommand, InfoFlags(..)+    , fetchCommand, FetchFlags(..)+    , checkCommand+    , uploadCommand, UploadFlags(..)+    , reportCommand, ReportFlags(..)+    , unpackCommand, UnpackFlags(..)+    , initCommand, IT.InitFlags(..)++    , parsePackageArgs+    --TODO: stop exporting these:+    , showRepo+    , parseRepo+    ) where++import Distribution.Client.Types+         ( Username(..), Password(..), Repo(..), RemoteRepo(..), LocalRepo(..) )+import Distribution.Client.BuildReports.Types+         ( ReportLevel(..) )+import qualified Distribution.Client.Init.Types as IT+         ( InitFlags(..), PackageType(..) )+import Distribution.Client.Targets+         ( UserConstraint, readUserConstraint )++import Distribution.Simple.Program+         ( defaultProgramConfiguration )+import Distribution.Simple.Command hiding (boolOpt)+import qualified Distribution.Simple.Command as Command+import qualified Distribution.Simple.Setup as Cabal+         ( configureCommand )+import Distribution.Simple.Setup+         ( ConfigFlags(..) )+import Distribution.Simple.Setup+         ( Flag(..), toFlag, fromFlag, flagToList, flagToMaybe+         , optionVerbosity, trueArg, falseArg )+import Distribution.Simple.InstallDirs+         ( PathTemplate, toPathTemplate, fromPathTemplate )+import Distribution.Version+         ( Version(Version), anyVersion, thisVersion )+import Distribution.Package+         ( PackageIdentifier, packageName, packageVersion, Dependency(..) )+import Distribution.Text+         ( Text(parse), display )+import Distribution.ReadE+         ( ReadE(..), readP_to_E, succeedReadE )+import qualified Distribution.Compat.ReadP as Parse+         ( ReadP, readP_to_S, char, munch1, pfail, (+++) )+import Distribution.Verbosity+         ( Verbosity, normal )+import Distribution.Simple.Utils+         ( wrapText )++import Data.Char+         ( isSpace, isAlphaNum )+import Data.Maybe+         ( listToMaybe, maybeToList, fromMaybe )+import Data.Monoid+         ( Monoid(..) )+import Control.Monad+         ( liftM )+import System.FilePath+         ( (</>) )+import Network.URI+         ( parseAbsoluteURI, uriToString )++-- ------------------------------------------------------------+-- * Global flags+-- ------------------------------------------------------------++-- | Flags that apply at the top level, not to any sub-command.+data GlobalFlags = GlobalFlags {+    globalVersion        :: Flag Bool,+    globalNumericVersion :: Flag Bool,+    globalConfigFile     :: Flag FilePath,+    globalRemoteRepos    :: [RemoteRepo],     -- ^ Available Hackage servers.+    globalCacheDir       :: Flag FilePath,+    globalLocalRepos     :: [FilePath],+    globalLogsDir        :: Flag FilePath,+    globalWorldFile      :: Flag FilePath+  }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags  = GlobalFlags {+    globalVersion        = Flag False,+    globalNumericVersion = Flag False,+    globalConfigFile     = mempty,+    globalRemoteRepos    = [],+    globalCacheDir       = mempty,+    globalLocalRepos     = mempty,+    globalLogsDir        = mempty,+    globalWorldFile      = mempty+  }++globalCommand :: CommandUI GlobalFlags+globalCommand = CommandUI {+    commandName         = "",+    commandSynopsis     = "",+    commandUsage        = \_ ->+         "This program is the command line interface "+           ++ "to the Haskell Cabal infrastructure.\n"+      ++ "See http://www.haskell.org/cabal/ for more information.\n",+    commandDescription  = Just $ \pname ->+         "For more information about a command use:\n"+      ++ "  " ++ pname ++ " COMMAND --help\n\n"+      ++ "To install Cabal packages from hackage use:\n"+      ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"+      ++ "Occasionally you need to update the list of available packages:\n"+      ++ "  " ++ pname ++ " update\n",+    commandDefaultFlags = defaultGlobalFlags,+    commandOptions      = \showOrParseArgs ->+      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)+      [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++      ,option [] ["config-file"]+         "Set an alternate location for the config file"+         globalConfigFile (\v flags -> flags { globalConfigFile = v })+         (reqArgFlag "FILE")++      ,option [] ["remote-repo"]+         "The name and url for a remote repository"+         globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })+         (reqArg' "NAME:URL" (maybeToList . readRepo) (map showRepo))++      ,option [] ["remote-repo-cache"]+         "The location where downloads from all remote repos are cached"+         globalCacheDir (\v flags -> flags { globalCacheDir = v })+         (reqArgFlag "DIR")++      ,option [] ["local-repo"]+         "The location of a local repository"+         globalLocalRepos (\v flags -> flags { globalLocalRepos = v })+         (reqArg' "DIR" (\x -> [x]) id)++      ,option [] ["logs-dir"]+         "The location to put log files"+         globalLogsDir (\v flags -> flags { globalLogsDir = v })+         (reqArgFlag "DIR")++      ,option [] ["world-file"]+         "The location of the world file"+         globalWorldFile (\v flags -> flags { globalWorldFile = v })+         (reqArgFlag "FILE")+      ]+  }++instance Monoid GlobalFlags where+  mempty = GlobalFlags {+    globalVersion        = mempty,+    globalNumericVersion = mempty,+    globalConfigFile     = mempty,+    globalRemoteRepos    = mempty,+    globalCacheDir       = mempty,+    globalLocalRepos     = mempty,+    globalLogsDir        = mempty,+    globalWorldFile      = mempty+  }+  mappend a b = GlobalFlags {+    globalVersion        = combine globalVersion,+    globalNumericVersion = combine globalNumericVersion,+    globalConfigFile     = combine globalConfigFile,+    globalRemoteRepos    = combine globalRemoteRepos,+    globalCacheDir       = combine globalCacheDir,+    globalLocalRepos     = combine globalLocalRepos,+    globalLogsDir        = combine globalLogsDir,+    globalWorldFile      = combine globalWorldFile+  }+    where combine field = field a `mappend` field b++globalRepos :: GlobalFlags -> [Repo]+globalRepos globalFlags = remoteRepos ++ localRepos+  where+    remoteRepos =+      [ Repo (Left remote) cacheDir+      | remote <- globalRemoteRepos globalFlags+      , let cacheDir = fromFlag (globalCacheDir globalFlags)+                   </> remoteRepoName remote ]+    localRepos =+      [ Repo (Right LocalRepo) local+      | local <- globalLocalRepos globalFlags ]++-- ------------------------------------------------------------+-- * Config flags+-- ------------------------------------------------------------++configureCommand :: CommandUI ConfigFlags+configureCommand = (Cabal.configureCommand defaultProgramConfiguration) {+    commandDefaultFlags = mempty+  }++configureOptions ::  ShowOrParseArgs -> [OptionField ConfigFlags]+configureOptions = commandOptions configureCommand++filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags+filterConfigureFlags flags cabalLibVersion+  | cabalLibVersion >= Version [1,3,10] [] = flags+    -- older Cabal does not grok the constraints flag:+  | otherwise = flags { configConstraints = [] }+++-- ------------------------------------------------------------+-- * Config extra flags+-- ------------------------------------------------------------++-- | cabal configure takes some extra flags beyond runghc Setup configure+--+data ConfigExFlags = ConfigExFlags {+    configCabalVersion :: Flag Version,+    configExConstraints:: [UserConstraint],+    configPreferences  :: [Dependency]+  }++defaultConfigExFlags :: ConfigExFlags+defaultConfigExFlags = mempty++configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags)+configureExCommand = configureCommand {+    commandDefaultFlags = (mempty, defaultConfigExFlags),+    commandOptions      = \showOrParseArgs ->+         liftOptions fst setFst (filter ((/="constraint") . optionName) $+                                 configureOptions   showOrParseArgs)+      ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++configureExOptions ::  ShowOrParseArgs -> [OptionField ConfigExFlags]+configureExOptions _showOrParseArgs =+  [ option [] ["cabal-lib-version"]+      ("Select which version of the Cabal lib to use to build packages "+      ++ "(useful for testing).")+      configCabalVersion (\v flags -> flags { configCabalVersion = v })+      (reqArg "VERSION" (readP_to_E ("Cannot parse cabal lib version: "++)+                                    (fmap toFlag parse))+                        (map display . flagToList))+  , option [] ["constraint"]+      "Specify constraints on a package (version, installed/source, flags)"+      configExConstraints (\v flags -> flags { configExConstraints = v })+      (reqArg "CONSTRAINT"+              (fmap (\x -> [x]) (ReadE readUserConstraint))+              (map display))++  , option [] ["preference"]+      "Specify preferences (soft constraints) on the version of a package"+      configPreferences (\v flags -> flags { configPreferences = v })+      (reqArg "CONSTRAINT"+              (readP_to_E (const "dependency expected")+                          (fmap (\x -> [x]) parse))+              (map display))+  ]++instance Monoid ConfigExFlags where+  mempty = ConfigExFlags {+    configCabalVersion = mempty,+    configExConstraints= mempty,+    configPreferences  = mempty+  }+  mappend a b = ConfigExFlags {+    configCabalVersion = combine configCabalVersion,+    configExConstraints= combine configExConstraints,+    configPreferences  = combine configPreferences+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Fetch command+-- ------------------------------------------------------------++data FetchFlags = FetchFlags {+--    fetchOutput    :: Flag FilePath,+      fetchDeps      :: Flag Bool,+      fetchDryRun    :: Flag Bool,+      fetchVerbosity :: Flag Verbosity+    }++defaultFetchFlags :: FetchFlags+defaultFetchFlags = FetchFlags {+--  fetchOutput    = mempty,+    fetchDeps      = toFlag True,+    fetchDryRun    = toFlag False,+    fetchVerbosity = toFlag normal+   }++fetchCommand :: CommandUI FetchFlags+fetchCommand = CommandUI {+    commandName         = "fetch",+    commandSynopsis     = "Downloads packages for later installation.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "fetch",+    commandDefaultFlags = defaultFetchFlags,+    commandOptions      = \_ -> [+         optionVerbosity fetchVerbosity (\v flags -> flags { fetchVerbosity = v })++--     , option "o" ["output"]+--         "Put the package(s) somewhere specific rather than the usual cache."+--         fetchOutput (\v flags -> flags { fetchOutput = v })+--         (reqArgFlag "PATH")++       , option [] ["dependencies", "deps"]+           "Resolve and fetch dependencies (default)"+           fetchDeps (\v flags -> flags { fetchDeps = v })+           trueArg++       , option [] ["no-dependencies", "no-deps"]+           "Ignore dependencies"+           fetchDeps (\v flags -> flags { fetchDeps = v })+           falseArg++       , option [] ["dry-run"]+           "Do not install anything, only print what would be installed."+           fetchDryRun (\v flags -> flags { fetchDryRun = v })+           trueArg+       ]+  }++-- ------------------------------------------------------------+-- * Other commands+-- ------------------------------------------------------------++updateCommand  :: CommandUI (Flag Verbosity)+updateCommand = CommandUI {+    commandName         = "update",+    commandSynopsis     = "Updates list of known packages",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "update",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }++upgradeCommand  :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+upgradeCommand = configureCommand {+    commandName         = "upgrade",+    commandSynopsis     = "(command disabled, use install instead)",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "upgrade",+    commandDefaultFlags = (mempty, mempty, mempty),+    commandOptions      = commandOptions installCommand+  }++{-+cleanCommand  :: CommandUI ()+cleanCommand = makeCommand name shortDesc longDesc emptyFlags options+  where+    name       = "clean"+    shortDesc  = "Removes downloaded files"+    longDesc   = Nothing+    emptyFlags = ()+    options _  = []+-}++checkCommand  :: CommandUI (Flag Verbosity)+checkCommand = CommandUI {+    commandName         = "check",+    commandSynopsis     = "Check the package for common mistakes",+    commandDescription  = Nothing,+    commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> []+  }++-- ------------------------------------------------------------+-- * Report flags+-- ------------------------------------------------------------++data ReportFlags = ReportFlags {+    reportUsername  :: Flag Username,+    reportPassword  :: Flag Password,+    reportVerbosity :: Flag Verbosity+  }++defaultReportFlags :: ReportFlags+defaultReportFlags = ReportFlags {+    reportUsername  = mempty,+    reportPassword  = mempty,+    reportVerbosity = toFlag normal+  }++reportCommand :: CommandUI ReportFlags+reportCommand = CommandUI {+    commandName         = "report",+    commandSynopsis     = "Upload build reports to a remote server.",+    commandDescription  = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n",+    commandUsage        = \pname -> "Usage: " ++ pname ++ " report [FLAGS]\n\n"+      ++ "Flags for upload:",+    commandDefaultFlags = defaultReportFlags,+    commandOptions      = \_ ->+      [optionVerbosity reportVerbosity (\v flags -> flags { reportVerbosity = v })++      ,option ['u'] ["username"]+        "Hackage username."+        reportUsername (\v flags -> flags { reportUsername = v })+        (reqArg' "USERNAME" (toFlag . Username)+                            (flagToList . fmap unUsername))++      ,option ['p'] ["password"]+        "Hackage password."+        reportPassword (\v flags -> flags { reportPassword = v })+        (reqArg' "PASSWORD" (toFlag . Password)+                            (flagToList . fmap unPassword))+      ]+  }++instance Monoid ReportFlags where+  mempty = ReportFlags {+    reportUsername  = mempty,+    reportPassword  = mempty,+    reportVerbosity = mempty+  }+  mappend a b = ReportFlags {+    reportUsername  = combine reportUsername,+    reportPassword  = combine reportPassword,+    reportVerbosity = combine reportVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Unpack flags+-- ------------------------------------------------------------++data UnpackFlags = UnpackFlags {+      unpackDestDir :: Flag FilePath,+      unpackVerbosity :: Flag Verbosity+    }++defaultUnpackFlags :: UnpackFlags+defaultUnpackFlags = UnpackFlags {+    unpackDestDir = mempty,+    unpackVerbosity = toFlag normal+   }++unpackCommand :: CommandUI UnpackFlags+unpackCommand = CommandUI {+    commandName         = "unpack",+    commandSynopsis     = "Unpacks packages for user inspection.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "unpack",+    commandDefaultFlags = mempty,+    commandOptions      = \_ -> [+        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })++       ,option "d" ["destdir"]+         "where to unpack the packages, defaults to the current directory."+         unpackDestDir (\v flags -> flags { unpackDestDir = v })+         (reqArgFlag "PATH")+       ]+  }++instance Monoid UnpackFlags where+  mempty = defaultUnpackFlags+  mappend a b = UnpackFlags {+     unpackDestDir = combine unpackDestDir+    ,unpackVerbosity = combine unpackVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * List flags+-- ------------------------------------------------------------++data ListFlags = ListFlags {+    listInstalled :: Flag Bool,+    listSimpleOutput :: Flag Bool,+    listVerbosity :: Flag Verbosity+  }++defaultListFlags :: ListFlags+defaultListFlags = ListFlags {+    listInstalled = Flag False,+    listSimpleOutput = Flag False,+    listVerbosity = toFlag normal+  }++listCommand  :: CommandUI ListFlags+listCommand = CommandUI {+    commandName         = "list",+    commandSynopsis     = "List packages matching a search string.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "list",+    commandDefaultFlags = defaultListFlags,+    commandOptions      = \_ -> [+        optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })++        , option [] ["installed"]+            "Only print installed packages"+            listInstalled (\v flags -> flags { listInstalled = v })+            trueArg++        , option [] ["simple-output"]+            "Print in a easy-to-parse format"+            listSimpleOutput (\v flags -> flags { listSimpleOutput = v })+            trueArg++        ]+  }++instance Monoid ListFlags where+  mempty = defaultListFlags+  mappend a b = ListFlags {+    listInstalled = combine listInstalled,+    listSimpleOutput = combine listSimpleOutput,+    listVerbosity = combine listVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Info flags+-- ------------------------------------------------------------++data InfoFlags = InfoFlags {+    infoVerbosity :: Flag Verbosity+  }++defaultInfoFlags :: InfoFlags+defaultInfoFlags = InfoFlags {+    infoVerbosity = toFlag normal+  }++infoCommand  :: CommandUI InfoFlags+infoCommand = CommandUI {+    commandName         = "info",+    commandSynopsis     = "Display detailed information about a particular package.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "info",+    commandDefaultFlags = defaultInfoFlags,+    commandOptions      = \_ -> [+        optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })+        ]+  }++instance Monoid InfoFlags where+  mempty = defaultInfoFlags+  mappend a b = InfoFlags {+    infoVerbosity = combine infoVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Install flags+-- ------------------------------------------------------------++-- | Install takes the same flags as configure along with a few extras.+--+data InstallFlags = InstallFlags {+    installDocumentation:: Flag Bool,+    installHaddockIndex :: Flag PathTemplate,+    installDryRun       :: Flag Bool,+    installReinstall    :: Flag Bool,+    installUpgradeDeps  :: Flag Bool,+    installOnly         :: Flag Bool,+    installOnlyDeps     :: Flag Bool,+    installRootCmd      :: Flag String,+    installSummaryFile  :: [PathTemplate],+    installLogFile      :: Flag PathTemplate,+    installBuildReports :: Flag ReportLevel,+    installSymlinkBinDir:: Flag FilePath,+    installOneShot      :: Flag Bool+  }++defaultInstallFlags :: InstallFlags+defaultInstallFlags = InstallFlags {+    installDocumentation= Flag False,+    installHaddockIndex = Flag docIndexFile,+    installDryRun       = Flag False,+    installReinstall    = Flag False,+    installUpgradeDeps  = Flag False,+    installOnly         = Flag False,+    installOnlyDeps     = Flag False,+    installRootCmd      = mempty,+    installSummaryFile  = mempty,+    installLogFile      = mempty,+    installBuildReports = Flag NoReports,+    installSymlinkBinDir= mempty,+    installOneShot      = Flag False+  }+  where+    docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html")++installCommand :: CommandUI (ConfigFlags, ConfigExFlags, InstallFlags)+installCommand = CommandUI {+  commandName         = "install",+  commandSynopsis     = "Installs a list of packages.",+  commandUsage        = usagePackages "install",+  commandDescription  = Just $ \pname ->+    let original = case commandDescription configureCommand of+          Just desc -> desc pname ++ "\n"+          Nothing   -> ""+     in original+     ++ "Examples:\n"+     ++ "  " ++ pname ++ " install                 "+     ++ "    Package in the current directory\n"+     ++ "  " ++ pname ++ " install foo             "+     ++ "    Package from the hackage server\n"+     ++ "  " ++ pname ++ " install foo-1.0         "+     ++ "    Specific version of a package\n"+     ++ "  " ++ pname ++ " install 'foo < 2'       "+     ++ "    Constrained package version\n",+  commandDefaultFlags = (mempty, mempty, mempty),+  commandOptions      = \showOrParseArgs ->+       liftOptions get1 set1 (filter ((/="constraint") . optionName) $+                              configureOptions   showOrParseArgs)+    ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)+    ++ liftOptions get3 set3 (installOptions     showOrParseArgs)+  }+  where+    get1 (a,_,_) = a; set1 a (_,b,c) = (a,b,c)+    get2 (_,b,_) = b; set2 b (a,_,c) = (a,b,c)+    get3 (_,_,c) = c; set3 c (a,b,_) = (a,b,c)++installOptions ::  ShowOrParseArgs -> [OptionField InstallFlags]+installOptions showOrParseArgs =+      [ option "" ["documentation"]+          "building of documentation"+          installDocumentation (\v flags -> flags { installDocumentation = v })+          (boolOpt [] [])++      , option [] ["doc-index-file"]+          "A central index of haddock API documentation (template cannot use $pkgid)"+          installHaddockIndex (\v flags -> flags { installHaddockIndex = v })+          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)+                              (flagToList . fmap fromPathTemplate))++      , option [] ["dry-run"]+          "Do not install anything, only print what would be installed."+          installDryRun (\v flags -> flags { installDryRun = v })+          trueArg++      , option [] ["reinstall"]+          "Install even if it means installing the same version again."+          installReinstall (\v flags -> flags { installReinstall = v })+          trueArg++      , option [] ["upgrade-dependencies"]+          "Pick the latest version for all dependencies, rather than trying to pick an installed version."+          installUpgradeDeps (\v flags -> flags { installUpgradeDeps = v })+          trueArg+++      , option [] ["only-dependencies"]+          "Install only the dependencies necessary to build the given packages"+          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })+          trueArg+++      , option [] ["root-cmd"]+          "Command used to gain root privileges, when installing with --global."+          installRootCmd (\v flags -> flags { installRootCmd = v })+          (reqArg' "COMMAND" toFlag flagToList)++      , option [] ["symlink-bindir"]+          "Add symlinks to installed executables into this directory."+           installSymlinkBinDir (\v flags -> flags { installSymlinkBinDir = v })+           (reqArgFlag "DIR")++      , option [] ["build-summary"]+          "Save build summaries to file (name template can use $pkgid, $compiler, $os, $arch)"+          installSummaryFile (\v flags -> flags { installSummaryFile = v })+          (reqArg' "TEMPLATE" (\x -> [toPathTemplate x]) (map fromPathTemplate))++      , option [] ["build-log"]+          "Log all builds to file (name template can use $pkgid, $compiler, $os, $arch)"+          installLogFile (\v flags -> flags { installLogFile = v })+          (reqArg' "TEMPLATE" (toFlag.toPathTemplate)+                              (flagToList . fmap fromPathTemplate))++      , option [] ["remote-build-reporting"]+          "Generate build reports to send to a remote server (none, anonymous or detailed)."+          installBuildReports (\v flags -> flags { installBuildReports = v })+          (reqArg "LEVEL" (readP_to_E (const $ "report level must be 'none', "+                                            ++ "'anonymous' or 'detailed'")+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))++      , option [] ["one-shot"]+          "Do not record the packages in the world file."+          installOneShot (\v flags -> flags { installOneShot = v })+          trueArg+      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids+          ParseArgs ->+            option [] ["only"]+              "Only installs the package in the current directory."+              installOnly (\v flags -> flags { installOnly = v })+              trueArg+             : []+          _ -> []++instance Monoid InstallFlags where+  mempty = InstallFlags {+    installDocumentation= mempty,+    installHaddockIndex = mempty,+    installDryRun       = mempty,+    installReinstall    = mempty,+    installUpgradeDeps  = mempty,+    installOnly         = mempty,+    installOnlyDeps     = mempty,+    installRootCmd      = mempty,+    installSummaryFile  = mempty,+    installLogFile      = mempty,+    installBuildReports = mempty,+    installSymlinkBinDir= mempty,+    installOneShot      = mempty+  }+  mappend a b = InstallFlags {+    installDocumentation= combine installDocumentation,+    installHaddockIndex = combine installHaddockIndex,+    installDryRun       = combine installDryRun,+    installReinstall    = combine installReinstall,+    installUpgradeDeps  = combine installUpgradeDeps,+    installOnly         = combine installOnly,+    installOnlyDeps     = combine installOnlyDeps,+    installRootCmd      = combine installRootCmd,+    installSummaryFile  = combine installSummaryFile,+    installLogFile      = combine installLogFile,+    installBuildReports = combine installBuildReports,+    installSymlinkBinDir= combine installSymlinkBinDir,+    installOneShot      = combine installOneShot+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Upload flags+-- ------------------------------------------------------------++data UploadFlags = UploadFlags {+    uploadCheck     :: Flag Bool,+    uploadUsername  :: Flag Username,+    uploadPassword  :: Flag Password,+    uploadVerbosity :: Flag Verbosity+  }++defaultUploadFlags :: UploadFlags+defaultUploadFlags = UploadFlags {+    uploadCheck     = toFlag False,+    uploadUsername  = mempty,+    uploadPassword  = mempty,+    uploadVerbosity = toFlag normal+  }++uploadCommand :: CommandUI UploadFlags+uploadCommand = CommandUI {+    commandName         = "upload",+    commandSynopsis     = "Uploads source packages to Hackage",+    commandDescription  = Just $ \_ ->+         "You can store your Hackage login in the ~/.cabal/config file\n",+    commandUsage        = \pname ->+         "Usage: " ++ pname ++ " upload [FLAGS] [TARFILES]\n\n"+      ++ "Flags for upload:",+    commandDefaultFlags = defaultUploadFlags,+    commandOptions      = \_ ->+      [optionVerbosity uploadVerbosity (\v flags -> flags { uploadVerbosity = v })++      ,option ['c'] ["check"]+         "Do not upload, just do QA checks."+        uploadCheck (\v flags -> flags { uploadCheck = v })+        trueArg++      ,option ['u'] ["username"]+        "Hackage username."+        uploadUsername (\v flags -> flags { uploadUsername = v })+        (reqArg' "USERNAME" (toFlag . Username)+                            (flagToList . fmap unUsername))++      ,option ['p'] ["password"]+        "Hackage password."+        uploadPassword (\v flags -> flags { uploadPassword = v })+        (reqArg' "PASSWORD" (toFlag . Password)+                            (flagToList . fmap unPassword))+      ]+  }++instance Monoid UploadFlags where+  mempty = UploadFlags {+    uploadCheck     = mempty,+    uploadUsername  = mempty,+    uploadPassword  = mempty,+    uploadVerbosity = mempty+  }+  mappend a b = UploadFlags {+    uploadCheck     = combine uploadCheck,+    uploadUsername  = combine uploadUsername,+    uploadPassword  = combine uploadPassword,+    uploadVerbosity = combine uploadVerbosity+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Init flags+-- ------------------------------------------------------------++emptyInitFlags :: IT.InitFlags+emptyInitFlags  = mempty++defaultInitFlags :: IT.InitFlags+defaultInitFlags  = emptyInitFlags++initCommand :: CommandUI IT.InitFlags+initCommand = CommandUI {+    commandName = "init",+    commandSynopsis = "Interactively create a .cabal file.",+    commandDescription = Just $ \_ -> wrapText $+         "Cabalise a project by creating a .cabal, Setup.hs, and "+      ++ "optionally a LICENSE file.\n\n"+      ++ "Calling init with no arguments (recommended) uses an "+      ++ "interactive mode, which will try to guess as much as "+      ++ "possible and prompt you for the rest.  Command-line "+      ++ "arguments are provided for scripting purposes. "+      ++ "If you don't want interactive mode, be sure to pass "+      ++ "the -n flag.\n",+    commandUsage = \pname ->+         "Usage: " ++ pname ++ " init [FLAGS]\n\n"+      ++ "Flags for init:",+    commandDefaultFlags = defaultInitFlags,+    commandOptions = \_ ->+      [ option ['n'] ["non-interactive"]+        "Non-interactive mode."+        IT.nonInteractive (\v flags -> flags { IT.nonInteractive = v })+        trueArg++      , option ['q'] ["quiet"]+        "Do not generate log messages to stdout."+        IT.quiet (\v flags -> flags { IT.quiet = v })+        trueArg++      , option [] ["no-comments"]+        "Do not generate explanatory comments in the .cabal file."+        IT.noComments (\v flags -> flags { IT.noComments = v })+        trueArg++      , option ['m'] ["minimal"]+        "Generate a minimal .cabal file, that is, do not include extra empty fields.  Also implies --no-comments."+        IT.minimal (\v flags -> flags { IT.minimal = v })+        trueArg++      , option [] ["package-dir"]+        "Root directory of the package (default = current directory)."+        IT.packageDir (\v flags -> flags { IT.packageDir = v })+        (reqArgFlag "DIRECTORY")++      , option ['p'] ["package-name"]+        "Name of the Cabal package to create."+        IT.packageName (\v flags -> flags { IT.packageName = v })+        (reqArgFlag "PACKAGE")++      , option [] ["version"]+        "Initial version of the package."+        IT.version (\v flags -> flags { IT.version = v })+        (reqArg "VERSION" (readP_to_E ("Cannot parse package version: "++)+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))++      , option [] ["cabal-version"]+        "Required version of the Cabal library."+        IT.cabalVersion (\v flags -> flags { IT.cabalVersion = v })+        (reqArg "VERSION_RANGE" (readP_to_E ("Cannot parse Cabal version range: "++)+                                            (toFlag `fmap` parse))+                                (flagToList . fmap display))++      , option ['l'] ["license"]+        "Project license."+        IT.license (\v flags -> flags { IT.license = v })+        (reqArg "LICENSE" (readP_to_E ("Cannot parse license: "++)+                                      (toFlag `fmap` parse))+                          (flagToList . fmap display))++      , option ['a'] ["author"]+        "Name of the project's author."+        IT.author (\v flags -> flags { IT.author = v })+        (reqArgFlag "NAME")++      , option ['e'] ["email"]+        "Email address of the maintainer."+        IT.email (\v flags -> flags { IT.email = v })+        (reqArgFlag "EMAIL")++      , option ['u'] ["homepage"]+        "Project homepage and/or repository."+        IT.homepage (\v flags -> flags { IT.homepage = v })+        (reqArgFlag "URL")++      , option ['s'] ["synopsis"]+        "Short project synopsis."+        IT.synopsis (\v flags -> flags { IT.synopsis = v })+        (reqArgFlag "TEXT")++      , option ['c'] ["category"]+        "Project category."+        IT.category (\v flags -> flags { IT.category = v })+        (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))+                            (flagToList . fmap (either id show)))++      , option [] ["is-library"]+        "Build a library."+        IT.packageType (\v flags -> flags { IT.packageType = v })+        (noArg (Flag IT.Library))++      , option [] ["is-executable"]+        "Build an executable."+        IT.packageType+        (\v flags -> flags { IT.packageType = v })+        (noArg (Flag IT.Executable))++      , option ['o'] ["expose-module"]+        "Export a module from the package."+        IT.exposedModules+        (\v flags -> flags { IT.exposedModules = v })+        (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++)+                                     ((Just . (:[])) `fmap` parse))+                         (fromMaybe [] . fmap (fmap display)))++      , option ['d'] ["dependency"]+        "Package dependency."+        IT.dependencies (\v flags -> flags { IT.dependencies = v })+        (reqArg "PACKAGE" (readP_to_E ("Cannot parse dependency: "++)+                                      ((Just . (:[])) `fmap` parse))+                          (fromMaybe [] . fmap (fmap display)))++      , option [] ["source-dir"]+        "Directory containing package source."+        IT.sourceDirs (\v flags -> flags { IT.sourceDirs = v })+        (reqArg' "DIR" (Just . (:[]))+                       (fromMaybe []))++      , option [] ["build-tool"]+        "Required external build tool."+        IT.buildTools (\v flags -> flags { IT.buildTools = v })+        (reqArg' "TOOL" (Just . (:[]))+                        (fromMaybe []))+      ]+  }+  where readMaybe s = case reads s of+                        [(x,"")]  -> Just x+                        _         -> Nothing++-- ------------------------------------------------------------+-- * GetOpt Utils+-- ------------------------------------------------------------++boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt  = Command.boolOpt  flagToMaybe Flag++reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->+              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b+reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList++liftOptions :: (b -> a) -> (a -> b -> b)+            -> [OptionField a] -> [OptionField b]+liftOptions get set = map (liftOption get set)++usagePackages :: String -> String -> String+usagePackages name pname =+     "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"+  ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"+  ++ "Flags for " ++ name ++ ":"++--TODO: do we want to allow per-package flags?+parsePackageArgs :: [String] -> Either String [Dependency]+parsePackageArgs = parsePkgArgs []+  where+    parsePkgArgs ds [] = Right (reverse ds)+    parsePkgArgs ds (arg:args) =+      case readPToMaybe parseDependencyOrPackageId arg of+        Just dep -> parsePkgArgs (dep:ds) args+        Nothing  -> Left $+         show arg ++ " is not valid syntax for a package name or"+                  ++ " package dependency."++readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                     , all isSpace s ]++parseDependencyOrPackageId :: Parse.ReadP r Dependency+parseDependencyOrPackageId = parse Parse.+++ liftM pkgidToDependency parse+  where+    pkgidToDependency :: PackageIdentifier -> Dependency+    pkgidToDependency p = case packageVersion p of+      Version [] _ -> Dependency (packageName p) anyVersion+      version      -> Dependency (packageName p) (thisVersion version)++showRepo :: RemoteRepo -> String+showRepo repo = remoteRepoName repo ++ ":"+             ++ uriToString id (remoteRepoURI repo) []++readRepo :: String -> Maybe RemoteRepo+readRepo = readPToMaybe parseRepo++parseRepo :: Parse.ReadP r RemoteRepo+parseRepo = do+  name <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "_-.")+  _ <- Parse.char ':'+  uriStr <- Parse.munch1 (\c -> isAlphaNum c || c `elem` "+-=._/*()@'$:;&!?~")+  uri <- maybe Parse.pfail return (parseAbsoluteURI uriStr)+  return $ RemoteRepo {+    remoteRepoName = name,+    remoteRepoURI  = uri+  }
+ cabal/cabal-install/Distribution/Client/SetupWrapper.hs view
@@ -0,0 +1,320 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.SetupWrapper+-- Copyright   :  (c) The University of Glasgow 2006,+--                    Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  alpha+-- Portability :  portable+--+-- An interface to building and installing Cabal packages.+-- If the @Built-Type@ field is specified as something other than+-- 'Custom', and the current version of Cabal is acceptable, this performs+-- setup actions directly.  Otherwise it builds the setup script and+-- runs it with the given arguments.++module Distribution.Client.SetupWrapper (+    setupWrapper,+    SetupScriptOptions(..),+    defaultSetupScriptOptions,+  ) where++import Distribution.Client.Types+         ( InstalledPackage )++import qualified Distribution.Make as Make+import qualified Distribution.Simple as Simple+import Distribution.Version+         ( Version(..), VersionRange, anyVersion+         , intersectVersionRanges, orLaterVersion+         , withinRange )+import Distribution.Package+         ( PackageIdentifier(..), PackageName(..), Package(..), packageName+         , packageVersion, Dependency(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(packageDescription)+         , PackageDescription(..), specVersion, BuildType(..) )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Configure+         ( configCompiler )+import Distribution.Simple.Compiler+         ( CompilerFlavor(GHC), Compiler, PackageDB(..), PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration, emptyProgramConfiguration+         , rawSystemProgramConf, ghcProgram )+import Distribution.Simple.BuildPaths+         ( defaultDistPref, exeExtension )+import Distribution.Simple.Command+         ( CommandUI(..), commandShowOptions )+import Distribution.Simple.GHC+         ( ghcVerbosityOptions )+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Client.IndexUtils+         ( getInstalledPackages )+import Distribution.Simple.Utils+         ( die, debug, info, cabalVersion, findPackageDesc, comparing+         , createDirectoryIfMissingVerbose, rewriteFile )+import Distribution.Client.Utils+         ( moreRecentFile, inDir )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import System.Directory  ( doesFileExist, getCurrentDirectory )+import System.FilePath   ( (</>), (<.>) )+import System.IO         ( Handle )+import System.Exit       ( ExitCode(..), exitWith )+import System.Process    ( runProcess, waitForProcess )+import Control.Monad     ( when, unless )+import Data.List         ( maximumBy )+import Data.Maybe        ( fromMaybe, isJust )+import Data.Char         ( isSpace )++data SetupScriptOptions = SetupScriptOptions {+    useCabalVersion  :: VersionRange,+    useCompiler      :: Maybe Compiler,+    usePackageDB     :: PackageDBStack,+    usePackageIndex  :: Maybe (PackageIndex InstalledPackage),+    useProgramConfig :: ProgramConfiguration,+    useDistPref      :: FilePath,+    useLoggingHandle :: Maybe Handle,+    useWorkingDir    :: Maybe FilePath+  }++defaultSetupScriptOptions :: SetupScriptOptions+defaultSetupScriptOptions = SetupScriptOptions {+    useCabalVersion  = anyVersion,+    useCompiler      = Nothing,+    usePackageDB     = [GlobalPackageDB, UserPackageDB],+    usePackageIndex  = Nothing,+    useProgramConfig = emptyProgramConfiguration,+    useDistPref      = defaultDistPref,+    useLoggingHandle = Nothing,+    useWorkingDir    = Nothing+  }++setupWrapper :: Verbosity+             -> SetupScriptOptions+             -> Maybe PackageDescription+             -> CommandUI flags+             -> (Version -> flags)+             -> [String]+             -> IO ()+setupWrapper verbosity options mpkg cmd flags extraArgs = do+  pkg <- maybe getPkg return mpkg+  let setupMethod = determineSetupMethod options' buildType'+      options'    = options {+                      useCabalVersion = intersectVersionRanges+                                          (useCabalVersion options)+                                          (orLaterVersion (specVersion pkg))+                    }+      buildType'  = fromMaybe Custom (buildType pkg)+      mkArgs cabalLibVersion = commandName cmd+                             : commandShowOptions cmd (flags cabalLibVersion)+                            ++ extraArgs+  setupMethod verbosity options' (packageId pkg) buildType' mkArgs+  where+    getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options))+         >>= readPackageDescription verbosity+         >>= return . packageDescription++-- | Decide if we're going to be able to do a direct internal call to the+-- entry point in the Cabal library or if we're going to have to compile+-- and execute an external Setup.hs script.+--+determineSetupMethod :: SetupScriptOptions -> BuildType -> SetupMethod+determineSetupMethod options buildType'+  | isJust (useLoggingHandle options)+ || buildType' == Custom      = externalSetupMethod+  | cabalVersion `withinRange`+      useCabalVersion options = internalSetupMethod+  | otherwise                 = externalSetupMethod++type SetupMethod = Verbosity+                -> SetupScriptOptions+                -> PackageIdentifier+                -> BuildType+                -> (Version -> [String]) -> IO ()++-- ------------------------------------------------------------+-- * Internal SetupMethod+-- ------------------------------------------------------------++internalSetupMethod :: SetupMethod+internalSetupMethod verbosity options _ bt mkargs = do+  let args = mkargs cabalVersion+  debug verbosity $ "Using internal setup method with build-type " ++ show bt+                 ++ " and args:\n  " ++ show args+  inDir (useWorkingDir options) $+    buildTypeAction bt args++buildTypeAction :: BuildType -> ([String] -> IO ())+buildTypeAction Simple    = Simple.defaultMainArgs+buildTypeAction Configure = Simple.defaultMainWithHooksArgs+                              Simple.autoconfUserHooks+buildTypeAction Make      = Make.defaultMainArgs+buildTypeAction Custom               = error "buildTypeAction Custom"+buildTypeAction (UnknownBuildType _) = error "buildTypeAction UnknownBuildType"++-- ------------------------------------------------------------+-- * External SetupMethod+-- ------------------------------------------------------------++externalSetupMethod :: SetupMethod+externalSetupMethod verbosity options pkg bt mkargs = do+  debug verbosity $ "Using external setup method with build-type " ++ show bt+  createDirectoryIfMissingVerbose verbosity True setupDir+  (cabalLibVersion, options') <- cabalLibVersionToUse+  debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion+  setupHs <- updateSetupScript cabalLibVersion bt+  debug verbosity $ "Using " ++ setupHs ++ " as setup script."+  compileSetupExecutable options' cabalLibVersion setupHs+  invokeSetupScript (mkargs cabalLibVersion)++  where+  workingDir       = case fromMaybe "" (useWorkingDir options) of+                       []  -> "."+                       dir -> dir+  setupDir         = workingDir </> useDistPref options </> "setup"+  setupVersionFile = setupDir </> "setup" <.> "version"+  setupProgFile    = setupDir </> "setup" <.> exeExtension++  cabalLibVersionToUse :: IO (Version, SetupScriptOptions)+  cabalLibVersionToUse = do+    savedVersion <- savedCabalVersion+    case savedVersion of+      Just version | version `withinRange` useCabalVersion options+        -> return (version, options)+      _ -> do (comp, conf, options') <- configureCompiler options+              version <- installedCabalVersion options comp conf+              writeFile setupVersionFile (show version ++ "\n")+              return (version, options')++  savedCabalVersion = do+    versionString <- readFile setupVersionFile `catch` \_ -> return ""+    case reads versionString of+      [(version,s)] | all isSpace s -> return (Just version)+      _                             -> return Nothing++  installedCabalVersion :: SetupScriptOptions -> Compiler+                        -> ProgramConfiguration -> IO Version+  installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" =+    return (packageVersion pkg)+  installedCabalVersion options' comp conf = do+    index <- case usePackageIndex options' of+      Just index -> return index+      Nothing    -> getInstalledPackages verbosity+                      comp (usePackageDB options') conf++    let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)+    case PackageIndex.lookupDependency index cabalDep of+      []   -> die $ "The package requires Cabal library version "+                 ++ display (useCabalVersion options)+                 ++ " but no suitable version is installed."+      pkgs -> return $ bestVersion (map packageVersion pkgs)+    where+      bestVersion          = maximumBy (comparing preference)+      preference version   = (sameVersion, sameMajorVersion+                             ,stableVersion, latestVersion)+        where+          sameVersion      = version == cabalVersion+          sameMajorVersion = majorVersion version == majorVersion cabalVersion+          majorVersion     = take 2 . versionBranch+          stableVersion    = case versionBranch version of+                               (_:x:_) -> even x+                               _       -> False+          latestVersion    = version++  configureCompiler :: SetupScriptOptions+                    -> IO (Compiler, ProgramConfiguration, SetupScriptOptions)+  configureCompiler options' = do+    (comp, conf) <- case useCompiler options' of+      Just comp -> return (comp, useProgramConfig options')+      Nothing   -> configCompiler (Just GHC) Nothing Nothing+                     (useProgramConfig options') verbosity+    return (comp, conf, options' { useCompiler = Just comp,+                                   useProgramConfig = conf })++  -- | Decide which Setup.hs script to use, creating it if necessary.+  --+  updateSetupScript :: Version -> BuildType -> IO FilePath+  updateSetupScript _ Custom = do+    useHs  <- doesFileExist setupHs+    useLhs <- doesFileExist setupLhs+    unless (useHs || useLhs) $ die+      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."+    return (if useHs then setupHs else setupLhs)+    where+      setupHs  = workingDir </> "Setup.hs"+      setupLhs = workingDir </> "Setup.lhs"++  updateSetupScript cabalLibVersion _ = do+    rewriteFile setupHs (buildTypeScript cabalLibVersion)+    return setupHs+    where+      setupHs  = setupDir </> "setup.hs"++  buildTypeScript :: Version -> String+  buildTypeScript cabalLibVersion = case bt of+    Simple    -> "import Distribution.Simple; main = defaultMain\n"+    Configure -> "import Distribution.Simple; main = defaultMainWithHooks "+              ++ if cabalLibVersion >= Version [1,3,10] []+                   then "autoconfUserHooks\n"+                   else "defaultUserHooks\n"+    Make      -> "import Distribution.Make; main = defaultMain\n"+    Custom             -> error "buildTypeScript Custom"+    UnknownBuildType _ -> error "buildTypeScript UnknownBuildType"++  -- | If the Setup.hs is out of date wrt the executable then recompile it.+  -- Currently this is GHC only. It should really be generalised.+  --+  compileSetupExecutable :: SetupScriptOptions -> Version -> FilePath -> IO ()+  compileSetupExecutable options' cabalLibVersion setupHsFile = do+    setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile+    cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile+    let outOfDate = setupHsNewer || cabalVersionNewer+    when outOfDate $ do+      debug verbosity "Setup script is out of date, compiling..."+      (_, conf, _) <- configureCompiler options'+      --TODO: get Cabal's GHC module to export a GhcOptions type and render func+      rawSystemProgramConf verbosity ghcProgram conf $+          ghcVerbosityOptions verbosity+       ++ ["--make", setupHsFile, "-o", setupProgFile+          ,"-odir", setupDir, "-hidir", setupDir+          ,"-i", "-i" ++ workingDir ]+       ++ ghcPackageDbOptions (usePackageDB options')+       ++ if packageName pkg == PackageName "Cabal"+            then []+            else ["-package", display cabalPkgid]+    where+      cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion++      ghcPackageDbOptions :: PackageDBStack -> [String]+      ghcPackageDbOptions dbstack = case dbstack of+        (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+        (GlobalPackageDB:dbs)               -> "-no-user-package-conf"+                                             : concatMap specific dbs+        _                                   -> ierror+        where+          specific (SpecificPackageDB db) = [ "-package-conf", db ]+          specific _ = ierror+          ierror     = error "internal error: unexpected package db stack"+++  invokeSetupScript :: [String] -> IO ()+  invokeSetupScript args = do+    info verbosity $ unwords (setupProgFile : args)+    case useLoggingHandle options of+      Nothing        -> return ()+      Just logHandle -> info verbosity $ "Redirecting build log to "+                                      ++ show logHandle+    currentDir <- getCurrentDirectory+    process <- runProcess (currentDir </> setupProgFile) args+                 (useWorkingDir options) Nothing+                 Nothing (useLoggingHandle options) (useLoggingHandle options)+    exitCode <- waitForProcess process+    unless (exitCode == ExitSuccess) $ exitWith exitCode
+ cabal/cabal-install/Distribution/Client/SrcDist.hs view
@@ -0,0 +1,80 @@+-- Implements the \"@.\/cabal sdist@\" command, which creates a source+-- distribution for this package.  That is, packs up the source code+-- into a tarball, making use of the corresponding Cabal module.+module Distribution.Client.SrcDist (+         sdist+  )  where+import Distribution.Simple.SrcDist+         ( printPackageProblems, prepareTree+         , prepareSnapshotTree, snapshotPackage )+import Distribution.Client.Tar (createTarGzFile)++import Distribution.Package+         ( Package(..) )+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.PackageDescription.Parse+         ( readPackageDescription )+import Distribution.Simple.Utils+         ( defaultPackageDesc, warn, notice, setupMessage+         , createDirectoryIfMissingVerbose, withTempDirectory )+import Distribution.Simple.Setup (SDistFlags(..), fromFlag)+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.PreProcess (knownSuffixHandlers)+import Distribution.Simple.BuildPaths ( srcPref)+import Distribution.Simple.Configure(maybeGetPersistBuildConfig)+import Distribution.PackageDescription.Configuration ( flattenPackageDescription )+import Distribution.Text+         ( display )++import System.Time (getClockTime, toCalendarTime)+import System.FilePath ((</>), (<.>))+import Control.Monad (when)+import Data.Maybe (isNothing)++-- |Create a source distribution.+sdist :: SDistFlags -> IO ()+sdist flags = do+  pkg <- return . flattenPackageDescription+     =<< readPackageDescription verbosity+     =<< defaultPackageDesc verbosity+  mb_lbi <- maybeGetPersistBuildConfig distPref+  let tmpTargetDir = srcPref distPref++  -- do some QA+  printPackageProblems verbosity pkg++  when (isNothing mb_lbi) $+    warn verbosity "Cannot run preprocessors. Run 'configure' command first."++  createDirectoryIfMissingVerbose verbosity True tmpTargetDir+  withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do++    date <- toCalendarTime =<< getClockTime+    let pkg' | snapshot  = snapshotPackage date pkg+             | otherwise = pkg+    setupMessage verbosity "Building source dist for" (packageId pkg')++    _ <- if snapshot+      then prepareSnapshotTree verbosity pkg' mb_lbi distPref tmpDir pps+      else prepareTree         verbosity pkg' mb_lbi distPref tmpDir pps+    targzFile <- createArchive verbosity pkg' tmpDir distPref+    notice verbosity $ "Source tarball created: " ++ targzFile++  where+    verbosity = fromFlag (sDistVerbosity flags)+    snapshot  = fromFlag (sDistSnapshot flags)+    distPref  = fromFlag (sDistDistPref flags)+    pps       = knownSuffixHandlers++-- |Create an archive from a tree of source files, and clean up the tree.+createArchive :: Verbosity+              -> PackageDescription+              -> FilePath+              -> FilePath+              -> IO FilePath+createArchive _verbosity pkg tmpDir targetPref = do+  let tarBallName     = display (packageId pkg)+      tarBallFilePath = targetPref </> tarBallName <.> "tar.gz"+  createTarGzFile tarBallFilePath tmpDir tarBallName+  return tarBallFilePath
+ cabal/cabal-install/Distribution/Client/Tar.hs view
@@ -0,0 +1,903 @@+{-# OPTIONS_GHC -fno-warn-unused-imports #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Tar+-- Copyright   :  (c) 2007 Bjorn Bringert,+--                    2008 Andrea Vezzosi,+--                    2008-2009 Duncan Coutts+-- License     :  BSD3+--+-- Maintainer  :  duncan@community.haskell.org+-- Portability :  portable+--+-- Reading, writing and manipulating \"@.tar@\" archive files.+--+-----------------------------------------------------------------------------+module Distribution.Client.Tar (+  -- * High level \"all in one\" operations+  createTarGzFile,+  extractTarGzFile,++  -- * Converting between internal and external representation+  read,+  write,++  -- * Packing and unpacking files to\/from internal representation+  pack,+  unpack,++  -- * Tar entry and associated types+  Entry(..),+  entryPath,+  EntryContent(..),+  Ownership(..),+  FileSize,+  Permissions,+  EpochTime,+  DevMajor,+  DevMinor,+  TypeCode,+  Format(..),++  -- * Constructing simple entry values+  simpleEntry,+  fileEntry,+  directoryEntry,++  -- * TarPath type+  TarPath,+  toTarPath,+  fromTarPath,++  -- ** Sequences of tar entries+  Entries(..),+  foldrEntries,+  foldlEntries,+  unfoldrEntries,+  mapEntries,+  filterEntries,+  entriesIndex,++  ) where++import Data.Char     (ord)+import Data.Int      (Int64)+import Data.Bits     (Bits, shiftL, testBit)+import Data.List     (foldl')+import Numeric       (readOct, showOct)+import Control.Monad (MonadPlus(mplus), when)+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.ByteString.Lazy (ByteString)+import qualified Codec.Compression.GZip as GZip+import qualified Distribution.Client.GZipUtils as GZipUtils++import System.FilePath+         ( (</>) )+import qualified System.FilePath         as FilePath.Native+import qualified System.FilePath.Windows as FilePath.Windows+import qualified System.FilePath.Posix   as FilePath.Posix+import System.Directory+         ( getDirectoryContents, doesDirectoryExist, getModificationTime+         , getPermissions, createDirectoryIfMissing, copyFile )+import qualified System.Directory as Permissions+         ( Permissions(executable) )+import Distribution.Compat.FilePerms+         ( setFileExecutable )+import System.Posix.Types+         ( FileMode )+import System.Time+         ( ClockTime(..) )+import System.IO+         ( IOMode(ReadMode), openBinaryFile, hFileSize )+import System.IO.Unsafe (unsafeInterleaveIO)++import Prelude hiding (read)+++--+-- * High level operations+--++createTarGzFile :: FilePath  -- ^ Full Tarball path+                -> FilePath  -- ^ Base directory+                -> FilePath  -- ^ Directory to archive, relative to base dir+                -> IO ()+createTarGzFile tar base dir =+  BS.writeFile tar . GZip.compress . write =<< pack base [dir]++extractTarGzFile :: FilePath -- ^ Destination directory+                 -> FilePath -- ^ Expected subdir (to check for tarbombs)+                 -> FilePath -- ^ Tarball+                -> IO ()+extractTarGzFile dir expected tar = do+  unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar++--+-- * Entry type+--++type FileSize  = Int64+-- | The number of seconds since the UNIX epoch+type EpochTime = Int64+type DevMajor  = Int+type DevMinor  = Int+type TypeCode  = Char+type Permissions = FileMode++-- | Tar archive entry.+--+data Entry = Entry {++    -- | The path of the file or directory within the archive. This is in a+    -- tar-specific form. Use 'entryPath' to get a native 'FilePath'.+    entryTarPath :: !TarPath,++    -- | The real content of the entry. For 'NormalFile' this includes the+    -- file data. An entry usually contains a 'NormalFile' or a 'Directory'.+    entryContent :: !EntryContent,++    -- | File permissions (Unix style file mode).+    entryPermissions :: !Permissions,++    -- | The user and group to which this file belongs.+    entryOwnership :: !Ownership,++    -- | The time the file was last modified.+    entryTime :: !EpochTime,++    -- | The tar format the archive is using.+    entryFormat :: !Format+  }++-- | Native 'FilePath' of the file or directory within the archive.+--+entryPath :: Entry -> FilePath+entryPath = fromTarPath . entryTarPath++-- | The content of a tar archive entry, which depends on the type of entry.+--+-- Portable archives should contain only 'NormalFile' and 'Directory'.+--+data EntryContent = NormalFile      ByteString !FileSize+                  | Directory+                  | SymbolicLink    !LinkTarget+                  | HardLink        !LinkTarget+                  | CharacterDevice !DevMajor !DevMinor+                  | BlockDevice     !DevMajor !DevMinor+                  | NamedPipe+                  | OtherEntryType  !TypeCode ByteString !FileSize++data Ownership = Ownership {+    -- | The owner user name. Should be set to @\"\"@ if unknown.+    ownerName :: String,++    -- | The owner group name. Should be set to @\"\"@ if unknown.+    groupName :: String,++    -- | Numeric owner user id. Should be set to @0@ if unknown.+    ownerId :: !Int,++    -- | Numeric owner group id. Should be set to @0@ if unknown.+    groupId :: !Int+  }++-- | There have been a number of extensions to the tar file format over the+-- years. They all share the basic entry fields and put more meta-data in+-- different extended headers.+--+data Format =++     -- | This is the classic Unix V7 tar format. It does not support owner and+     -- group names, just numeric Ids. It also does not support device numbers.+     V7Format++     -- | The \"USTAR\" format is an extension of the classic V7 format. It was+     -- later standardised by POSIX. It has some restructions but is the most+     -- portable format.+     --+   | UstarFormat++     -- | The GNU tar implementation also extends the classic V7 format, though+     -- in a slightly different way from the USTAR format. In general for new+     -- archives the standard USTAR/POSIX should be used.+     --+   | GnuFormat+  deriving Eq++-- | @rw-r--r--@ for normal files+ordinaryFilePermissions :: Permissions+ordinaryFilePermissions   = 0o0644++-- | @rwxr-xr-x@ for executable files+executableFilePermissions :: Permissions+executableFilePermissions = 0o0755++-- | @rwxr-xr-x@ for directories+directoryPermissions :: Permissions+directoryPermissions  = 0o0755++isExecutable :: Permissions -> Bool+isExecutable p = testBit p 0 || testBit p 6 -- user or other exectuable++-- | An 'Entry' with all default values except for the file name and type. It+-- uses the portable USTAR/POSIX format (see 'UstarHeader').+--+-- You can use this as a basis and override specific fields, eg:+--+-- > (emptyEntry name HardLink) { linkTarget = target }+--+simpleEntry :: TarPath -> EntryContent -> Entry+simpleEntry tarpath content = Entry {+    entryTarPath     = tarpath,+    entryContent     = content,+    entryPermissions = case content of+                         Directory -> directoryPermissions+                         _         -> ordinaryFilePermissions,+    entryOwnership   = Ownership "" "" 0 0,+    entryTime        = 0,+    entryFormat      = UstarFormat+  }++-- | A tar 'Entry' for a file.+--+-- Entry  fields such as file permissions and ownership have default values.+--+-- You can use this as a basis and override specific fields. For example if you+-- need an executable file you could use:+--+-- > (fileEntry name content) { fileMode = executableFileMode }+--+fileEntry :: TarPath -> ByteString -> Entry+fileEntry name fileContent =+  simpleEntry name (NormalFile fileContent (BS.length fileContent))++-- | A tar 'Entry' for a directory.+--+-- Entry fields such as file permissions and ownership have default values.+--+directoryEntry :: TarPath -> Entry+directoryEntry name = simpleEntry name Directory++--+-- * Tar paths+--++-- | The classic tar format allowed just 100 charcters for the file name. The+-- USTAR format extended this with an extra 155 characters, however it uses a+-- complex method of splitting the name between the two sections.+--+-- Instead of just putting any overflow into the extended area, it uses the+-- extended area as a prefix. The agrevating insane bit however is that the+-- prefix (if any) must only contain a directory prefix. That is the split+-- between the two areas must be on a directory separator boundary. So there is+-- no simple calculation to work out if a file name is too long. Instead we+-- have to try to find a valid split that makes the name fit in the two areas.+--+-- The rationale presumably was to make it a bit more compatible with old tar+-- programs that only understand the classic format. A classic tar would be+-- able to extract the file name and possibly some dir prefix, but not the+-- full dir prefix. So the files would end up in the wrong place, but that's+-- probably better than ending up with the wrong names too.+--+-- So it's understandable but rather annoying.+--+-- * Tar paths use posix format (ie @\'/\'@ directory separators), irrespective+--   of the local path conventions.+--+-- * The directory separator between the prefix and name is /not/ stored.+--+data TarPath = TarPath FilePath -- path name, 100 characters max.+                       FilePath -- path prefix, 155 characters max.+  deriving (Eq, Ord)++-- | Convert a 'TarPath' to a native 'FilePath'.+--+-- The native 'FilePath' will use the native directory separator but it is not+-- otherwise checked for validity or sanity. In particular:+--+-- * The tar path may be invalid as a native path, eg the filename @\"nul\"@ is+--   not valid on Windows.+--+-- * The tar path may be an absolute path or may contain @\"..\"@ components.+--   For security reasons this should not usually be allowed, but it is your+--   responsibility to check for these conditions (eg using 'checkSecurity').+--+fromTarPath :: TarPath -> FilePath+fromTarPath (TarPath name prefix) = adjustDirectory $+  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories prefix+                          ++ FilePath.Posix.splitDirectories name+  where+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator name+                    = FilePath.Native.addTrailingPathSeparator+                    | otherwise = id++-- | Convert a native 'FilePath' to a 'TarPath'.+--+-- The conversion may fail if the 'FilePath' is too long. See 'TarPath' for a+-- description of the problem with splitting long 'FilePath's.+--+toTarPath :: Bool -- ^ Is the path for a directory? This is needed because for+                  -- directories a 'TarPath' must always use a trailing @\/@.+          -> FilePath -> Either String TarPath+toTarPath isDir = splitLongPath+                . addTrailingSep+                . FilePath.Posix.joinPath+                . FilePath.Native.splitDirectories+  where+    addTrailingSep | isDir     = FilePath.Posix.addTrailingPathSeparator+                   | otherwise = id++-- | Take a sanitized path, split on directory separators and try to pack it+-- into the 155 + 100 tar file name format.+--+-- The stragey is this: take the name-directory components in reverse order+-- and try to fit as many components into the 100 long name area as possible.+-- If all the remaining components fit in the 155 name area then we win.+--+splitLongPath :: FilePath -> Either String TarPath+splitLongPath path =+  case packName nameMax (reverse (FilePath.Posix.splitPath path)) of+    Left err                 -> Left err+    Right (name, [])         -> Right (TarPath name "")+    Right (name, first:rest) -> case packName prefixMax remainder of+      Left err               -> Left err+      Right (_     , (_:_))  -> Left "File name too long (cannot split)"+      Right (prefix, [])     -> Right (TarPath name prefix)+      where+        -- drop the '/' between the name and prefix:+        remainder = init first : rest++  where+    nameMax, prefixMax :: Int+    nameMax   = 100+    prefixMax = 155++    packName _      []     = Left "File name empty"+    packName maxLen (c:cs)+      | n > maxLen         = Left "File name too long"+      | otherwise          = Right (packName' maxLen n [c] cs)+      where n = length c++    packName' maxLen n ok (c:cs)+      | n' <= maxLen             = packName' maxLen n' (c:ok) cs+                                     where n' = n + length c+    packName' _      _ ok    cs  = (FilePath.Posix.joinPath ok, cs)++-- | The tar format allows just 100 ASCII charcters for the 'SymbolicLink' and+-- 'HardLink' entry types.+--+newtype LinkTarget = LinkTarget FilePath+  deriving (Eq, Ord)++-- | Convert a tar 'LinkTarget' to a native 'FilePath'.+--+fromLinkTarget :: LinkTarget -> FilePath+fromLinkTarget (LinkTarget path) = adjustDirectory $+  FilePath.Native.joinPath $ FilePath.Posix.splitDirectories path+  where+    adjustDirectory | FilePath.Posix.hasTrailingPathSeparator path+                    = FilePath.Native.addTrailingPathSeparator+                    | otherwise = id++--+-- * Entries type+--++-- | A tar archive is a sequence of entries.+data Entries = Next Entry Entries+             | Done+             | Fail String++unfoldrEntries :: (a -> Either String (Maybe (Entry, a))) -> a -> Entries+unfoldrEntries f = unfold+  where+    unfold x = case f x of+      Left err             -> Fail err+      Right Nothing        -> Done+      Right (Just (e, x')) -> Next e (unfold x')++foldrEntries :: (Entry -> a -> a) -> a -> (String -> a) -> Entries -> a+foldrEntries next done fail' = fold+  where+    fold (Next e es) = next e (fold es)+    fold Done        = done+    fold (Fail err)  = fail' err++foldlEntries :: (a -> Entry -> a) -> a -> Entries -> Either String a+foldlEntries f = fold+  where+    fold a (Next e es) = (fold $! f a e) es+    fold a Done        = Right a+    fold _ (Fail err)  = Left err++mapEntries :: (Entry -> Entry) -> Entries -> Entries+mapEntries f = foldrEntries (Next . f) Done Fail++filterEntries :: (Entry -> Bool) -> Entries -> Entries+filterEntries p =+  foldrEntries+    (\entry rest -> if p entry+                      then Next entry rest+                      else rest)+    Done Fail++checkEntries :: (Entry -> Maybe String) -> Entries -> Entries+checkEntries checkEntry =+  foldrEntries+    (\entry rest -> case checkEntry entry of+                      Nothing  -> Next entry rest+                      Just err -> Fail err)+    Done Fail++entriesIndex :: Entries -> Either String (Map.Map TarPath Entry)+entriesIndex = foldlEntries (\m e -> Map.insert (entryTarPath e) e m) Map.empty++--+-- * Checking+--++-- | This function checks a sequence of tar entries for file name security+-- problems. It checks that:+--+-- * file paths are not absolute+--+-- * file paths do not contain any path components that are \"@..@\"+--+-- * file names are valid+--+-- These checks are from the perspective of the current OS. That means we check+-- for \"@C:\blah@\" files on Windows and \"\/blah\" files on unix. For archive+-- entry types 'HardLink' and 'SymbolicLink' the same checks are done for the+-- link target. A failure in any entry terminates the sequence of entries with+-- an error.+--+checkSecurity :: Entries -> Entries+checkSecurity = checkEntries checkEntrySecurity++checkTarbomb :: FilePath -> Entries -> Entries+checkTarbomb expectedTopDir = checkEntries (checkEntryTarbomb expectedTopDir)++checkEntrySecurity :: Entry -> Maybe String+checkEntrySecurity entry = case entryContent entry of+    HardLink     link -> check (entryPath entry)+                 `mplus` check (fromLinkTarget link)+    SymbolicLink link -> check (entryPath entry)+                 `mplus` check (fromLinkTarget link)+    _                 -> check (entryPath entry)++  where+    check name+      | not (FilePath.Native.isRelative name)+      = Just $ "Absolute file name in tar archive: " ++ show name++      | not (FilePath.Native.isValid name)+      = Just $ "Invalid file name in tar archive: " ++ show name++      | any (=="..") (FilePath.Native.splitDirectories name)+      = Just $ "Invalid file name in tar archive: " ++ show name++      | otherwise = Nothing++checkEntryTarbomb :: FilePath -> Entry -> Maybe String+checkEntryTarbomb _ entry | nonFilesystemEntry = Nothing+  where+    -- Ignore some special entries we will not unpack anyway+    nonFilesystemEntry =+      case entryContent entry of+        OtherEntryType 'g' _ _ -> True --PAX global header+        OtherEntryType 'x' _ _ -> True --PAX individual header+        _                      -> False++checkEntryTarbomb expectedTopDir entry =+  case FilePath.Native.splitDirectories (entryPath entry) of+    (topDir:_) | topDir == expectedTopDir -> Nothing+    _ -> Just $ "File in tar archive is not in the expected directory "+             ++ show expectedTopDir+++--+-- * Reading+--++read :: ByteString -> Entries+read = unfoldrEntries getEntry++getEntry :: ByteString -> Either String (Maybe (Entry, ByteString))+getEntry bs+  | BS.length header < 512 = Left "truncated tar archive"++  -- Tar files end with at least two blocks of all '0'. Checking this serves+  -- two purposes. It checks the format but also forces the tail of the data+  -- which is necessary to close the file if it came from a lazily read file.+  | BS.head bs == 0 = case BS.splitAt 1024 bs of+      (end, trailing)+        | BS.length end /= 1024        -> Left "short tar trailer"+        | not (BS.all (== 0) end)      -> Left "bad tar trailer"+        | not (BS.all (== 0) trailing) -> Left "tar file has trailing junk"+        | otherwise                    -> Right Nothing++  | otherwise  = partial $ do++  case (chksum_, format_) of+    (Ok chksum, _   ) | correctChecksum header chksum -> return ()+    (Ok _,      Ok _) -> fail "tar checksum error"+    _                 -> fail "data is not in tar format"++  -- These fields are partial, have to check them+  format   <- format_;   mode     <- mode_;+  uid      <- uid_;      gid      <- gid_;+  size     <- size_;     mtime    <- mtime_;+  devmajor <- devmajor_; devminor <- devminor_;++  let content = BS.take size (BS.drop 512 bs)+      padding = (512 - size) `mod` 512+      bs'     = BS.drop (512 + size + padding) bs++      entry = Entry {+        entryTarPath     = TarPath name prefix,+        entryContent     = case typecode of+                   '\0' -> NormalFile      content size+                   '0'  -> NormalFile      content size+                   '1'  -> HardLink        (LinkTarget linkname)+                   '2'  -> SymbolicLink    (LinkTarget linkname)+                   '3'  -> CharacterDevice devmajor devminor+                   '4'  -> BlockDevice     devmajor devminor+                   '5'  -> Directory+                   '6'  -> NamedPipe+                   '7'  -> NormalFile      content size+                   _    -> OtherEntryType  typecode content size,+        entryPermissions = mode,+        entryOwnership   = Ownership uname gname uid gid,+        entryTime        = mtime,+        entryFormat      = format+    }++  return (Just (entry, bs'))++  where+   header = BS.take 512 bs++   name       = getString   0 100 header+   mode_      = getOct    100   8 header+   uid_       = getOct    108   8 header+   gid_       = getOct    116   8 header+   size_      = getOct    124  12 header+   mtime_     = getOct    136  12 header+   chksum_    = getOct    148   8 header+   typecode   = getByte   156     header+   linkname   = getString 157 100 header+   magic      = getChars  257   8 header+   uname      = getString 265  32 header+   gname      = getString 297  32 header+   devmajor_  = getOct    329   8 header+   devminor_  = getOct    337   8 header+   prefix     = getString 345 155 header+-- trailing   = getBytes  500  12 header++   format_ = case magic of+    "\0\0\0\0\0\0\0\0" -> return V7Format+    "ustar\NUL00"      -> return UstarFormat+    "ustar  \NUL"      -> return GnuFormat+    _                  -> fail "tar entry not in a recognised format"++correctChecksum :: ByteString -> Int -> Bool+correctChecksum header checksum = checksum == checksum'+  where+    -- sum of all 512 bytes in the header block,+    -- treating each byte as an 8-bit unsigned value+    checksum' = BS.Char8.foldl' (\x y -> x + ord y) 0 header'+    -- treating the 8 bytes of chksum as blank characters.+    header'   = BS.concat [BS.take 148 header,+                           BS.Char8.replicate 8 ' ',+                           BS.drop 156 header]++-- * TAR format primitive input++getOct :: (Integral a, Bits a) => Int64 -> Int64 -> ByteString -> Partial a+getOct off len header+  | BS.head bytes == 128 = parseBinInt (BS.unpack (BS.tail bytes))+  | null octstr          = return 0+  | otherwise            = case readOct octstr of+               [(x,[])] -> return x+               _        -> fail "tar header is malformed (bad numeric encoding)"+  where+    bytes  = getBytes off len header+    octstr = BS.Char8.unpack+           . BS.Char8.takeWhile (\c -> c /= '\NUL' && c /= ' ')+           . BS.Char8.dropWhile (== ' ')+           $ bytes++    -- Some tar programs switch into a binary format when they try to represent+    -- field values that will not fit in the required width when using the text+    -- octal format. In particular, the UID/GID fields can only hold up to 2^21+    -- while in the binary format can hold up to 2^32. The binary format uses+    -- '\128' as the header which leaves 7 bytes. Only the last 4 are used.+    parseBinInt [0, 0, 0, byte3, byte2, byte1, byte0] =+      return $! shiftL (fromIntegral byte3) 24+              + shiftL (fromIntegral byte2) 16+              + shiftL (fromIntegral byte1) 8+              + shiftL (fromIntegral byte0) 0+    parseBinInt _ = fail "tar header uses non-standard number encoding"++getBytes :: Int64 -> Int64 -> ByteString -> ByteString+getBytes off len = BS.take len . BS.drop off++getByte :: Int64 -> ByteString -> Char+getByte off bs = BS.Char8.index bs off++getChars :: Int64 -> Int64 -> ByteString -> String+getChars off len = BS.Char8.unpack . getBytes off len++getString :: Int64 -> Int64 -> ByteString -> String+getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0') . getBytes off len++data Partial a = Error String | Ok a++partial :: Partial a -> Either String a+partial (Error msg) = Left msg+partial (Ok x)      = Right x++instance Monad Partial where+    return        = Ok+    Error m >>= _ = Error m+    Ok    x >>= k = k x+    fail          = Error++--+-- * Writing+--++-- | Create the external representation of a tar archive by serialising a list+-- of tar entries.+--+-- * The conversion is done lazily.+--+write :: [Entry] -> ByteString+write es = BS.concat $ map putEntry es ++ [BS.replicate (512*2) 0]++putEntry :: Entry -> ByteString+putEntry entry = case entryContent entry of+  NormalFile       content size -> BS.concat [ header, content, padding size ]+  OtherEntryType _ content size -> BS.concat [ header, content, padding size ]+  _                             -> header+  where+    header       = putHeader entry+    padding size = BS.replicate paddingSize 0+      where paddingSize = fromIntegral (negate size `mod` 512)++putHeader :: Entry -> ByteString+putHeader entry =+     BS.Char8.pack $ take 148 block+  ++ putOct 7 checksum+  ++ ' ' : drop 156 block+  where+    block    = putHeaderNoChkSum entry+    checksum = foldl' (\x y -> x + ord y) 0 block++putHeaderNoChkSum :: Entry -> String+putHeaderNoChkSum Entry {+    entryTarPath     = TarPath name prefix,+    entryContent     = content,+    entryPermissions = permissions,+    entryOwnership   = ownership,+    entryTime        = modTime,+    entryFormat      = format+  } =++  concat+    [ putString  100 $ name+    , putOct       8 $ permissions+    , putOct       8 $ ownerId ownership+    , putOct       8 $ groupId ownership+    , putOct      12 $ contentSize+    , putOct      12 $ modTime+    , fill         8 $ ' ' -- dummy checksum+    , putChar8       $ typeCode+    , putString  100 $ linkTarget+    ] +++  case format of+  V7Format    ->+      fill 255 '\NUL'+  UstarFormat -> concat+    [ putString    8 $ "ustar\NUL00"+    , putString   32 $ ownerName ownership+    , putString   32 $ groupName ownership+    , putOct       8 $ deviceMajor+    , putOct       8 $ deviceMinor+    , putString  155 $ prefix+    , fill        12 $ '\NUL'+    ]+  GnuFormat -> concat+    [ putString    8 $ "ustar  \NUL"+    , putString   32 $ ownerName ownership+    , putString   32 $ groupName ownership+    , putGnuDev    8 $ deviceMajor+    , putGnuDev    8 $ deviceMinor+    , putString  155 $ prefix+    , fill        12 $ '\NUL'+    ]+  where+    (typeCode, contentSize, linkTarget,+     deviceMajor, deviceMinor) = case content of+       NormalFile      _ size            -> ('0' , size, [],   0,     0)+       Directory                         -> ('5' , 0,    [],   0,     0)+       SymbolicLink    (LinkTarget link) -> ('2' , 0,    link, 0,     0)+       HardLink        (LinkTarget link) -> ('1' , 0,    link, 0,     0)+       CharacterDevice major minor       -> ('3' , 0,    [],   major, minor)+       BlockDevice     major minor       -> ('4' , 0,    [],   major, minor)+       NamedPipe                         -> ('6' , 0,    [],   0,     0)+       OtherEntryType  code _ size       -> (code, size, [],   0,     0)++    putGnuDev w n = case content of+      CharacterDevice _ _ -> putOct w n+      BlockDevice     _ _ -> putOct w n+      _                   -> replicate w '\NUL'++-- * TAR format primitive output++type FieldWidth = Int++putString :: FieldWidth -> String -> String+putString n s = take n s ++ fill (n - length s) '\NUL'++--TODO: check integer widths, eg for large file sizes+putOct :: Integral a => FieldWidth -> a -> String+putOct n x =+  let octStr = take (n-1) $ showOct x ""+   in fill (n - length octStr - 1) '0'+   ++ octStr+   ++ putChar8 '\NUL'++putChar8 :: Char -> String+putChar8 c = [c]++fill :: FieldWidth -> Char -> String+fill n c = replicate n c++--+-- * Unpacking+--++unpack :: FilePath -> Entries -> IO ()+unpack baseDir entries = unpackEntries [] (checkSecurity entries)+                     >>= emulateLinks++  where+    -- We're relying here on 'checkSecurity' to make sure we're not scribbling+    -- files all over the place.++    unpackEntries _     (Fail err)      = fail err+    unpackEntries links Done            = return links+    unpackEntries links (Next entry es) = case entryContent entry of+      NormalFile file _ -> extractFile entry path file+                        >> unpackEntries links es+      Directory         -> extractDir path+                        >> unpackEntries links es+      HardLink     link -> (unpackEntries $! saveLink path link links) es+      SymbolicLink link -> (unpackEntries $! saveLink path link links) es+      _                 -> unpackEntries links es --ignore other file types+      where+        path = entryPath entry++    extractFile entry path content = do+      -- Note that tar archives do not make sure each directory is created+      -- before files they contain, indeed we may have to create several+      -- levels of directory.+      createDirectoryIfMissing True absDir+      BS.writeFile absPath content+      when (isExecutable (entryPermissions entry))+           (setFileExecutable absPath)+      where+        absDir  = baseDir </> FilePath.Native.takeDirectory path+        absPath = baseDir </> path++    extractDir path = createDirectoryIfMissing True (baseDir </> path)++    saveLink path link links = seq (length path)+                             $ seq (length link')+                             $ (path, link'):links+      where link' = fromLinkTarget link++    emulateLinks = mapM_ $ \(relPath, relLinkTarget) ->+      let absPath   = baseDir </> relPath+          absTarget = FilePath.Native.takeDirectory absPath </> relLinkTarget+       in copyFile absTarget absPath++--+-- * Packing+--++pack :: FilePath   -- ^ Base directory+     -> [FilePath] -- ^ Files and directories to pack, relative to the base dir+     -> IO [Entry]+pack baseDir paths0 = preparePaths baseDir paths0 >>= packPaths baseDir++preparePaths :: FilePath -> [FilePath] -> IO [FilePath]+preparePaths baseDir paths =+  fmap concat $ interleave+    [ do isDir  <- doesDirectoryExist (baseDir </> path)+         if isDir+           then do entries <- getDirectoryContentsRecursive (baseDir </> path)+                   return (FilePath.Native.addTrailingPathSeparator path+                         : map (path </>) entries)+           else return [path]+    | path <- paths ]++packPaths :: FilePath -> [FilePath] -> IO [Entry]+packPaths baseDir paths =+  interleave+    [ do tarpath <- either fail return (toTarPath isDir relpath)+         if isDir then packDirectoryEntry filepath tarpath+                  else packFileEntry      filepath tarpath+    | relpath <- paths+    , let isDir    = FilePath.Native.hasTrailingPathSeparator filepath+          filepath = baseDir </> relpath ]++interleave :: [IO a] -> IO [a]+interleave = unsafeInterleaveIO . go+  where+    go []     = return []+    go (x:xs) = do+      x'  <- x+      xs' <- interleave xs+      return (x':xs')++packFileEntry :: FilePath -- ^ Full path to find the file on the local disk+              -> TarPath  -- ^ Path to use for the tar Entry in the archive+              -> IO Entry+packFileEntry filepath tarpath = do+  mtime   <- getModTime filepath+  perms   <- getPermissions filepath+  file    <- openBinaryFile filepath ReadMode+  size    <- hFileSize file+  content <- BS.hGetContents file+  return (simpleEntry tarpath (NormalFile content (fromIntegral size))) {+    entryPermissions = if Permissions.executable perms+                         then executableFilePermissions+                         else ordinaryFilePermissions,+    entryTime = mtime+  }++packDirectoryEntry :: FilePath -- ^ Full path to find the file on the local disk+                   -> TarPath  -- ^ Path to use for the tar Entry in the archive+                   -> IO Entry+packDirectoryEntry filepath tarpath = do+  mtime   <- getModTime filepath+  return (directoryEntry tarpath) {+    entryTime = mtime+  }++getDirectoryContentsRecursive :: FilePath -> IO [FilePath]+getDirectoryContentsRecursive dir0 =+  fmap tail (recurseDirectories dir0 [""])++recurseDirectories :: FilePath -> [FilePath] -> IO [FilePath]+recurseDirectories _    []         = return []+recurseDirectories base (dir:dirs) = unsafeInterleaveIO $ do+  (files, dirs') <- collect [] [] =<< getDirectoryContents (base </> dir)++  files' <- recurseDirectories base (dirs' ++ dirs)+  return (dir : 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+          dirEntry' = FilePath.Native.addTrailingPathSeparator dirEntry+      isDirectory <- doesDirectoryExist (base </> dirEntry)+      if isDirectory+        then collect files (dirEntry':dirs') entries+        else collect (dirEntry:files) dirs' entries++    ignore ['.']      = True+    ignore ['.', '.'] = True+    ignore _          = False++getModTime :: FilePath -> IO EpochTime+getModTime path = do+  (TOD s _) <- getModificationTime path+  return $! fromIntegral s
+ cabal/cabal-install/Distribution/Client/Targets.hs view
@@ -0,0 +1,743 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Targets+-- Copyright   :  (c) Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified targets+-----------------------------------------------------------------------------+module Distribution.Client.Targets (+  -- * User targets+  UserTarget(..),+  readUserTargets,++  -- * Package specifiers+  PackageSpecifier(..),+  pkgSpecifierTarget,+  pkgSpecifierConstraints,++  -- * Resolving user targets to package specifiers+  resolveUserTargets,++  -- ** Detailed interface+  UserTargetProblem(..),+  readUserTarget,+  reportUserTargetProblems,+  expandUserTarget,++  PackageTarget(..),+  fetchPackageTarget,+  readPackageTarget,++  PackageTargetProblem(..),+  reportPackageTargetProblems,++  disambiguatePackageTargets,+  disambiguatePackageName,++  -- * User constraints+  UserConstraint(..),+  readUserConstraint,+  userToPackageConstraint++  ) where++import Distribution.Package+         ( Package(..), PackageName(..)+         , PackageIdentifier(..), packageName, packageVersion+         , Dependency(Dependency) )+import Distribution.Client.Types+         ( SourcePackage(..), PackageLocation(..) )+import Distribution.Client.Dependency.Types+         ( PackageConstraint(..) )++import qualified Distribution.Client.World as World+import Distribution.Client.PackageIndex (PackageIndex)+import qualified Distribution.Client.PackageIndex as PackageIndex+import qualified Distribution.Client.Tar as Tar+import Distribution.Client.FetchUtils++import Distribution.PackageDescription+         ( GenericPackageDescription, FlagName(..), FlagAssignment )+import Distribution.PackageDescription.Parse+         ( readPackageDescription, parsePackageDescription, ParseResult(..) )+import Distribution.Version+         ( Version(Version), thisVersion, anyVersion, isAnyVersion+         , VersionRange )+import Distribution.Text+         ( Text(..), display )+import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils+         ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )++import Data.List+         ( find, nub )+import Data.Maybe+         ( listToMaybe )+import Data.Either+         ( partitionEithers )+import Data.Monoid+         ( Monoid(..) )+import qualified Data.Map as Map+import qualified Data.ByteString.Lazy as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import qualified Distribution.Client.GZipUtils as GZipUtils+import Control.Monad (liftM)+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( (+++), (<++) )+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint+         ( (<>), (<+>) )+import Data.Char+         ( isSpace, isAlphaNum )+import System.FilePath+         ( takeExtension, dropExtension, takeDirectory, splitPath )+import System.Directory+         ( doesFileExist, doesDirectoryExist )+import Network.URI+         ( URI(..), URIAuth(..), parseAbsoluteURI )++-- ------------------------------------------------------------+-- * User targets+-- ------------------------------------------------------------++-- | Various ways that a user may specify a package or package collection.+--+data UserTarget =++     -- | A partially specified package, identified by name and possibly with+     -- an exact version or a version constraint.+     --+     -- > cabal install foo+     -- > cabal install foo-1.0+     -- > cabal install 'foo < 2'+     --+     UserTargetNamed Dependency++     -- | A special virtual package that refers to the collection of packages+     -- recorded in the world file that the user specifically installed.+     --+     -- > cabal install world+     --+   | UserTargetWorld++     -- | A specific package that is unpacked in a local directory, often the+     -- current directory.+     --+     -- > cabal install .+     -- > cabal install ../lib/other+     --+     -- * Note: in future, if multiple @.cabal@ files are allowed in a single+     -- directory then this will refer to the collection of packages.+     --+   | UserTargetLocalDir FilePath++     -- | A specific local unpacked package, identified by its @.cabal@ file.+     --+     -- > cabal install foo.cabal+     -- > cabal install ../lib/other/bar.cabal+     --+   | UserTargetLocalCabalFile FilePath++     -- | A specific package that is available as a local tarball file+     --+     -- > cabal install dist/foo-1.0.tar.gz+     -- > cabal install ../build/baz-1.0.tar.gz+     --+   | UserTargetLocalTarball FilePath++     -- | A specific package that is available as a remote tarball file+     --+     -- > cabal install http://code.haskell.org/~user/foo/foo-0.9.tar.gz+     --+   | UserTargetRemoteTarball URI+  deriving (Show,Eq)+++-- ------------------------------------------------------------+-- * Package specifier+-- ------------------------------------------------------------++-- | A fully or partially resolved reference to a package.+--+data PackageSpecifier pkg =++     -- | A partially specified reference to a package (either source or+     -- installed). It is specified by package name and optionally some+     -- additional constraints. Use a dependency resolver to pick a specific+     -- package satisfying these constraints.+     --+     NamedPackage PackageName [PackageConstraint]++     -- | A fully specified source package.+     --+   | SpecificSourcePackage pkg+  deriving Show+++pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName+pkgSpecifierTarget (NamedPackage name _)       = name+pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg++pkgSpecifierConstraints :: Package pkg+                        => PackageSpecifier pkg -> [PackageConstraint]+pkgSpecifierConstraints (NamedPackage _ constraints) = constraints+pkgSpecifierConstraints (SpecificSourcePackage pkg)  =+  [PackageConstraintVersion (packageName pkg)+                            (thisVersion (packageVersion pkg))]+++-- ------------------------------------------------------------+-- * Parsing and checking user targets+-- ------------------------------------------------------------++readUserTargets :: Verbosity -> [String] -> IO [UserTarget]+readUserTargets _verbosity targetStrs = do+    (problems, targets) <- liftM partitionEithers+                                 (mapM readUserTarget targetStrs)+    reportUserTargetProblems problems+    return targets+++data UserTargetProblem+   = UserTargetUnexpectedFile      String+   | UserTargetNonexistantFile     String+   | UserTargetUnexpectedUriScheme String+   | UserTargetUnrecognisedUri     String+   | UserTargetUnrecognised        String+   | UserTargetBadWorldPkg+  deriving Show++readUserTarget :: String -> IO (Either UserTargetProblem UserTarget)+readUserTarget targetstr =+    case testNamedTargets targetstr of+      Just (Dependency (PackageName "world") verrange)+        | verrange == anyVersion -> return (Right UserTargetWorld)+        | otherwise              -> return (Left  UserTargetBadWorldPkg)+      Just dep                   -> return (Right (UserTargetNamed dep))+      Nothing -> do+        fileTarget <- testFileTargets targetstr+        case fileTarget of+          Just target -> return target+          Nothing     ->+            case testUriTargets targetstr of+              Just target -> return target+              Nothing     -> return (Left (UserTargetUnrecognised targetstr))+  where+    testNamedTargets = readPToMaybe parseDependencyOrPackageId++    testFileTargets filename = do+      isDir  <- doesDirectoryExist filename+      isFile <- doesFileExist filename+      parentDirExists <- case takeDirectory filename of+                           []  -> return False+                           dir -> doesDirectoryExist dir+      let result+            | isDir+            = Just (Right (UserTargetLocalDir filename))++            | isFile && extensionIsTarGz filename+            = Just (Right (UserTargetLocalTarball filename))++            | isFile && takeExtension filename == ".cabal"+            = Just (Right (UserTargetLocalCabalFile filename))++            | isFile+            = Just (Left (UserTargetUnexpectedFile filename))++            | parentDirExists+            = Just (Left (UserTargetNonexistantFile filename))++            | otherwise+            = Nothing+      return result++    testUriTargets str =+      case parseAbsoluteURI str of+        Just uri@URI {+            uriScheme    = scheme,+            uriAuthority = Just URIAuth { uriRegName = host }+          }+          | scheme /= "http:" ->+            Just (Left (UserTargetUnexpectedUriScheme targetstr))++          | null host ->+            Just (Left (UserTargetUnrecognisedUri targetstr))++          | otherwise ->+            Just (Right (UserTargetRemoteTarball uri))+        _ -> Nothing++    extensionIsTarGz f = takeExtension f                 == ".gz"+                      && takeExtension (dropExtension f) == ".tar"++    parseDependencyOrPackageId :: Parse.ReadP r Dependency+    parseDependencyOrPackageId = parse+                             +++ liftM pkgidToDependency parse+      where+        pkgidToDependency :: PackageIdentifier -> Dependency+        pkgidToDependency p = case packageVersion p of+          Version [] _ -> Dependency (packageName p) anyVersion+          version      -> Dependency (packageName p) (thisVersion version)++readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                     , all isSpace s ]+++reportUserTargetProblems :: [UserTargetProblem] -> IO ()+reportUserTargetProblems problems = do+    case [ target | UserTargetUnrecognised target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "Unrecognised target '" ++ name ++ "'."+                  | name <- target ]+             ++ "Targets can be:\n"+             ++ " - package names, e.g. 'pkgname', 'pkgname-1.0.1', 'pkgname < 2.0'\n"+             ++ " - the special 'world' target\n"+             ++ " - cabal files 'pkgname.cabal' or package directories 'pkgname/'\n"+             ++ " - package tarballs 'pkgname.tar.gz' or 'http://example.com/pkgname.tar.gz'"++    case [ () | UserTargetBadWorldPkg <- problems ] of+      [] -> return ()+      _  -> die "The special 'world' target does not take any version."++    case [ target | UserTargetNonexistantFile target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "The file does not exist '" ++ name ++ "'."+                  | name <- target ]++    case [ target | UserTargetUnexpectedFile target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "Unrecognised file target '" ++ name ++ "'."+                  | name <- target ]+             ++ "File targets can be either package tarballs 'pkgname.tar.gz' "+             ++ "or cabal files 'pkgname.cabal'."++    case [ target | UserTargetUnexpectedUriScheme target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "URL target not supported '" ++ name ++ "'."+                  | name <- target ]+             ++ "Only 'http://' URLs are supported."++    case [ target | UserTargetUnrecognisedUri target <- problems ] of+      []     -> return ()+      target -> die+              $ unlines+                  [ "Unrecognise URL target '" ++ name ++ "'."+                  | name <- target ]+++-- ------------------------------------------------------------+-- * Resolving user targets to package specifiers+-- ------------------------------------------------------------++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to. They can either be specific packages (local dirs, tarballs etc)+-- or they can be named packages (with or without version info).+--+resolveUserTargets :: Package pkg+                   => Verbosity+                   -> FilePath+                   -> PackageIndex pkg+                   -> [UserTarget]+                   -> IO [PackageSpecifier SourcePackage]+resolveUserTargets verbosity worldFile available userTargets = do++    -- given the user targets, get a list of fully or partially resolved+    -- package references+    packageTargets <- mapM (readPackageTarget verbosity)+                  =<< mapM (fetchPackageTarget verbosity) . concat+                  =<< mapM (expandUserTarget worldFile) userTargets++    -- users are allowed to give package names case-insensitively, so we must+    -- disambiguate named package references+    let (problems, packageSpecifiers) =+           disambiguatePackageTargets available availableExtra packageTargets++        -- use any extra specific available packages to help us disambiguate+        availableExtra = [ packageName pkg+                         | PackageTargetLocation pkg <- packageTargets ]++    reportPackageTargetProblems verbosity problems++    return packageSpecifiers+++-- ------------------------------------------------------------+-- * Package targets+-- ------------------------------------------------------------++-- | An intermediate between a 'UserTarget' and a resolved 'PackageSpecifier'.+-- Unlike a 'UserTarget', a 'PackageTarget' refers only to a single package.+--+data PackageTarget pkg =+     PackageTargetNamed      PackageName [PackageConstraint] UserTarget++     -- | A package identified by name, but case insensitively, so it needs+     -- to be resolved to the right case-sensitive name.+   | PackageTargetNamedFuzzy PackageName [PackageConstraint] UserTarget+   | PackageTargetLocation pkg+  deriving Show+++-- ------------------------------------------------------------+-- * Converting user targets to package targets+-- ------------------------------------------------------------++-- | Given a user-specified target, expand it to a bunch of package targets+-- (each of which refers to only one package).+--+expandUserTarget :: FilePath+                 -> UserTarget+                 -> IO [PackageTarget (PackageLocation ())]+expandUserTarget worldFile userTarget = case userTarget of++    UserTargetNamed (Dependency name vrange) ->+      let constraints = [ PackageConstraintVersion name vrange+                        | not (isAnyVersion vrange) ]+      in  return [PackageTargetNamedFuzzy name constraints userTarget]++    UserTargetWorld -> do+      worldPkgs <- World.getContents worldFile+      --TODO: should we warn if there are no world targets?+      return [ PackageTargetNamed name constraints userTarget+             | World.WorldPkgInfo (Dependency name vrange) flags <- worldPkgs+             , let constraints = [ PackageConstraintVersion name vrange+                                 | not (isAnyVersion vrange) ]+                              ++ [ PackageConstraintFlags name flags+                                 | not (null flags) ] ]++    UserTargetLocalDir dir ->+      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++    UserTargetLocalCabalFile file -> do+      let dir = takeDirectory file+      _   <- findPackageDesc dir -- just as a check+      return [ PackageTargetLocation (LocalUnpackedPackage dir) ]++    UserTargetLocalTarball tarballFile ->+      return [ PackageTargetLocation (LocalTarballPackage tarballFile) ]++    UserTargetRemoteTarball tarballURL ->+      return [ PackageTargetLocation (RemoteTarballPackage tarballURL ()) ]+++-- ------------------------------------------------------------+-- * Fetching and reading package targets+-- ------------------------------------------------------------+++-- | Fetch any remote targets so that they can be read.+--+fetchPackageTarget :: Verbosity+                   -> PackageTarget (PackageLocation ())+                   -> IO (PackageTarget (PackageLocation FilePath))+fetchPackageTarget verbosity target = case target of+    PackageTargetNamed      n cs ut -> return (PackageTargetNamed      n cs ut)+    PackageTargetNamedFuzzy n cs ut -> return (PackageTargetNamedFuzzy n cs ut)+    PackageTargetLocation location  -> do+      location' <- fetchPackage verbosity (fmap (const Nothing) location)+      return (PackageTargetLocation location')+++-- | Given a package target that has been fetched, read the .cabal file.+--+-- This only affects targets given by location, named targets are unaffected.+--+readPackageTarget :: Verbosity+                  -> PackageTarget (PackageLocation FilePath)+                  -> IO (PackageTarget SourcePackage)+readPackageTarget verbosity target = case target of++    PackageTargetNamed pkgname constraints userTarget ->+      return (PackageTargetNamed pkgname constraints userTarget)++    PackageTargetNamedFuzzy pkgname constraints userTarget ->+      return (PackageTargetNamedFuzzy pkgname constraints userTarget)++    PackageTargetLocation location -> case location of++      LocalUnpackedPackage dir -> do+        pkg <- readPackageDescription verbosity =<< findPackageDesc dir+        return $ PackageTargetLocation $+                   SourcePackage {+                     packageInfoId      = packageId pkg,+                     packageDescription = pkg,+                     packageSource      = fmap Just location+                   }++      LocalTarballPackage tarballFile ->+        readTarballPackageTarget location tarballFile tarballFile++      RemoteTarballPackage tarballURL tarballFile ->+        readTarballPackageTarget location tarballFile (show tarballURL)++      RepoTarballPackage _repo _pkgid _ ->+        error "TODO: readPackageTarget RepoTarballPackage"+        -- For repo tarballs this info should be obtained from the index.++  where+    readTarballPackageTarget location tarballFile tarballOriginalLoc = do+      (filename, content) <- extractTarballPackageCabalFile+                               tarballFile tarballOriginalLoc+      case parsePackageDescription' content of+        Nothing  -> die $ "Could not parse the cabal file "+                       ++ filename ++ " in " ++ tarballFile+        Just pkg ->+          return $ PackageTargetLocation $+                     SourcePackage {+                       packageInfoId      = packageId pkg,+                       packageDescription = pkg,+                       packageSource      = fmap Just location+                     }++    extractTarballPackageCabalFile :: FilePath -> String+                                   -> IO (FilePath, BS.ByteString)+    extractTarballPackageCabalFile tarballFile tarballOriginalLoc =+          either (die . formatErr) return+        . check+        . Tar.entriesIndex+        . Tar.filterEntries isCabalFile+        . Tar.read+        . GZipUtils.maybeDecompress+      =<< BS.readFile tarballFile+      where+        formatErr msg = "Error reading " ++ tarballOriginalLoc ++ ": " ++ msg++        check (Left e)  = Left e+        check (Right m) = case Map.elems m of+            []     -> Left noCabalFile+            [file] -> case Tar.entryContent file of+              Tar.NormalFile content _ -> Right (Tar.entryPath file, content)+              _                        -> Left noCabalFile+            _files -> Left multipleCabalFiles+          where+            noCabalFile        = "No cabal file found"+            multipleCabalFiles = "Multiple cabal files found"++        isCabalFile e = case splitPath (Tar.entryPath e) of+          [     _dir, file] -> takeExtension file == ".cabal"+          [".", _dir, file] -> takeExtension file == ".cabal"+          _                 -> False++    parsePackageDescription' :: BS.ByteString -> Maybe GenericPackageDescription+    parsePackageDescription' content =+      case parsePackageDescription . fromUTF8 . BS.Char8.unpack $ content of+        ParseOk _ pkg -> Just pkg+        _             -> Nothing+++-- ------------------------------------------------------------+-- * Checking package targets+-- ------------------------------------------------------------++data PackageTargetProblem+   = PackageNameUnknown   PackageName               UserTarget+   | PackageNameAmbigious PackageName [PackageName] UserTarget+  deriving Show+++-- | Users are allowed to give package names case-insensitively, so we must+-- disambiguate named package references.+--+disambiguatePackageTargets :: Package pkg'+                           => PackageIndex pkg'+                           -> [PackageName]+                           -> [PackageTarget pkg]+                           -> ( [PackageTargetProblem]+                              , [PackageSpecifier pkg] )+disambiguatePackageTargets availablePkgIndex availableExtra targets =+    partitionEithers (map disambiguatePackageTarget targets)+  where+    disambiguatePackageTarget packageTarget = case packageTarget of+      PackageTargetLocation pkg -> Right (SpecificSourcePackage pkg)++      PackageTargetNamed pkgname constraints userTarget+        | null (PackageIndex.lookupPackageName availablePkgIndex pkgname)+                    -> Left (PackageNameUnknown pkgname userTarget)+        | otherwise -> Right (NamedPackage pkgname constraints)++      PackageTargetNamedFuzzy pkgname constraints userTarget ->+        case disambiguatePackageName packageNameEnv pkgname of+          None                 -> Left  (PackageNameUnknown+                                          pkgname userTarget)+          Ambiguous   pkgnames -> Left  (PackageNameAmbigious+                                          pkgname pkgnames userTarget)+          Unambiguous pkgname' -> Right (NamedPackage pkgname' constraints')+            where+              constraints' = map (renamePackageConstraint pkgname') constraints++    -- use any extra specific available packages to help us disambiguate+    packageNameEnv :: PackageNameEnv+    packageNameEnv = mappend (indexPackageNameEnv availablePkgIndex)+                             (extraPackageNameEnv availableExtra)+++-- | Report problems to the user. That is, if there are any problems+-- then raise an exception.+reportPackageTargetProblems :: Verbosity+                            -> [PackageTargetProblem] -> IO ()+reportPackageTargetProblems verbosity problems = do+    case [ pkg | PackageNameUnknown pkg originalTarget <- problems+               , not (isUserTagetWorld originalTarget) ] of+      []    -> return ()+      pkgs  -> die $ unlines+                       [ "There is no package named '" ++ display name ++ "'. "+                       | name <- pkgs ]+                  ++ "You may need to run 'hackport update' to get the latest "+                  ++ "list of available packages."++    case [ (pkg, matches) | PackageNameAmbigious pkg matches _ <- problems ] of+      []          -> return ()+      ambiguities -> die $ unlines+                             [    "The package name '" ++ display name+                               ++ "' is ambigious. It could be: "+                               ++ intercalate ", " (map display matches)+                             | (name, matches) <- ambiguities ]++    case [ pkg | PackageNameUnknown pkg UserTargetWorld <- problems ] of+      []   -> return ()+      pkgs -> warn verbosity $+                 "The following 'world' packages will be ignored because "+              ++ "they refer to packages that cannot be found: "+              ++ intercalate ", " (map display pkgs) ++ "\n"+              ++ "You can suppress this warning by correcting the world file."+  where+    isUserTagetWorld UserTargetWorld = True; isUserTagetWorld _ = False+++-- ------------------------------------------------------------+-- * Disambiguating package names+-- ------------------------------------------------------------++data MaybeAmbigious a = None | Unambiguous a | Ambiguous [a]++-- | Given a package name and a list of matching names, figure out which one it+-- might be referring to. If there is an exact case-sensitive match then that's+-- ok. If it matches just one package case-insensitively then that's also ok.+-- The only problem is if it matches multiple packages case-insensitively, in+-- that case it is ambigious.+--+disambiguatePackageName :: PackageNameEnv+                        -> PackageName+                        -> MaybeAmbigious PackageName+disambiguatePackageName (PackageNameEnv pkgNameLookup) name =+    case nub (pkgNameLookup name) of+      []      -> None+      [name'] -> Unambiguous name'+      names   -> case find (name==) names of+                   Just name' -> Unambiguous name'+                   Nothing    -> Ambiguous names+++newtype PackageNameEnv = PackageNameEnv (PackageName -> [PackageName])++instance Monoid PackageNameEnv where+  mempty = PackageNameEnv (const [])+  mappend (PackageNameEnv lookupA) (PackageNameEnv lookupB) =+    PackageNameEnv (\name -> lookupA name ++ lookupB name)++indexPackageNameEnv :: Package pkg => PackageIndex pkg -> PackageNameEnv+indexPackageNameEnv pkgIndex = PackageNameEnv pkgNameLookup+  where+    pkgNameLookup (PackageName name) =+      map fst (PackageIndex.searchByName pkgIndex name)++extraPackageNameEnv :: [PackageName] -> PackageNameEnv+extraPackageNameEnv names = PackageNameEnv pkgNameLookup+  where+    pkgNameLookup (PackageName name) =+      [ PackageName name'+      | let lname = lowercase name+      , PackageName name' <- names+      , lowercase name' == lname ]+++-- ------------------------------------------------------------+-- * Package constraints+-- ------------------------------------------------------------++data UserConstraint =+     UserConstraintVersion   PackageName VersionRange+   | UserConstraintInstalled PackageName+   | UserConstraintSource    PackageName+   | UserConstraintFlags     PackageName FlagAssignment+  deriving (Show,Eq)+++userToPackageConstraint :: UserConstraint -> PackageConstraint+-- At the moment, the types happen to be directly equivalent+userToPackageConstraint uc = case uc of+  UserConstraintVersion   name ver   -> PackageConstraintVersion    name ver+  UserConstraintInstalled name       -> PackageConstraintInstalled  name+  UserConstraintSource    name       -> PackageConstraintSource     name+  UserConstraintFlags     name flags -> PackageConstraintFlags      name flags++renamePackageConstraint :: PackageName -> PackageConstraint -> PackageConstraint+renamePackageConstraint name pc = case pc of+  PackageConstraintVersion   _ ver   -> PackageConstraintVersion    name ver+  PackageConstraintInstalled _       -> PackageConstraintInstalled  name+  PackageConstraintSource    _       -> PackageConstraintSource     name+  PackageConstraintFlags     _ flags -> PackageConstraintFlags      name flags++readUserConstraint :: String -> Either String UserConstraint+readUserConstraint str =+    case readPToMaybe parse str of+      Nothing -> Left msgCannotParse+      Just c  -> Right c+  where+    msgCannotParse =+         "expected a package name followed by a constraint, which is "+      ++ "either a version range, 'installed', 'source' or flags"++--FIXME: use Text instance for FlagName and FlagAssignment+instance Text UserConstraint where+  disp (UserConstraintVersion   pkgname verrange) = disp pkgname <+> disp verrange+  disp (UserConstraintInstalled pkgname)          = disp pkgname <+> Disp.text "installed"+  disp (UserConstraintSource    pkgname)          = disp pkgname <+> Disp.text "source"+  disp (UserConstraintFlags     pkgname flags)    = disp pkgname <+> dispFlagAssignment flags+    where+      dispFlagAssignment = Disp.hsep . map dispFlagValue+      dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f+      dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f+      dispFlagName (FlagName f) = Disp.text f++  parse = parse >>= parseConstraint+    where+      parseConstraint pkgname =+            (parse >>= return . UserConstraintVersion pkgname)+        +++ (do Parse.skipSpaces+                _ <- Parse.string "installed"+                return (UserConstraintInstalled pkgname))+        +++ (do Parse.skipSpaces+                _ <- Parse.string "source"+                return (UserConstraintSource pkgname))+        <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))++      parseFlagAssignment = Parse.many1 (Parse.skipSpaces >> parseFlagValue)+      parseFlagValue =+            (do Parse.optional (Parse.char '+')+                f <- parseFlagName+                return (f, True))+        +++ (do _ <- Parse.char '-'+                f <- parseFlagName+                return (f, False))+      parseFlagName = liftM FlagName ident++      ident :: Parse.ReadP r String+      ident = Parse.munch1 identChar >>= \s -> check s >> return s+        where+          identChar c   = isAlphaNum c || c == '_' || c == '-'+          check ('-':_) = Parse.pfail+          check _       = return ()
+ cabal/cabal-install/Distribution/Client/Types.hs view
@@ -0,0 +1,163 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Types+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Various common data types for the entire cabal-install system+-----------------------------------------------------------------------------+module Distribution.Client.Types where++import Distribution.Package+         ( PackageName, PackageId, Package(..), PackageFixedDeps(..) )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import Distribution.PackageDescription+         ( GenericPackageDescription, FlagAssignment )+import Distribution.Client.PackageIndex+         ( PackageIndex )+import Distribution.Version+         ( VersionRange )++import Data.Map (Map)+import Network.URI (URI)+import Distribution.Compat.ExceptionCI+         ( SomeException )++newtype Username = Username { unUsername :: String }+newtype Password = Password { unPassword :: String }++-- | This is the information we get from a @00-index.tar.gz@ hackage index.+--+data SourcePackageDb = SourcePackageDb {+  packageIndex       :: PackageIndex SourcePackage,+  packagePreferences :: Map PackageName VersionRange+}++-- ------------------------------------------------------------+-- * Various kinds of information about packages+-- ------------------------------------------------------------++-- | TODO: This is a hack to help us transition from Cabal-1.6 to 1.8.+-- What is new in 1.8 is that installed packages and dependencies between+-- installed packages are now identified by an opaque InstalledPackageId+-- rather than a source PackageId.+--+-- We should use simply an 'InstalledPackageInfo' here but to ease the+-- transition we are temporarily using this variant where we pretend that+-- installed packages still specify their deps in terms of PackageIds.+--+-- Crucially this means that 'InstalledPackage' can be an instance of+-- 'PackageFixedDeps' where as 'InstalledPackageInfo' is no longer an instance+-- of that class. This means we can make 'PackageIndex'es of InstalledPackage+-- where as the InstalledPackageInfo now has its own monomorphic index type.+--+data InstalledPackage = InstalledPackage+       InstalledPackageInfo+       [PackageId]++instance Package InstalledPackage where+  packageId (InstalledPackage pkg _) = packageId pkg+instance PackageFixedDeps InstalledPackage where+  depends (InstalledPackage _ deps) = deps++-- | A 'ConfiguredPackage' is a not-yet-installed package along with the+-- total configuration information. The configuration information is total in+-- the sense that it provides all the configuration information and so the+-- final configure process will be independent of the environment.+--+data ConfiguredPackage = ConfiguredPackage+       SourcePackage       -- package info, including repo+       FlagAssignment      -- complete flag assignment for the package+       [PackageId]         -- set of exact dependencies. These must be+                           -- consistent with the 'buildDepends' in the+                           -- 'PackageDescrption' that you'd get by applying+                           -- the flag assignment.+  deriving Show++instance Package ConfiguredPackage where+  packageId (ConfiguredPackage pkg _ _) = packageId pkg++instance PackageFixedDeps ConfiguredPackage where+  depends (ConfiguredPackage _ _ deps) = deps+++-- | A package description along with the location of the package sources.+--+data SourcePackage = SourcePackage {+    packageInfoId      :: PackageId,+    packageDescription :: GenericPackageDescription,+    packageSource      :: PackageLocation (Maybe FilePath)+  }+  deriving Show++instance Package SourcePackage where packageId = packageInfoId++-- ------------------------------------------------------------+-- * Package locations and repositories+-- ------------------------------------------------------------++data PackageLocation local =++    -- | An unpacked package in the given dir, or current dir+    LocalUnpackedPackage FilePath++    -- | A package as a tarball that's available as a local tarball+  | LocalTarballPackage FilePath++    -- | A package as a tarball from a remote URI+  | RemoteTarballPackage URI local++    -- | A package available as a tarball from a repository.+    --+    -- It may be from a local repository or from a remote repository, with a+    -- locally cached copy. ie a package available from hackage+  | RepoTarballPackage Repo PackageId local++--TODO:+--  * add support for darcs and other SCM style remote repos with a local cache+--  | ScmPackage+  deriving Show++instance Functor PackageLocation where+  fmap _ (LocalUnpackedPackage dir)      = LocalUnpackedPackage dir+  fmap _ (LocalTarballPackage  file)     = LocalTarballPackage  file+  fmap f (RemoteTarballPackage uri x)    = RemoteTarballPackage uri    (f x)+  fmap f (RepoTarballPackage repo pkg x) = RepoTarballPackage repo pkg (f x)+++data LocalRepo = LocalRepo+  deriving (Show,Eq)++data RemoteRepo = RemoteRepo {+    remoteRepoName :: String,+    remoteRepoURI  :: URI+  }+  deriving (Show,Eq)++data Repo = Repo {+    repoKind     :: Either RemoteRepo LocalRepo,+    repoLocalDir :: FilePath+  }+  deriving (Show,Eq)++-- ------------------------------------------------------------+-- * Build results+-- ------------------------------------------------------------++type BuildResult  = Either BuildFailure BuildSuccess+data BuildFailure = DependentFailed PackageId+                  | DownloadFailed  SomeException+                  | UnpackFailed    SomeException+                  | ConfigureFailed SomeException+                  | BuildFailed     SomeException+                  | InstallFailed   SomeException+data BuildSuccess = BuildOk         DocsResult TestsResult++data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk+data TestsResult = TestsNotTried | TestsFailed | TestsOk
+ cabal/cabal-install/Distribution/Client/Unpack.hs view
@@ -0,0 +1,123 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Unpack+-- Copyright   :  (c) Andrea Vezzosi 2008+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Unpack (++    -- * Commands+    unpack,++  ) where++import Distribution.Package+         ( PackageId, packageId )+import Distribution.Simple.Setup+         ( fromFlag, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( notice, die )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text(display)++import Distribution.Client.Setup+         ( GlobalFlags(..), UnpackFlags(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.FetchUtils+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)+import Distribution.Client.IndexUtils as IndexUtils+        ( getSourcePackages )++import System.Directory+         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )+import Control.Monad+         ( unless, when )+import Data.Monoid+         ( mempty )+import System.FilePath+         ( (</>), addTrailingPathSeparator )+++unpack :: Verbosity+       -> [Repo]+       -> GlobalFlags+       -> UnpackFlags+       -> [UserTarget] +       -> IO ()+unpack verbosity _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++unpack verbosity repos globalFlags unpackFlags userTargets = do+  mapM_ checkTarget userTargets++  sourcePkgDb   <- getSourcePackages verbosity repos++  pkgSpecifiers <- resolveUserTargets verbosity+                     (fromFlag $ globalWorldFile globalFlags)+                     (packageIndex sourcePkgDb)+                     userTargets++  pkgs <- either (die . unlines . map show) return $+            resolveWithoutDependencies+              (resolverParams sourcePkgDb pkgSpecifiers)++  unless (null prefix) $+         createDirectoryIfMissing True prefix++  flip mapM_ pkgs $ \pkg -> do+    location <- fetchPackage verbosity (packageSource pkg)+    let pkgid = packageId pkg+    case location of+      LocalTarballPackage tarballPath ->+        unpackPackage verbosity prefix pkgid tarballPath++      RemoteTarballPackage _tarballURL tarballPath ->+        unpackPackage verbosity prefix pkgid tarballPath++      RepoTarballPackage _repo _pkgid tarballPath ->+        unpackPackage verbosity prefix pkgid tarballPath++      LocalUnpackedPackage _ ->+        error "Distribution.Client.Unpack.unpack: the impossible happened."++  where+    resolverParams sourcePkgDb pkgSpecifiers =+        --TODO: add commandline constraint and preference args for unpack++        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers++    prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+    UserTargetLocalDir       dir  -> die (notTarball dir)+    UserTargetLocalCabalFile file -> die (notTarball file)+    _                             -> return ()+  where+    notTarball t =+        "The 'unpack' command is for tarball packages. "+     ++ "The target '" ++ t ++ "' is not a tarball."++unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO ()+unpackPackage verbosity prefix pkgid pkgPath = do+    let pkgdirname = display pkgid+        pkgdir     = prefix </> pkgdirname+        pkgdir'    = addTrailingPathSeparator pkgdir+    existsDir  <- doesDirectoryExist pkgdir+    when existsDir $ die $+     "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."+    existsFile  <- doesFileExist pkgdir+    when existsFile $ die $+     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."+    notice verbosity $ "Unpacking to " ++ pkgdir'+    Tar.extractTarGzFile prefix pkgdirname pkgPath
+ cabal/cabal-install/Distribution/Client/Update.hs view
@@ -0,0 +1,82 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Update+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+--+-----------------------------------------------------------------------------+module Distribution.Client.Update+    ( update+    ) where++import Distribution.Client.Types+         ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) )+import Distribution.Client.FetchUtils+         ( downloadIndex )+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.IndexUtils+         ( getSourcePackages )+import qualified Paths_cabal_install+         ( version )++import Distribution.Package+         ( PackageName(..), packageVersion )+import Distribution.Version+         ( anyVersion, withinRange )+import Distribution.Simple.Utils+         ( warn, notice, writeFileAtomic )+import Distribution.Verbosity+         ( Verbosity )++import qualified Data.ByteString.Lazy       as BS+import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Distribution.Client.GZipUtils (maybeDecompress)+import qualified Data.Map as Map+import System.FilePath (dropExtension)+import Data.Maybe      (fromMaybe)+import Control.Monad   (when)++-- | 'update' downloads the package list from all known servers+update :: Verbosity -> [Repo] -> IO ()+update verbosity [] = do+  warn verbosity $ "No remote package servers have been specified. Usually "+                ++ "you would have one specified in the config file."+update verbosity repos = do+  mapM_ (updateRepo verbosity) repos+  checkForSelfUpgrade verbosity repos++updateRepo :: Verbosity -> Repo -> IO ()+updateRepo verbosity repo = case repoKind repo of+  Right LocalRepo -> return ()+  Left remoteRepo -> do+    notice verbosity $ "Downloading the latest package list from "+                    ++ remoteRepoName remoteRepo+    indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)+    writeFileAtomic (dropExtension indexPath) . BS.Char8.unpack+                                              . maybeDecompress+                                            =<< BS.readFile indexPath++checkForSelfUpgrade :: Verbosity -> [Repo] -> IO ()+checkForSelfUpgrade verbosity repos = do+  SourcePackageDb sourcePkgIndex prefs <- getSourcePackages verbosity repos++  let self = PackageName "cabal-install"+      preferredVersionRange  = fromMaybe anyVersion (Map.lookup self prefs)+      currentVersion         = Paths_cabal_install.version+      laterPreferredVersions =+        [ packageVersion pkg+        | pkg <- PackageIndex.lookupPackageName sourcePkgIndex self+        , let version = packageVersion pkg+        , version > currentVersion+        , version `withinRange` preferredVersionRange ]++  when (not (null laterPreferredVersions)) $+    notice verbosity $+         "Note: there is a new version of cabal-install available.\n"+      ++ "To upgrade, run: cabal install cabal-install"+
+ cabal/cabal-install/Distribution/Client/Upload.hs view
@@ -0,0 +1,190 @@+-- This is a quick hack for uploading packages to Hackage.+-- See http://hackage.haskell.org/trac/hackage/wiki/CabalUpload++module Distribution.Client.Upload (check, upload, report) where++import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..))+import Distribution.Client.HttpUtils (proxy, isOldHackageURI)++import Distribution.Simple.Utils (debug, notice, warn, info)+import Distribution.Verbosity (Verbosity)+import Distribution.Text (display)+import Distribution.Client.Config++import qualified Distribution.Client.BuildReports.Anonymous as BuildReport+import qualified Distribution.Client.BuildReports.Upload as BuildReport++import Network.Browser+         ( BrowserAction, browse, request+         , Authority(..), addAuthority, setAuthorityGen+         , setOutHandler, setErrHandler, setProxy )+import Network.HTTP+         ( Header(..), HeaderName(..), findHeader+         , Request(..), RequestMethod(..), Response(..) )+import Network.TCP (HandleStream)+import Network.URI (URI(uriPath), parseURI)++import Data.Char        (intToDigit)+import Numeric          (showHex)+import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho+                        ,openBinaryFile, IOMode(ReadMode), hGetContents)+import Control.Exception (bracket)+import System.Random    (randomRIO)+import System.FilePath  ((</>), takeExtension, takeFileName)+import qualified System.FilePath.Posix as FilePath.Posix (combine)+import System.Directory+import Control.Monad (forM_)+++--FIXME: how do we find this path for an arbitrary hackage server?+-- is it always at some fixed location relative to the server root?+legacyUploadURI :: URI+Just legacyUploadURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/protected/upload-pkg"++checkURI :: URI+Just checkURI = parseURI "http://hackage.haskell.org/cgi-bin/hackage-scripts/check-pkg"+++upload :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> [FilePath] -> IO ()+upload verbosity repos mUsername mPassword paths = do+          let uploadURI = if isOldHackageURI targetRepoURI+                          then legacyUploadURI+                          else targetRepoURI{uriPath = uriPath targetRepoURI `FilePath.Posix.combine` "upload"}+          Username username <- maybe promptUsername return mUsername+          Password password <- maybe promptPassword return mPassword+          let auth = addAuthority AuthBasic {+                       auRealm    = "Hackage",+                       auUsername = username,+                       auPassword = password,+                       auSite     = uploadURI+                     }+          flip mapM_ paths $ \path -> do+            notice verbosity $ "Uploading " ++ path ++ "... "+            handlePackage verbosity uploadURI auth path+  where+    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given++promptUsername :: IO Username+promptUsername = do+  putStr "Hackage username: "+  hFlush stdout+  fmap Username getLine++promptPassword :: IO Password+promptPassword = do+  putStr "Hackage password: "+  hFlush stdout+  -- save/restore the terminal echoing status+  passwd <- bracket (hGetEcho stdin) (hSetEcho stdin) $ \_ -> do+    hSetEcho stdin False  -- no echoing for entering the password+    fmap Password getLine+  putStrLn ""+  return passwd++report :: Verbosity -> [Repo] -> Maybe Username -> Maybe Password -> IO ()+report verbosity repos mUsername mPassword = do+      let uploadURI = if isOldHackageURI targetRepoURI+                      then legacyUploadURI+                      else targetRepoURI{uriPath = ""}+      Username username <- maybe promptUsername return mUsername+      Password password <- maybe promptPassword return mPassword+      let auth = addAuthority AuthBasic {+                   auRealm    = "Hackage",+                   auUsername = username,+                   auPassword = password,+                   auSite     = uploadURI+                 }+      forM_ repos $ \repo -> case repoKind repo of+        Left remoteRepo+            -> do dotCabal <- defaultCabalDir+                  let srcDir = dotCabal </> "reports" </> remoteRepoName remoteRepo+                  contents <- getDirectoryContents srcDir+                  forM_ (filter (\c -> takeExtension c == ".log") contents) $ \logFile ->+                      do inp <- readFile (srcDir </> logFile)+                         let (reportStr, buildLog) = read inp :: (String,String)+                         case BuildReport.parse reportStr of+                           Left errs -> do warn verbosity $ "Errors: " ++ errs -- FIXME+                           Right report' ->+                               do info verbosity $ "Uploading report for " ++ display (BuildReport.package report')+                                  browse $ BuildReport.uploadReports (remoteRepoURI remoteRepo) [(report', Just buildLog)] auth+                                  return ()+        Right{} -> return ()+  where+    targetRepoURI = remoteRepoURI $ last [ remoteRepo | Left remoteRepo <- map repoKind repos ] --FIXME: better error message when no repos are given++check :: Verbosity -> [FilePath] -> IO ()+check verbosity paths = do+          flip mapM_ paths $ \path -> do+            notice verbosity $ "Checking " ++ path ++ "... "+            handlePackage verbosity checkURI (return ()) path++handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()+              -> FilePath -> IO ()+handlePackage verbosity uri auth path =+  do req <- mkRequest uri path+     p   <- proxy verbosity+     debug verbosity $ "\n" ++ show req+     (_,resp) <- browse $ do+                   setProxy p+                   setErrHandler (warn verbosity . ("http error: "++))+                   setOutHandler (debug verbosity)+                   auth+                   setAuthorityGen (\_ _ -> return Nothing)+                   request req+     debug verbosity $ show resp+     case rspCode resp of+       (2,0,0) -> do notice verbosity "Ok"+       (x,y,z) -> do notice verbosity $ "Error: " ++ path ++ ": "+                                     ++ map intToDigit [x,y,z] ++ " "+                                     ++ rspReason resp+                     case findHeader HdrContentType resp of+                       Just contenttype+                         | takeWhile (/= ';') contenttype == "text/plain"+                         -> notice verbosity $ rspBody resp+                       _ -> debug verbosity $ rspBody resp++mkRequest :: URI -> FilePath -> IO (Request String)+mkRequest uri path = +    do pkg <- readBinaryFile path+       boundary <- genBoundary+       let body = printMultiPart boundary (mkFormData path pkg)+       return $ Request {+                         rqURI = uri,+                         rqMethod = POST,+                         rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),+                                      Header HdrContentLength (show (length body)),+                                      Header HdrAccept ("text/plain")],+                         rqBody = body+                        }++readBinaryFile :: FilePath -> IO String+readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents++genBoundary :: IO String+genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer+                 return $ showHex i ""++mkFormData :: FilePath -> String -> [BodyPart]+mkFormData path pkg =+  -- yes, web browsers are that stupid (re quoting)+  [BodyPart [Header hdrContentDisposition $+             "form-data; name=package; filename=\""++takeFileName path++"\"",+             Header HdrContentType "application/x-gzip"]+   pkg]++hdrContentDisposition :: HeaderName+hdrContentDisposition = HdrCustom "Content-disposition"++-- * Multipart, partly stolen from the cgi package.++data BodyPart = BodyPart [Header] String++printMultiPart :: String -> [BodyPart] -> String+printMultiPart boundary xs = +    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf++printBodyPart :: String -> BodyPart -> String+printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c++crlf :: String+crlf = "\r\n"
+ cabal/cabal-install/Distribution/Client/Utils.hs view
@@ -0,0 +1,60 @@+module Distribution.Client.Utils where++import Data.List+         ( sortBy, groupBy )+import System.Directory+         ( doesFileExist, getModificationTime+         , getCurrentDirectory, setCurrentDirectory )+import qualified Control.Exception as Exception+         ( finally )++-- | Generic merging utility. For sorted input lists this is a full outer join.+--+-- * The result list never contains @(Nothing, Nothing)@.+--+mergeBy :: (a -> b -> Ordering) -> [a] -> [b] -> [MergeResult a b]+mergeBy cmp = merge+  where+    merge []     ys     = [ OnlyInRight y | y <- ys]+    merge xs     []     = [ OnlyInLeft  x | x <- xs]+    merge (x:xs) (y:ys) =+      case x `cmp` y of+        GT -> OnlyInRight   y : merge (x:xs) ys+        EQ -> InBoth      x y : merge xs     ys+        LT -> OnlyInLeft  x   : merge xs  (y:ys)++data MergeResult a b = OnlyInLeft a | InBoth a b | OnlyInRight b++duplicates :: Ord a => [a] -> [[a]]+duplicates = duplicatesBy compare++duplicatesBy :: (a -> a -> Ordering) -> [a] -> [[a]]+duplicatesBy cmp = filter moreThanOne . groupBy eq . sortBy cmp+  where+    eq a b = case cmp a b of+               EQ -> True+               _  -> False+    moreThanOne (_:_:_) = True+    moreThanOne _       = False++-- | 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)++-- | Executes the action in the specified directory.+inDir :: Maybe FilePath -> IO () -> IO ()+inDir Nothing m = m+inDir (Just d) m = do+  old <- getCurrentDirectory+  setCurrentDirectory d+  m `Exception.finally` setCurrentDirectory old
+ cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs view
@@ -0,0 +1,222 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Win32SelfUpgrade+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Support for self-upgrading executables on Windows platforms.+-----------------------------------------------------------------------------+module Distribution.Client.Win32SelfUpgrade (+-- * Explanation+--+-- | Windows inherited a design choice from DOS that while initially innocuous+-- has rather unfortunate consequences. It maintains the invariant that every+-- open file has a corresponding name on disk. One positive consequence of this+-- is that an executable can always find it's own executable file. The downside+-- is that a program cannot be deleted or upgraded while it is running without+-- hideous workarounds. This module implements one such hideous workaround.+--+-- The basic idea is:+--+-- * Move our own exe file to a new name+-- * Copy a new exe file to the previous name+-- * Run the new exe file, passing our own pid and new path+-- * Wait for the new process to start+-- * Close the new exe file+-- * Exit old process+--+-- Then in the new process:+--+-- * Inform the old process that we've started+-- * Wait for the old process to die+-- * Delete the old exe file+-- * Exit new process+--++    possibleSelfUpgrade,+    deleteOldExeFile,+  ) where++#if mingw32_HOST_OS || mingw32_TARGET_OS++import qualified System.Win32 as Win32+import qualified System.Win32.DLL as Win32+import System.Win32 (DWORD, BOOL, HANDLE, LPCTSTR)+import Foreign.Ptr (Ptr, nullPtr)+import System.Process (runProcess)+import System.Directory (canonicalizePath)+import System.FilePath (takeBaseName, replaceBaseName, equalFilePath)++import Distribution.Verbosity as Verbosity (Verbosity, showForCabal)+import Distribution.Simple.Utils (debug, info)++import Prelude hiding (log)++-- | If one of the given files is our own exe file then we arrange things such+-- that the nested action can replace our own exe file.+--+-- We require that the new process accepts a command line invocation that+-- calls 'deleteOldExeFile', passing in the pid and exe file.+--+possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade verbosity newPaths action = do+  dstPath <- canonicalizePath =<< Win32.getModuleFileName Win32.nullHANDLE++  newPaths' <- mapM canonicalizePath newPaths+  let doingSelfUpgrade = any (equalFilePath dstPath) newPaths'++  if not doingSelfUpgrade+    then action+    else do+      info verbosity $ "cabal-install does the replace-own-exe-file dance..."+      tmpPath <- moveOurExeOutOfTheWay verbosity+      result <- action+      scheduleOurDemise verbosity dstPath tmpPath+        (\pid path -> ["win32selfupgrade", pid, path+                      ,"--verbose=" ++ Verbosity.showForCabal verbosity])+      return result++-- | The name of a Win32 Event object that we use to synchronise between the+-- old and new processes. We need to synchronise to make sure that the old+-- process has not yet terminated by the time the new one starts up and looks+-- for the old process. Otherwise the old one might have already terminated+-- and we could not wait on it terminating reliably (eg the pid might get+-- re-used).+--+syncEventName :: String+syncEventName = "Local\\cabal-install-upgrade"++-- | The first part of allowing our exe file to be replaced is to move the+-- existing exe file out of the way. Although we cannot delete our exe file+-- while we're still running, fortunately we can rename it, at least within+-- the same directory.+--+moveOurExeOutOfTheWay :: Verbosity -> IO FilePath+moveOurExeOutOfTheWay verbosity = do+  ourPID  <-       getCurrentProcessId+  dstPath <- Win32.getModuleFileName Win32.nullHANDLE++  let tmpPath = replaceBaseName dstPath (takeBaseName dstPath ++ show ourPID)++  debug verbosity $ "moving " ++ dstPath ++ " to " ++ tmpPath+  Win32.moveFile dstPath tmpPath+  return tmpPath++-- | Assuming we've now installed the new exe file in the right place, we+-- launch it and ask it to delete our exe file when we eventually terminate.+--+scheduleOurDemise :: Verbosity -> FilePath -> FilePath+                  -> (String -> FilePath -> [String]) -> IO ()+scheduleOurDemise verbosity dstPath tmpPath mkArgs = do+  ourPID <- getCurrentProcessId+  event  <- createEvent syncEventName++  let args = mkArgs (show ourPID) tmpPath+  log $ "launching child " ++ unwords (dstPath : map show args)+  runProcess dstPath args Nothing Nothing Nothing Nothing Nothing++  log $ "waiting for the child to start up"+  waitForSingleObject event (10*1000) -- wait at most 10 sec+  log $ "child started ok"++  where+    log msg = debug verbosity ("Win32Reinstall.parent: " ++ msg)++-- | Assuming we're now in the new child process, we've been asked by the old+-- process to wait for it to terminate and then we can remove the old exe file+-- that it renamted itself to.+--+deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile verbosity oldPID tmpPath = do+  log $ "process started. Will delete exe file of process "+     ++ show oldPID ++ " at path " ++ tmpPath++  log $ "getting handle of parent process " ++ show oldPID+  oldPHANDLE <- Win32.openProcess Win32.sYNCHORNIZE False (fromIntegral oldPID)++  log $ "synchronising with parent"+  event <- openEvent syncEventName+  setEvent event++  log $ "waiting for parent process to terminate"+  waitForSingleObject oldPHANDLE Win32.iNFINITE+  log $ "parent process terminated"++  log $ "deleting parent's old .exe file"+  Win32.deleteFile tmpPath++  where+    log msg = debug verbosity ("Win32Reinstall.child: " ++ msg)++------------------------+-- Win32 foreign imports+--++-- A bunch of functions sadly not provided by the Win32 package.++foreign import stdcall unsafe "windows.h GetCurrentProcessId"+  getCurrentProcessId :: IO DWORD++foreign import stdcall unsafe "windows.h WaitForSingleObject"+  waitForSingleObject_ :: HANDLE -> DWORD -> IO DWORD++waitForSingleObject :: HANDLE -> DWORD -> IO ()+waitForSingleObject handle timeout =+  Win32.failIf_ bad "WaitForSingleObject" $+    waitForSingleObject_ handle timeout+  where+    bad result   = not (result == 0 || result == wAIT_TIMEOUT)+    wAIT_TIMEOUT = 0x00000102++foreign import stdcall unsafe "windows.h CreateEventW"+  createEvent_ :: Ptr () -> BOOL -> BOOL -> LPCTSTR -> IO HANDLE++createEvent :: String -> IO HANDLE+createEvent name = do+  Win32.failIfNull "CreateEvent" $+    Win32.withTString name $+      createEvent_ nullPtr False False++foreign import stdcall unsafe "windows.h OpenEventW"+  openEvent_ :: DWORD -> BOOL -> LPCTSTR -> IO HANDLE++openEvent :: String -> IO HANDLE+openEvent name = do+  Win32.failIfNull "OpenEvent" $+    Win32.withTString name $+      openEvent_ eVENT_MODIFY_STATE False+  where+    eVENT_MODIFY_STATE :: DWORD+    eVENT_MODIFY_STATE = 0x0002++foreign import stdcall unsafe "windows.h SetEvent"+  setEvent_ :: HANDLE -> IO BOOL++setEvent :: HANDLE -> IO ()+setEvent handle =+  Win32.failIfFalse_ "SetEvent" $+    setEvent_ handle++#else++import Distribution.Verbosity (Verbosity)+import Distribution.Simple.Utils (die)++possibleSelfUpgrade :: Verbosity+                    -> [FilePath]+                    -> IO a -> IO a+possibleSelfUpgrade _ _ action = action++deleteOldExeFile :: Verbosity -> Int -> FilePath -> IO ()+deleteOldExeFile _ _ _ = die "win32selfupgrade not needed except on win32"++#endif
+ cabal/cabal-install/Distribution/Client/World.hs view
@@ -0,0 +1,173 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.World+-- Copyright   :  (c) Peter Robinson 2009+-- License     :  BSD-like+--+-- Maintainer  :  thaldyron@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Interface to the world-file that contains a list of explicitly+-- requested packages. Meant to be imported qualified.+--+-- A world file entry stores the package-name, package-version, and+-- user flags.+-- For example, the entry generated by+-- # cabal install stm-io-hooks --flags="-debug"+-- looks like this:+-- # stm-io-hooks -any --flags="-debug"+-- To rebuild/upgrade the packages in world (e.g. when updating the compiler)+-- use+-- # cabal install world+--+-----------------------------------------------------------------------------+module Distribution.Client.World (+    WorldPkgInfo(..),+    insert,+    delete,+    getContents,+  ) where++import Distribution.Package+         ( Dependency(..) )+import Distribution.PackageDescription+         ( FlagAssignment, FlagName(FlagName) )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Simple.Utils+         ( die, info, chattyTry, writeFileAtomic )+import Distribution.Text+         ( Text(..), display, simpleParse )+import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ( (<>), (<+>) )+++import Data.Char as Char++import Data.List+         ( unionBy, deleteFirstsBy, nubBy )+import Data.Maybe+         ( isJust, fromJust )+import System.IO.Error+         ( isDoesNotExistError )+import qualified Data.ByteString.Lazy.Char8 as B+import Prelude hiding (getContents)+++data WorldPkgInfo = WorldPkgInfo Dependency FlagAssignment+  deriving (Show,Eq)++-- | Adds packages to the world file; creates the file if it doesn't+-- exist yet. Version constraints and flag assignments for a package are+-- updated if already present. IO errors are non-fatal.+insert :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+insert = modifyWorld $ unionBy equalUDep++-- | Removes packages from the world file.+-- Note: Currently unused as there is no mechanism in Cabal (yet) to+-- handle uninstalls. IO errors are non-fatal.+delete :: Verbosity -> FilePath -> [WorldPkgInfo] -> IO ()+delete = modifyWorld $ flip (deleteFirstsBy equalUDep)++-- | WorldPkgInfo values are considered equal if they refer to+-- the same package, i.e., we don't care about differing versions or flags.+equalUDep :: WorldPkgInfo -> WorldPkgInfo -> Bool+equalUDep (WorldPkgInfo (Dependency pkg1 _) _)+          (WorldPkgInfo (Dependency pkg2 _) _) = pkg1 == pkg2++-- | Modifies the world file by applying an update-function ('unionBy'+-- for 'insert', 'deleteFirstsBy' for 'delete') to the given list of+-- packages. IO errors are considered non-fatal.+modifyWorld :: ([WorldPkgInfo] -> [WorldPkgInfo]+                -> [WorldPkgInfo])+                        -- ^ Function that defines how+                        -- the list of user packages are merged with+                        -- existing world packages.+            -> Verbosity+            -> FilePath               -- ^ Location of the world file+            -> [WorldPkgInfo] -- ^ list of user supplied packages+            -> IO ()+modifyWorld _ _         _     []   = return ()+modifyWorld f verbosity world pkgs =+  chattyTry "Error while updating world-file. " $ do+    pkgsOldWorld <- getContents world+    -- Filter out packages that are not in the world file:+    let pkgsNewWorld = nubBy equalUDep $ f pkgs pkgsOldWorld+    -- 'Dependency' is not an Ord instance, so we need to check for+    -- equivalence the awkward way:+    if not (all (`elem` pkgsOldWorld) pkgsNewWorld &&+            all (`elem` pkgsNewWorld) pkgsOldWorld)+      then do+        info verbosity "Updating world file..."+        writeFileAtomic world $ unlines+            [ (display pkg) | pkg <- pkgsNewWorld]+      else+        info verbosity "World file is already up to date."+++-- | Returns the content of the world file as a list+getContents :: FilePath -> IO [WorldPkgInfo]+getContents world = do+  content <- safelyReadFile world+  let result = map simpleParse (lines $ B.unpack content)+  if all isJust result+    then return $ map fromJust result+    else die "Could not parse world file."+  where+  safelyReadFile :: FilePath -> IO B.ByteString+  safelyReadFile file = B.readFile file `catch` handler+    where+      handler e | isDoesNotExistError e = return B.empty+                | otherwise             = ioError e+++instance Text WorldPkgInfo where+  disp (WorldPkgInfo dep flags) = disp dep <+> dispFlags flags+    where+      dispFlags [] = Disp.empty+      dispFlags fs = Disp.text "--flags="+                  <> Disp.doubleQuotes (flagAssToDoc fs)+      flagAssToDoc = foldr (\(FlagName fname,val) flagAssDoc ->+                             (if not val then Disp.char '-'+                                         else Disp.empty)+                             Disp.<> Disp.text fname+                             Disp.<+> flagAssDoc)+                           Disp.empty+  parse = do+      dep <- parse+      Parse.skipSpaces+      flagAss <- Parse.option [] parseFlagAssignment+      return $ WorldPkgInfo dep flagAss+    where+      parseFlagAssignment :: Parse.ReadP r FlagAssignment+      parseFlagAssignment = do+          _ <- Parse.string "--flags"+          Parse.skipSpaces+          _ <- Parse.char '='+          Parse.skipSpaces+          inDoubleQuotes $ Parse.many1 flag+        where+          inDoubleQuotes :: Parse.ReadP r a -> Parse.ReadP r a+          inDoubleQuotes = Parse.between (Parse.char '"') (Parse.char '"')++          flag = do+            Parse.skipSpaces+            val <- negative Parse.+++ positive+            name <- ident+            Parse.skipSpaces+            return (FlagName name,val)+          negative = do+            _ <- Parse.char '-'+            return False+          positive = return True++          ident :: Parse.ReadP r String+          ident = do+            -- First character must be a letter/digit to avoid flags+            -- like "+-debug":+            c  <- Parse.satisfy Char.isAlphaNum+            cs <- Parse.munch (\ch -> Char.isAlphaNum ch || ch == '_'+                                                         || ch == '-')+            return (c:cs)
+ cabal/cabal-install/Distribution/Compat/ExceptionCI.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp #-}+-- #hide+module Distribution.Compat.ExceptionCI (+  SomeException,+  onException,+  catchIO,+  handleIO,+  catchExit,+  throwIOIO+  ) where++import System.Exit+import qualified Control.Exception as Exception+#if MIN_VERSION_base(4,0,0)+import Control.Exception (SomeException)+#else+import Control.Exception (Exception)+type SomeException = Exception+#endif++onException :: IO a -> IO b -> IO a+#if MIN_VERSION_base(4,0,0)+onException = Exception.onException+#else+onException io what = io `Exception.catch` \e -> do what+                                                    Exception.throw e+#endif++throwIOIO :: Exception.IOException -> IO a+#if MIN_VERSION_base(4,0,0)+throwIOIO = Exception.throwIO+#else+throwIOIO = Exception.throwIO . Exception.IOException+#endif++catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#if MIN_VERSION_base(4,0,0)+catchIO = Exception.catch+#else+catchIO = Exception.catchJust Exception.ioErrors+#endif++handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a+handleIO = flip catchIO++catchExit :: IO a -> (ExitCode -> IO a) -> IO a+#if MIN_VERSION_base(4,0,0)+catchExit = Exception.catch+#else+catchExit = Exception.catchJust exitExceptions+    where exitExceptions (Exception.ExitException ee) = Just ee+          exitExceptions _                            = Nothing+#endif
+ cabal/cabal-install/Distribution/Compat/FilePerms.hs view
@@ -0,0 +1,40 @@+{-# LANGUAGE CPP #-}+-- #hide+module Distribution.Compat.FilePerms (+  setFileOrdinary,+  setFileExecutable,+  ) where++#ifndef mingw32_HOST_OS+import System.Posix.Types+         ( FileMode )+import System.Posix.Internals+         ( c_chmod )+import Foreign.C+         ( withCString )+#if MIN_VERSION_base(4,0,0)+import Foreign.C+         ( throwErrnoPathIfMinus1_ )+#else+import Foreign.C+         ( throwErrnoIfMinus1_ )+#endif+#endif /* mingw32_HOST_OS */++setFileOrdinary,  setFileExecutable  :: 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 =+  withCString name $ \s -> do+#if __GLASGOW_HASKELL__ >= 608+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+    throwErrnoIfMinus1_                   name (c_chmod s m)+#endif+#else+setFileOrdinary   _ = return ()+setFileExecutable _ = return ()+#endif
+ cabal/cabal-install/LICENSE view
@@ -0,0 +1,34 @@+Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren,+                         Bjorn Bringert, Krasimir Angelov,+                         Malcolm Wallace, Ross Patterson,+                         Lemmih, Paolo Martini, Don Stewart,+                         Duncan Coutts+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/cabal-install/Main.hs view
@@ -0,0 +1,403 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Main+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- Entry point to the default cabal-install front-end.+-----------------------------------------------------------------------------++module Main (main) where++import Distribution.Client.Setup+         ( GlobalFlags(..), globalCommand, globalRepos+         , ConfigFlags(..)+         , ConfigExFlags(..), configureExCommand+         , InstallFlags(..), defaultInstallFlags+         , installCommand, upgradeCommand+         , FetchFlags(..), fetchCommand+         , checkCommand+         , updateCommand+         , ListFlags(..), listCommand+         , InfoFlags(..), infoCommand+         , UploadFlags(..), uploadCommand+         , ReportFlags(..), reportCommand+         , InitFlags, initCommand+         , reportCommand+         , unpackCommand, UnpackFlags(..) )+import Distribution.Simple.Setup+         ( BuildFlags(..), buildCommand+         , HaddockFlags(..), haddockCommand+         , HscolourFlags(..), hscolourCommand+         , CopyFlags(..), copyCommand+         , RegisterFlags(..), registerCommand+         , CleanFlags(..), cleanCommand+         , SDistFlags(..), sdistCommand+         , TestFlags(..), testCommand+         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe )++import Distribution.Client.SetupWrapper+         ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )+import Distribution.Client.Config+         ( SavedConfig(..), loadConfig, defaultConfigFile )+import Distribution.Client.Targets+         ( readUserTargets )++import Distribution.Client.List             (list, info)+import Distribution.Client.Install          (install, upgrade)+import Distribution.Client.Configure        (configure)+import Distribution.Client.Update           (update)+import Distribution.Client.Fetch            (fetch)+import Distribution.Client.Check as Check   (check)+--import Distribution.Client.Clean            (clean)+import Distribution.Client.Upload as Upload (upload, check, report)+import Distribution.Client.SrcDist          (sdist)+import Distribution.Client.Unpack           (unpack)+import Distribution.Client.Init             (initCabal)+import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade++import Distribution.Simple.Compiler+         ( Compiler, PackageDB(..), PackageDBStack )+import Distribution.Simple.Program+         ( ProgramConfiguration, defaultProgramConfiguration )+import Distribution.Simple.Command+import Distribution.Simple.Configure (configCompilerAux)+import Distribution.Simple.Utils+         ( cabalVersion, die, topHandler, intercalate )+import Distribution.Text+         ( display )+import Distribution.Verbosity as Verbosity+       ( Verbosity, normal, intToVerbosity, lessVerbose )+import qualified Paths_cabal_install (version)++import System.Environment       (getArgs, getProgName)+import System.Exit              (exitFailure)+import System.FilePath          (splitExtension, takeExtension)+import System.Directory         (doesFileExist)+import Data.List                (intersperse)+import Data.Maybe               (fromMaybe)+import Data.Monoid              (Monoid(..))+import Control.Monad            (unless)++-- | Entry point+--+main :: IO ()+main = getArgs >>= mainWorker++mainWorker :: [String] -> IO ()+mainWorker ("win32selfupgrade":args) = win32SelfUpgradeAction args+mainWorker args = topHandler $+  case commandsRun globalCommand commands args of+    CommandHelp   help                 -> printGlobalHelp help+    CommandList   opts                 -> printOptionsList opts+    CommandErrors errs                 -> printErrors errs+    CommandReadyToGo (globalflags, commandParse)  ->+      case commandParse of+        _ | fromFlag (globalVersion globalflags)        -> printVersion+          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion+        CommandHelp     help           -> printCommandHelp help+        CommandList     opts           -> printOptionsList opts+        CommandErrors   errs           -> printErrors errs+        CommandReadyToGo action        -> action globalflags++  where+    printCommandHelp help = do+      pname <- getProgName+      putStr (help pname)+    printGlobalHelp help = do+      pname <- getProgName+      configFile <- defaultConfigFile+      putStr (help pname)+      putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"+            ++ "  " ++ configFile ++ "\n"+    printOptionsList = putStr . unlines+    printErrors errs = die $ concat (intersperse "\n" errs)+    printNumericVersion = putStrLn $ display Paths_cabal_install.version+    printVersion        = putStrLn $ "cabal-install version "+                                  ++ display Paths_cabal_install.version+                                  ++ "\nusing version "+                                  ++ display cabalVersion+                                  ++ " of the Cabal library "++    commands =+      [installCommand         `commandAddAction` installAction+      ,updateCommand          `commandAddAction` updateAction+      ,listCommand            `commandAddAction` listAction+      ,infoCommand            `commandAddAction` infoAction+      ,fetchCommand           `commandAddAction` fetchAction+      ,unpackCommand          `commandAddAction` unpackAction+      ,checkCommand           `commandAddAction` checkAction+      ,sdistCommand           `commandAddAction` sdistAction+      ,uploadCommand          `commandAddAction` uploadAction+      ,reportCommand          `commandAddAction` reportAction+      ,initCommand            `commandAddAction` initAction+      ,configureExCommand     `commandAddAction` configureAction+      ,wrapperAction (buildCommand defaultProgramConfiguration)+                     buildVerbosity    buildDistPref+      ,wrapperAction copyCommand+                     copyVerbosity     copyDistPref+      ,wrapperAction haddockCommand+                     haddockVerbosity  haddockDistPref+      ,wrapperAction cleanCommand+                     cleanVerbosity    cleanDistPref+      ,wrapperAction hscolourCommand+                     hscolourVerbosity hscolourDistPref+      ,wrapperAction registerCommand+                     regVerbosity      regDistPref+      ,wrapperAction testCommand+                     testVerbosity     testDistPref+      ,upgradeCommand         `commandAddAction` upgradeAction+      ]++wrapperAction :: Monoid flags+              => CommandUI flags+              -> (flags -> Flag Verbosity)+              -> (flags -> Flag String)+              -> Command (GlobalFlags -> IO ())+wrapperAction command verbosityFlag distPrefFlag =+  commandAddAction command+    { commandDefaultFlags = mempty } $ \flags extraArgs _globalFlags -> do+    let verbosity = fromFlagOrDefault normal (verbosityFlag flags)+        setupScriptOptions = defaultSetupScriptOptions {+          useDistPref = fromFlagOrDefault+                          (useDistPref defaultSetupScriptOptions)+                          (distPrefFlag flags)+        }+    setupWrapper verbosity setupScriptOptions Nothing+                 command (const flags) extraArgs++configureAction :: (ConfigFlags, ConfigExFlags)+                -> [String] -> GlobalFlags -> IO ()+configureAction (configFlags, configExFlags) extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags'+  configure verbosity+            (configPackageDB' configFlags') (globalRepos globalFlags')+            comp conf configFlags' configExFlags' extraArgs++installAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+              -> [String] -> GlobalFlags -> IO ()+installAction (configFlags, _, installFlags) _ _globalFlags+  | fromFlagOrDefault False (installOnly installFlags)+  = let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+    in setupWrapper verbosity defaultSetupScriptOptions Nothing+         installCommand (const mempty) []++installAction (configFlags, configExFlags, installFlags)+              extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      installFlags'  = defaultInstallFlags          `mappend`+                       savedInstallFlags     config `mappend` installFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags'+  install verbosity+          (configPackageDB' configFlags') (globalRepos globalFlags')+          comp conf globalFlags' configFlags' configExFlags' installFlags'+          targets++listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()+listAction listFlags extraArgs globalFlags = do+  let verbosity = fromFlag (listVerbosity listFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags+  list verbosity+       (configPackageDB' configFlags)+       (globalRepos globalFlags')+       comp+       conf+       listFlags+       extraArgs++infoAction :: InfoFlags -> [String] -> GlobalFlags -> IO ()+infoAction infoFlags extraArgs globalFlags = do+  let verbosity = fromFlag (infoVerbosity infoFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags    config `mappend` globalFlags+  (comp, conf) <- configCompilerAux configFlags+  info verbosity+       (configPackageDB' configFlags)+       (globalRepos globalFlags')+       comp+       conf+       globalFlags'+       infoFlags+       targets++updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+updateAction verbosityFlag extraArgs globalFlags = do+  unless (null extraArgs) $ do+    die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs+  let verbosity = fromFlag verbosityFlag+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  update verbosity (globalRepos globalFlags')++upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags)+              -> [String] -> GlobalFlags -> IO ()+upgradeAction (configFlags, configExFlags, installFlags)+              extraArgs globalFlags = do+  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags)+                                 (configUserInstall configFlags)+  let configFlags'   = savedConfigureFlags   config `mappend` configFlags+      configExFlags' = savedConfigureExFlags config `mappend` configExFlags+      installFlags'  = defaultInstallFlags          `mappend`+                       savedInstallFlags     config `mappend` installFlags+      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags'+  upgrade verbosity+          (configPackageDB' configFlags') (globalRepos globalFlags')+          comp conf globalFlags' configFlags' configExFlags' installFlags'+          targets++fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO ()+fetchAction fetchFlags extraArgs globalFlags = do+  let verbosity = fromFlag (fetchVerbosity fetchFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, conf) <- configCompilerAux' configFlags+  fetch verbosity+        (configPackageDB' configFlags) (globalRepos globalFlags')+        comp conf globalFlags' fetchFlags+        targets++uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO ()+uploadAction uploadFlags extraArgs globalFlags = do+  let verbosity = fromFlag (uploadVerbosity uploadFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let uploadFlags' = savedUploadFlags config `mappend` uploadFlags+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+      tarfiles     = extraArgs+  checkTarFiles extraArgs+  if fromFlag (uploadCheck uploadFlags')+    then Upload.check  verbosity tarfiles+    else upload verbosity+                (globalRepos globalFlags')+                (flagToMaybe $ uploadUsername uploadFlags')+                (flagToMaybe $ uploadPassword uploadFlags')+                tarfiles+  where+    checkTarFiles tarfiles+      | null tarfiles+      = die "the 'upload' command expects one or more .tar.gz packages."+      | not (null otherFiles)+      = die $ "the 'upload' command expects only .tar.gz packages: "+           ++ intercalate ", " otherFiles+      | otherwise = sequence_+                      [ do exists <- doesFileExist tarfile+                           unless exists $ die $ "file not found: " ++ tarfile+                      | tarfile <- tarfiles ]++      where otherFiles = filter (not . isTarGzFile) tarfiles+            isTarGzFile file = case splitExtension file of+              (file', ".gz") -> takeExtension file' == ".tar"+              _              -> False++checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO ()+checkAction verbosityFlag extraArgs _globalFlags = do+  unless (null extraArgs) $ do+    die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs+  allOk <- Check.check (fromFlag verbosityFlag)+  unless allOk exitFailure+++sdistAction :: SDistFlags -> [String] -> GlobalFlags -> IO ()+sdistAction sflags extraArgs _globalFlags = do+  unless (null extraArgs) $ do+    die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs+  sdist sflags++reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO ()+reportAction reportFlags extraArgs globalFlags = do+  unless (null extraArgs) $ do+    die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs++  let verbosity = fromFlag (reportVerbosity reportFlags)+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+      reportFlags' = savedReportFlags config `mappend` reportFlags++  Upload.report verbosity (globalRepos globalFlags')+    (flagToMaybe $ reportUsername reportFlags')+    (flagToMaybe $ reportPassword reportFlags')++unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()+unpackAction unpackFlags extraArgs globalFlags = do+  let verbosity = fromFlag (unpackVerbosity unpackFlags)+  targets <- readUserTargets verbosity extraArgs+  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  let globalFlags' = savedGlobalFlags config `mappend` globalFlags+  unpack verbosity+         (globalRepos (savedGlobalFlags config))+         globalFlags'+         unpackFlags+         targets++initAction :: InitFlags -> [String] -> GlobalFlags -> IO ()+initAction flags _extraArgs _globalFlags = do+  initCabal flags++-- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details.+--+win32SelfUpgradeAction :: [String] -> IO ()+win32SelfUpgradeAction (pid:path:rest) =+  Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path+  where+    verbosity = case rest of+      (['-','-','v','e','r','b','o','s','e','=',n]:_) | n `elem` ['0'..'9']+         -> fromMaybe Verbosity.normal (Verbosity.intToVerbosity (read [n]))+      _  ->           Verbosity.normal+win32SelfUpgradeAction _ = return ()++--+-- Utils (transitionary)+--++-- | Currently the user interface specifies the package dbs to use with just a+-- single valued option, a 'PackageDB'. However internally we represent the+-- stack of 'PackageDB's explictly as a list. This function converts encodes+-- the package db stack implicit in a single packagedb.+--+-- TODO: sort this out, make it consistent with the command line UI+implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack+implicitPackageDbStack userInstall packageDbFlag+  | userInstall = GlobalPackageDB : UserPackageDB : extra+  | otherwise   = GlobalPackageDB : extra+  where+    extra = case packageDbFlag of+      Just (SpecificPackageDB db) -> [SpecificPackageDB db]+      _                           -> []++configPackageDB' :: ConfigFlags -> PackageDBStack+configPackageDB' cfg =+  implicitPackageDbStack userInstall (flagToMaybe (configPackageDB cfg))+  where+    userInstall = fromFlagOrDefault True (configUserInstall cfg)++configCompilerAux' :: ConfigFlags+                   -> IO (Compiler, ProgramConfiguration)+configCompilerAux' configFlags =+  configCompilerAux configFlags+    --FIXME: make configCompilerAux use a sensible verbosity+    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
+ cabal/cabal-install/Paths_cabal_install.hs view
@@ -0,0 +1,8 @@+module Paths_cabal_install (+    version,+  ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [0,12,0], versionTags = []}
+ cabal/cabal-install/README view
@@ -0,0 +1,153 @@+The cabal-install package+=========================++[Cabal home page](http://www.haskell.org/cabal/)++The `cabal-install` package provides a command line tool called `cabal`. The+tool uses the `Cabal` library and provides a convenient user interface to the+Cabal/Hackage package build and distribution system. It can build and install+both local and remote packages, including dependencies.+++Installation instructions for the cabal-install command line tool+=================================================================++The `cabal-install` package requires a number of other packages, most of which+come with a standard ghc installation. It requires the `network` package, which+is sometimes packaged separately by Linux distributions, for example on+debian or ubuntu it is in "libghc6-network-dev".++It requires a few other Haskell packages that are not always installed:++ * Cabal  (version 1.10 or later)+ * HTTP   (version 4000 or later)+ * zlib   (version 0.4  or later)++All of these are available from [Hackage](http://hackage.haskell.org).++Note that on some Unix systems you may need to install an additional zlib+development package using your system package manager, for example on+debian or ubuntu it is in "zlib1g-dev". It is needed is because the+Haskell zlib package uses the system zlib C library and header files.++The `cabal-install` package is now part of the Haskell Platform so you do not+usually need to install it separately. However if you are starting from a+minimal ghc installation then you need to install `cabal-install` manually.+Since it is just an ordinary Cabal package it can be built in the standard+way, but to make it a bit easier we have partly automated the process:+++Quickstart on Unix systems+--------------------------++As a convenience for users on Unix systems there is a `bootstrap.sh` script+which will download and install each of the dependencies in turn.++    $ ./bootstrap.sh++It will download and install the above three dependencies. The script will+install the library packages into `$HOME/.cabal/` and the `cabal` program will+be installed into `$HOME/.cabal/bin/`.++You then have two choices:++ * put `$HOME/.cabal/bin` on your `$PATH`+ * move the `cabal` program somewhere that is on your `$PATH`++The next thing to do is to get the latest list of packages with:++    $ cabal update++This will also create a default config file (if it does not already echo exist)+at `$HOME/.cabal/config`++By default cabal will install programs to `$HOME/.cabal/bin`. If you do not+want to add this directory to your `$PATH` then you can change the setting in+the config file, for example you could use:++    symlink-bindir: $HOME/bin+++Quickstart on Windows systems+-----------------------------++For Windows users we provide a pre-compiled [cabal.exe] program. Just download+it and put it somewhere on your `%PATH%`, for example+`C:\Program Files\Haskell\bin`.++[cabal.exe]: http://haskell.org/cabal/release/cabal-install-latest/cabal.exe++The next thing to do is to get the latest list of packages with++    cabal update++This will also create a default config file (if it does not already echo exist)+at `C:\Documents and Settings\username\Application Data\cabal\config`+++Using cabal-install+===================++There are two sets of commands: commands for working with a local project build+tree and ones for working with distributed released packages from hackage.++For a list of the full set of commands and the flags for each command see++    $ cabal --help+++Commands for developers for local build trees+---------------------------------------------++The commands for local project build trees are almost exactly the same as the+`runghc Setup` command line interface that many people are already familiar+with. In particular there are the commands++    cabal configure+    cabal build+    cabal haddock+    cabal clean+    cabal sdist++The `install` command is somewhat different. It is an all-in-one operation. If+you run++    $ cabal install++in your build tree it will configure, build and install. It takes all the flags+that `configure` takes such as `--global` and `--prefix`.++In addition, if any dependencies are not installed it will download and install+them. If can also rebuild packages to ensure a consistent set of dependencies.+++Commands for released hackage packages+--------------------------------------++    $ cabal update++This command gets the latest list of packages from the hackage server.+Currently this command has to be run manually occasionally, in particular if+you want to install a newly released package. +++    $ cabal install xmonad++This is the eponymous command. It installs one or more named packages (and all+their dependencies) from hackage.++By default it installs the latest available version however you can optionally+specify exact versions or version ranges. For example `cabal install alex-2.2`+or `cabal install parsec < 3`.++    $ cabal upgrade xmonad++This is a variation on the `install` command. Both mean to install the latest+version, the only difference is in the treatment of dependencies. The `install`+command tries to use existing installed versions of dependent packages while+the `upgrade` command tries to upgrade all the dependencies too.++    $ cabal list xml++This does a search of the installed and available packages. It does a+case-insensitive substring match on the package name.
+ cabal/cabal-install/Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal-install/bash-completion/cabal view
@@ -0,0 +1,24 @@+# cabal command line completion+# Copyright 2007-2008 "Lennart Kolmodin" <kolmodin@gentoo.org>+#                     "Duncan Coutts"     <dcoutts@gentoo.org>+#++_cabal()+{+    # get the word currently being completed+    local cur+    cur=${COMP_WORDS[$COMP_CWORD]}++    # create a command line to run+    local cmd+    # copy all words the user has entered+    cmd=( ${COMP_WORDS[@]} )++    # replace the current word with --list-options+    cmd[${COMP_CWORD}]="--list-options"++    # the resulting completions should be put into this array+    COMPREPLY=( $( compgen -W "$( ${cmd[@]} )" -- $cur ) )+}++complete -F _cabal -o default cabal
+ cabal/cabal-install/bootstrap.sh view
@@ -0,0 +1,231 @@+#!/bin/sh++# A script to bootstrap cabal-install.++# It works by downloading and installing the Cabal, zlib and+# HTTP packages. It then installs cabal-install itself.+# It expects to be run inside the cabal-install directory.++# install settings, you can override these by setting environment vars+PREFIX=${PREFIX:-${HOME}/.cabal}+#VERBOSE+#EXTRA_CONFIGURE_OPTS++# programs, you can override these by setting environment vars+GHC=${GHC:-ghc}+GHC_PKG=${GHC_PKG:-ghc-pkg}+WGET=${WGET:-wget}+CURL=${CURL:-curl}+FETCH=${FETCH:-fetch}+TAR=${TAR:-tar}+GUNZIP=${GUNZIP:-gunzip}+SCOPE_OF_INSTALLATION="--user"+++for arg in $*+do+  case "${arg}" in+    "--user")+      SCOPE_OF_INSTALLATION=${arg}+      shift;;+    "--global")+      SCOPE_OF_INSTALLATION=${arg}+      PREFIX="/usr/local"+      shift;;+    *)+      echo "Unknown argument or option, quitting: ${arg}"+      echo "usage: bootstrap.sh [OPTION]"+      echo+      echo "options:"+      echo "   --user    Install for the local user (default)"+      echo "   --global  Install systemwide (must be run as root)"+      exit;;+  esac+done+++# Versions of the packages to install.+# The version regex says what existing installed versions are ok.+PARSEC_VER="3.1.1";    PARSEC_VER_REGEXP="[23]\."  # == 2.* || == 3.*+NETWORK_VER="2.3.0.2"; NETWORK_VER_REGEXP="2\."    # == 2.*+CABAL_VER="1.10.1.0";  CABAL_VER_REGEXP="1\.10\.[^0]"  # == 1.10.* && >= 1.10.1+TRANS_VER="0.2.2.0";   TRANS_VER_REGEXP="0\.2\."   # == 0.2.*+MTL_VER="2.0.1.0";     MTL_VER_REGEXP="[12]\."     # == 1.* || == 2.*+HTTP_VER="4000.1.1";   HTTP_VER_REGEXP="4000\.[01]\." # == 4000.0.* || 4000.1.*+ZLIB_VER="0.5.3.1";    ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || ==0.5.*+TIME_VER="1.2.0.4"     TIME_VER_REGEXP="1\.[12]\." # == 0.1.* || ==0.2.*++HACKAGE_URL="http://hackage.haskell.org/packages/archive"++die () {+  echo+  echo "Error during cabal-install bootstrap:"+  echo $1 >&2+  exit 2+}++# Check we're in the right directory:+grep "cabal-install" ./cabal-install.cabal > /dev/null 2>&1 \+  || die "The bootstrap.sh script must be run in the cabal-install directory"++${GHC} --numeric-version > /dev/null \+  || die "${GHC} not found (or could not be run). If ghc is installed make sure it is on your PATH or set the GHC and GHC_PKG vars."+${GHC_PKG} --version     > /dev/null \+  || die "${GHC_PKG} not found."+GHC_VER=`${GHC} --numeric-version`+GHC_PKG_VER=`${GHC_PKG} --version | cut -d' ' -f 5`+[ ${GHC_VER} = ${GHC_PKG_VER} ] \+  || die "Version mismatch between ${GHC} and ${GHC_PKG} If you set the GHC variable then set GHC_PKG too"++# Cache the list of packages:+echo "Checking installed packages for ghc-${GHC_VER}..."+${GHC_PKG} list --global ${SCOPE_OF_INSTALLATION} > ghc-pkg.list \+  || die "running '${GHC_PKG} list' failed"++# Will we need to install this package, or is a suitable version installed?+need_pkg () {+  PKG=$1+  VER_MATCH=$2+  if grep " ${PKG}-${VER_MATCH}" ghc-pkg.list > /dev/null 2>&1+  then+    return 1;+  else+    return 0;+  fi+  #Note: we cannot use "! grep" here as Solaris 9 /bin/sh doesn't like it.+}++info_pkg () {+  PKG=$1+  VER=$2+  VER_MATCH=$3++  if need_pkg ${PKG} ${VER_MATCH}+  then+    echo "${PKG}-${VER} will be downloaded and installed."+  else+    echo "${PKG} is already installed and the version is ok."+  fi+}++fetch_pkg () {+  PKG=$1+  VER=$2++  URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz+  if which ${CURL} > /dev/null+  then+    ${CURL} --fail -C - -O ${URL} || die "Failed to download ${PKG}."+  elif which ${WGET} > /dev/null+  then+    ${WGET} -c ${URL} || die "Failed to download ${PKG}."+  elif which ${FETCH} > /dev/null+ 	then+ 	  ${FETCH} ${URL} || die "Failed to download ${PKG}."+  else+    die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."+  fi+  [ -f "${PKG}-${VER}.tar.gz" ] \+    || die "Downloading ${URL} did not create ${PKG}-${VER}.tar.gz"+}++unpack_pkg () {+  PKG=$1+  VER=$2++  rm -rf "${PKG}-${VER}.tar" "${PKG}-${VER}"/+  ${GUNZIP} -f "${PKG}-${VER}.tar.gz" \+    || die "Failed to gunzip ${PKG}-${VER}.tar.gz"+  ${TAR} -xf "${PKG}-${VER}.tar" \+    || die "Failed to untar ${PKG}-${VER}.tar.gz"+  [ -d "${PKG}-${VER}" ] \+    || die "Unpacking ${PKG}-${VER}.tar.gz did not create ${PKG}-${VER}/"+}++install_pkg () {+  PKG=$1++  [ -x Setup ] && ./Setup clean+  [ -f Setup ] && rm Setup++  ${GHC} --make Setup -o Setup \+    || die "Compiling the Setup script failed"+  [ -x Setup ] || die "The Setup script does not exist or cannot be run"++  ./Setup configure ${SCOPE_OF_INSTALLATION} "--prefix=${PREFIX}" \+    --with-compiler=${GHC} --with-hc-pkg=${GHC_PKG} \+    ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \+    || die "Configuring the ${PKG} package failed"++  ./Setup build ${VERBOSE} \+    || die "Building the ${PKG} package failed"++  ./Setup install ${VERBOSE} \+    || die "Installing the ${PKG} package failed"+}++do_pkg () {+  PKG=$1+  VER=$2+  VER_MATCH=$3++  if need_pkg ${PKG} ${VER_MATCH}+  then+    echo+    echo "Downloading ${PKG}-${VER}..."+    fetch_pkg ${PKG} ${VER}+    unpack_pkg ${PKG} ${VER}+    cd "${PKG}-${VER}"+    install_pkg ${PKG} ${VER}+    cd ..+  fi+}++# Actually do something!++info_pkg "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP}+info_pkg "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP}+info_pkg "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}+info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP}+info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}+info_pkg "time"         ${TIME_VER}    ${TIME_VER_REGEXP}+info_pkg "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP}+info_pkg "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP}++do_pkg   "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP}+do_pkg   "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP}+do_pkg   "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}+do_pkg   "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP}+do_pkg   "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}+do_pkg   "time"         ${TIME_VER}    ${TIME_VER_REGEXP}+do_pkg   "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP}+do_pkg   "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP}++install_pkg "cabal-install"++echo+echo "==========================================="+CABAL_BIN="$PREFIX/bin"+if [ -x "$CABAL_BIN/cabal" ]+then+    echo "The 'cabal' program has been installed in $CABAL_BIN/"+    echo "You should either add $CABAL_BIN to your PATH"+    echo "or copy the cabal program to a directory that is on your PATH."+    echo+    echo "The first thing to do is to get the latest list of packages with:"+    echo "  cabal update"+    echo "This will also create a default config file (if it does not already"+    echo "exist) at $HOME/.cabal/config"+    echo+    echo "By default cabal will install programs to $HOME/.cabal/bin"+    echo "If you do not want to add this directory to your PATH then you can"+    echo "change the setting in the config file, for example you could use:"+    echo "symlink-bindir: $HOME/bin"+else+    echo "Sorry, something went wrong."+    echo "The 'cabal' executable was not successfully installed into"+    echo "$CABAL_BIN/"+fi+echo++rm ghc-pkg.list
+ cabal/cabal-install/cabal-install.cabal view
@@ -0,0 +1,120 @@+Name:               cabal-install+Version:            0.11.2+Synopsis:           The command-line interface for Cabal and Hackage.+Description:+    The \'cabal\' command-line program simplifies the process of managing+    Haskell software by automating the fetching, configuration, compilation+    and installation of Haskell libraries and programs.+homepage:           http://www.haskell.org/cabal/+bug-reports:        http://hackage.haskell.org/trac/hackage/+License:            BSD3+License-File:       LICENSE+Author:             Lemmih <lemmih@gmail.com>+                    Paolo Martini <paolo@nemail.it>+                    Bjorn Bringert <bjorn@bringert.net>+                    Isaac Potoczny-Jones <ijones@syntaxpolice.org>+                    Duncan Coutts <duncan@community.haskell.org>+Maintainer:         cabal-devel@haskell.org+Copyright:          2005 Lemmih <lemmih@gmail.com>+                    2006 Paolo Martini <paolo@nemail.it>+                    2007 Bjorn Bringert <bjorn@bringert.net>+                    2007 Isaac Potoczny-Jones <ijones@syntaxpolice.org>+                    2007-2011 Duncan Coutts <duncan@community.haskell.org>+Category:           Distribution+Build-type:         Simple+Extra-Source-Files: README bash-completion/cabal bootstrap.sh+Cabal-Version:      >= 1.6++source-repository head+  type:     darcs+  location: http://darcs.haskell.org/cabal-install/++flag old-base+  description: Old, monolithic base+  default: False++flag bytestring-in-base++Executable cabal+    Main-Is:            Main.hs+    -- We want assertion checking on even if people build with -O+    -- although it is expensive, we want to catch problems early:+    ghc-options:        -Wall -fno-ignore-asserts+    if impl(ghc >= 6.8)+      ghc-options: -fwarn-tabs+    Other-Modules:+        Distribution.Client.BuildReports.Anonymous+        Distribution.Client.BuildReports.Storage+        Distribution.Client.BuildReports.Types+        Distribution.Client.BuildReports.Upload+        Distribution.Client.Check+        Distribution.Client.Config+        Distribution.Client.Configure+        Distribution.Client.Dependency+        Distribution.Client.Dependency.TopDown+        Distribution.Client.Dependency.TopDown.Constraints+        Distribution.Client.Dependency.TopDown.Types+        Distribution.Client.Dependency.Types+        Distribution.Client.Fetch+        Distribution.Client.FetchUtils+        Distribution.Client.GZipUtils+        Distribution.Client.Haddock+        Distribution.Client.HttpUtils+        Distribution.Client.IndexUtils+        Distribution.Client.Init+        Distribution.Client.Init.Heuristics+        Distribution.Client.Init.Licenses+        Distribution.Client.Init.Types+        Distribution.Client.Install+        Distribution.Client.InstallPlan+        Distribution.Client.InstallSymlink+        Distribution.Client.List+        Distribution.Client.PackageIndex+        Distribution.Client.PackageUtils+        Distribution.Client.Setup+        Distribution.Client.SetupWrapper+        Distribution.Client.SrcDist+        Distribution.Client.Tar+        Distribution.Client.Targets+        Distribution.Client.Types+        Distribution.Client.Unpack+        Distribution.Client.Update+        Distribution.Client.Upload+        Distribution.Client.Utils+        Distribution.Client.World+        Distribution.Client.Win32SelfUpgrade+        Distribution.Compat.Exception+        Distribution.Compat.FilePerms+        Paths_cabal_install++    build-depends: base     >= 2        && < 5,+                   Cabal    >= 1.10.1   && < 1.11.3,+                   filepath >= 1.0      && < 1.3,+                   network  >= 1        && < 3,+                   HTTP     >= 4000.0.2 && < 4001,+                   zlib     >= 0.4      && < 0.6,+                   time     >= 1.1      && < 1.3++    if flag(old-base)+      build-depends: base < 3+    else+      build-depends: base       >= 3,+                     process    >= 1   && < 1.1,+                     directory  >= 1   && < 1.2,+                     pretty     >= 1   && < 1.1,+                     random     >= 1   && < 1.1,+                     containers >= 0.1 && < 0.5,+                     array      >= 0.1 && < 0.4,+                     old-time   >= 1   && < 1.1++    if flag(bytestring-in-base)+      build-depends: base >= 2.0 && < 2.2+    else+      build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9++    if os(windows)+      build-depends: Win32 >= 2 && < 3+      cpp-options: -DWIN32+    else+      build-depends: unix >= 1.0 && < 2.5+    extensions: CPP
+ cabal/cabal-install/changelog view
@@ -0,0 +1,121 @@+-*-change-log-*-++0.10.0 Duncan Coutts <duncan@community.haskell.org> February 2011+	* New package targets: local dirs, local and remote tarballs+	* Initial support for a "world" package target+	* Partial fix for situation where user packages mask global ones+	* Removed cabal upgrade, new --upgrade-dependencies flag+	* New cabal install --only-dependencies flag+	* New cabal fetch --no-dependencies and --dry-run flags+	* Improved output for cabal info+	* Simpler and faster bash command line completion+	* Fix for broken proxies that decompress wrongly+	* Fix for cabal unpack to preserve executable permissions+	* Adjusted the output for the -v verbosity level in a few places++0.8.2 Duncan Coutts <duncan@community.haskell.org> March 2010+	* Fix for cabal update on Windows+	* On windows switch to per-user installs (rather than global)+	* Handle intra-package dependencies in dependency planning+	* Minor tweaks to cabal init feature+	* Fix various -Wall warnings+	* Fix for cabal sdist --snapshot++0.8.0 Duncan Coutts <duncan@haskell.org> Dec 2009+	* Works with ghc-6.12+	* New "cabal init" command for making initial project .cabal file+	* New feature to maintain an index of haddock documentation++0.6.4 Duncan Coutts <duncan@haskell.org> Nov 2009+	* Improve the algorithm for selecting the base package version+	* Hackage errors now reported by "cabal upload [--check]"+	* Improved format of messages from "cabal check"+	* Config file can now be selected by an env var+	* Updated tar reading/writing code+	* Improve instructions in the README and bootstrap output+	* Fix bootstrap.sh on Solaris 9+	* Fix bootstrap for systems where network uses parsec 3+	* Fix building with ghc-6.6++0.6.2 Duncan Coutts <duncan@haskell.org> Feb 2009+	* The upgrade command has been disabled in this release+	* The configure and install commands now have consistent behaviour+	* Reduce the tendancy to re-install already existing packages+	* The --constraint= flag now works for the install command+	* New --preference= flag for soft constraints / version preferences+	* Improved bootstrap.sh script, smarter and better error checking+	* New cabal info command to display detailed info on packages+	* New cabal unpack command to download and untar a package+	* HTTP-4000 package required, should fix bugs with http proxies+	* Now works with authenticated proxies.+	* On Windows can now override the proxy setting using an env var+	* Fix compatability with config files generated by older versions+	* Warn if the hackage package list is very old+	* More helpful --help output, mention config file and examples+	* Better documentation in ~/.cabal/config file+	* Improved command line interface for logging and build reporting+	* Minor improvements to some messages++0.6.0 Duncan Coutts <duncan@haskell.org> Oct 2008+	* Constraint solver can now cope with base 3 and base 4+	* Allow use of package version preferences from hackage index+	* More detailed output from cabal install --dry-run -v+	* Improved bootstrap.sh++0.5.2 Duncan Coutts <duncan@haskell.org> Aug 2008+	* Suport building haddock documentaion+	* Self-reinstall now works on Windows+	* Allow adding symlinks to excutables into a separate bindir+	* New self-documenting config file+	* New install --reinstall flag+	* More helpful status messages in a couple places+	* Upload failures now report full text error message from the server+	* Support for local package repositories+	* New build logging and reporting+	* New command to upload build reports to (a compatible) server+	* Allow tilde in hackage server URIs+	* Internal code improvements+	* Many other minor improvements and bug fixes++0.5.1 Duncan Coutts <duncan@haskell.org> June 2008+	* Restore minimal hugs support in dependency resolver+	* Fix for disabled http proxies on Windows+	* Revert to global installs on Windows by default++0.5.0 Duncan Coutts <duncan@haskell.org> June 2008+	* New package dependency resolver, solving diamond dep problem+	* Integrate cabal-setup functionality+	* Integrate cabal-upload functionality+	* New cabal update and check commands+	* Improved behavior for install and upgrade commands+	* Full Windows support+	* New command line handling+	* Bash command line completion+	* Allow case insensitive package names on command line+	* New --dry-run flag for install, upgrade and fetch commands+	* New --root-cmd flag to allow installing as root+	* New --cabal-lib-version flag to select different Cabal lib versions+	* Support for HTTP proxies+	* Improved cabal list output+	* Build other non-dependent packages even when some fail+	* Report a summary of all build failures at the end+	* Partial support for hugs+	* Partial implementation of build reporting and logging+	* More consistent logging and verbosity+	* Significant internal code restructuring++0.4 Duncan Coutts <duncan@haskell.org> Oct 2007+	* Renamed executable from 'cabal-install' to 'cabal'+	* Partial Windows compatability+	* Do per-user installs by default+	* cabal install now installs the package in the current directory+	* Allow multiple remote servers+	* Use zlib lib and internal tar code and rather than external tar+	* Reorganised configuration files+	* Significant code restructuring+	* Cope with packages with conditional dependencies++0.3 and older versions by Lemmih, Paolo Martini and others 2006-2007+	* Switch from smart-server, dumb-client model to the reverse+	* New .tar.gz based index format+	* New remote and local package archive format
+ cabal/cabal-install/tests/test-cabal-install view
@@ -0,0 +1,9 @@+#!/bin/sh++darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \+cd Cabal/cabal-install && \+make && \+sudo make install && \+sudo cabal-install update && \+cabal-install install --prefix=/tmp --user hnop && \+ls -l /tmp/bin/hnop
+ cabal/cabal-install/tests/test-cabal-install-user view
@@ -0,0 +1,8 @@+#!/bin/sh++darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \+cd Cabal/cabal-install && \+make install-user && \+cabal-install update && \+cabal-install install --prefix=/tmp --user hnop && \+ls -l /tmp/bin/hnop
+ cabal/cabal/Cabal.cabal view
@@ -0,0 +1,163 @@+Name: Cabal+Version: 1.12.0+Copyright: 2003-2006, Isaac Jones+           2005-2011, Duncan Coutts+License: BSD3+License-File: LICENSE+Author: Isaac Jones <ijones@syntaxpolice.org>+        Duncan Coutts <duncan@community.haskell.org>+Maintainer: cabal-devel@haskell.org+Homepage: http://www.haskell.org/cabal/+bug-reports: http://hackage.haskell.org/trac/hackage/+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 changelog++source-repository head+  type:     darcs+  location: http://darcs.haskell.org/cabal/++Flag base4+    Description: Choose the even newer, even smaller, split-up base package.++Flag base3+    Description: Choose the new smaller, split-up base package.++Library+  build-depends:   base       >= 2   && < 5,+                   filepath   >= 1   && < 1.3+  if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }+  if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }+  if flag(base3)+    Build-Depends: directory  >= 1   && < 1.2,+                   process    >= 1   && < 1.2,+                   old-time   >= 1   && < 1.1,+                   containers >= 0.1 && < 0.5,+                   array      >= 0.1 && < 0.4,+                   pretty     >= 1   && < 1.2++  if !os(windows)+    Build-Depends: unix       >= 2.0 && < 2.6++  ghc-options: -Wall -fno-ignore-asserts+  if impl(ghc >= 6.8)+    ghc-options: -fwarn-tabs+  nhc98-Options: -K4M++  Exposed-Modules:+        Distribution.Compiler,+        Distribution.InstalledPackageInfo,+        Distribution.License,+        Distribution.Make,+        Distribution.ModuleName,+        Distribution.Package,+        Distribution.PackageDescription,+        Distribution.PackageDescription.Configuration,+        Distribution.PackageDescription.Parse,+        Distribution.PackageDescription.Check,+        Distribution.PackageDescription.PrettyPrint,+        Distribution.ParseUtils,+        Distribution.ReadE,+        Distribution.Simple,+        Distribution.Simple.Build,+        Distribution.Simple.Build.Macros,+        Distribution.Simple.Build.PathsModule,+        Distribution.Simple.BuildPaths,+        Distribution.Simple.Command,+        Distribution.Simple.Compiler,+        Distribution.Simple.Configure,+        Distribution.Simple.GHC,+        Distribution.Simple.LHC,+        Distribution.Simple.Haddock,+        Distribution.Simple.Hpc,+        Distribution.Simple.Hugs,+        Distribution.Simple.Install,+        Distribution.Simple.InstallDirs,+        Distribution.Simple.JHC,+        Distribution.Simple.LocalBuildInfo,+        Distribution.Simple.NHC,+        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.HcPkg,+        Distribution.Simple.Program.Ld,+        Distribution.Simple.Program.Run,+        Distribution.Simple.Program.Script,+        Distribution.Simple.Program.Types,+        Distribution.Simple.Register,+        Distribution.Simple.Setup,+        Distribution.Simple.SrcDist,+        Distribution.Simple.Test,+        Distribution.Simple.UHC,+        Distribution.Simple.UserHooks,+        Distribution.Simple.Utils,+        Distribution.System,+        Distribution.TestSuite,+        Distribution.Text,+        Distribution.Verbosity,+        Distribution.Version,+        Distribution.Compat.ReadP,+        Language.Haskell.Extension++  Other-Modules:+        Distribution.GetOpt,+        Distribution.Compat.Exception,+        Distribution.Compat.CopyFile,+        Distribution.Compat.TempFile,+        Distribution.Simple.GHC.IPI641,+        Distribution.Simple.GHC.IPI642,+        Paths_Cabal++  Default-Language: Haskell98+  Default-Extensions: CPP++test-suite unit-tests+  type: exitcode-stdio-1.0+  main-is: suite.hs+  other-modules: 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.TargetSpecificDeps1.Check,+                 PackageTests.BuildDeps.TargetSpecificDeps2.Check,+                 PackageTests.BuildDeps.TargetSpecificDeps3.Check,+                 PackageTests.BuildDeps.SameDepsAllRound.Check,+                 PackageTests.TestStanza.Check,+                 PackageTests.TestSuiteExeV10.Check,+                 PackageTests.PackageTester+  hs-source-dirs: tests+  build-depends:+        base,+        test-framework,+        test-framework-quickcheck2,+        test-framework-hunit,+        HUnit,+        QuickCheck >= 2.1.0.1,+        Cabal,+        process,+        directory,+        filepath,+        extensible-exceptions,+        bytestring,+        unix+  Default-Language: Haskell98
+ cabal/cabal/DefaultSetup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ cabal/cabal/Distribution/Compat/CopyFile.hs view
@@ -0,0 +1,115 @@+{-# OPTIONS -cpp #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp #-}+-- #hide+module Distribution.Compat.CopyFile (+  copyFile,+  copyOrdinaryFile,+  copyExecutableFile,+  setFileOrdinary,+  setFileExecutable,+  setDirOrdinary,+  ) where++#ifdef __GLASGOW_HASKELL__++import Control.Monad+         ( when )+import Control.Exception+         ( bracket, bracketOnError )+import Distribution.Compat.Exception+         ( catchIO )+#if __GLASGOW_HASKELL__ >= 608+import Distribution.Compat.Exception+         ( throwIOIO )+import System.IO.Error+         ( ioeSetLocation )+#endif+import System.Directory+         ( renameFile, removeFile )+import Distribution.Compat.TempFile+         ( openBinaryTempFile )+import System.FilePath+         ( takeDirectory )+import System.IO+         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )+import Foreign+         ( allocaBytes )+#endif /* __GLASGOW_HASKELL__ */++#ifndef mingw32_HOST_OS+#if __GLASGOW_HASKELL__ >= 611+import System.Posix.Internals (withFilePath)+#else+import Foreign.C              (withCString)+#endif+import System.Posix.Types+         ( FileMode )+import System.Posix.Internals+         ( c_chmod )+#if __GLASGOW_HASKELL__ >= 608+import Foreign.C+         ( throwErrnoPathIfMinus1_ )+#else+import Foreign.C+         ( throwErrnoIfMinus1_ )+#endif+#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 =+#if __GLASGOW_HASKELL__ >= 611+  withFilePath name $ \s -> do+#else+  withCString name $ \s -> do+#endif+#if __GLASGOW_HASKELL__ >= 608+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+    throwErrnoIfMinus1_                   name (c_chmod s m)+#endif+#else+setFileOrdinary   _ = return ()+setFileExecutable _ = return ()+#endif+-- This happens to be true on Unix and currently on Windows too:+setDirOrdinary = setFileExecutable++copyFile :: FilePath -> FilePath -> IO ()+#ifdef __GLASGOW_HASKELL__+copyFile fromFPath toFPath =+  copy+#if __GLASGOW_HASKELL__ >= 608+    `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))+#endif+    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+#else+copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath+#endif
+ cabal/cabal/Distribution/Compat/Exception.hs view
@@ -0,0 +1,61 @@+{-# OPTIONS -cpp #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp #-}++#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))+#define NEW_EXCEPTION+#endif++module Distribution.Compat.Exception (+     Exception.IOException,+     onException,+     catchIO,+     catchExit,+     throwIOIO,+     tryIO,+  ) where++import System.Exit+import qualified Control.Exception as Exception++onException :: IO a -> IO b -> IO a+#ifdef NEW_EXCEPTION+onException = Exception.onException+#else+onException io what = io `Exception.catch` \e -> do what+                                                    Exception.throw e+#endif++throwIOIO :: Exception.IOException -> IO a+#ifdef NEW_EXCEPTION+throwIOIO = Exception.throwIO+#else+throwIOIO = Exception.throwIO . Exception.IOException+#endif++tryIO :: IO a -> IO (Either Exception.IOException a)+#ifdef NEW_EXCEPTION+tryIO = Exception.try+#else+tryIO = Exception.tryJust Exception.ioErrors+#endif++catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a+#ifdef NEW_EXCEPTION+catchIO = Exception.catch+#else+catchIO = Exception.catchJust Exception.ioErrors+#endif++catchExit :: IO a -> (ExitCode -> IO a) -> IO a+#ifdef NEW_EXCEPTION+catchExit = Exception.catch+#else+catchExit = Exception.catchJust exitExceptions+    where exitExceptions (Exception.ExitException ee) = Just ee+          exitExceptions _                            = Nothing+#endif+
+ cabal/cabal/Distribution/Compat/ReadP.hs view
@@ -0,0 +1,470 @@+-----------------------------------------------------------------------------+-- |+-- 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/+-- (<http://www.cs.chalmers.se/~koen/publications.html>).+--+-- This version of ReadP has been locally hacked to make it H98, by+-- Martin Sj&#xF6;gren <mailto:msjogren@gmail.com>+--+-----------------------------------------------------------------------------++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++  -- * Properties+  -- $properties+  )+ where++import Control.Monad( MonadPlus(..), liftM2 )+import Data.Char (isSpace)++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 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 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 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']))++-- ---------------------------------------------------------------------------+-- 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 =+>    readP_to_S get [] =~ []+>+>  prop_Get_Cons c s =+>    readP_to_S get (c:s) =~ [(c,s)]+>+>  prop_Look s =+>    readP_to_S look s =~ [(s,s)]+>+>  prop_Fail s =+>    readP_to_S pfail s =~. []+>+>  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 p q s =+>    readP_to_S (p +++ q) s =~.+>      (readP_to_S p s ++ readP_to_S q s)+>+>  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 this s =+>    readP_to_S (string this) (this ++ s) =~+>      [(this,s)]+>+>  prop_String_Maybe this s =+>    readP_to_S (string this) s =~+>      [(this, drop (length this) s) | this `isPrefixOf` s]+>+>  prop_Munch p s =+>    readP_to_S (munch p) s =~+>      [(takeWhile p s, dropWhile p s)]+>+>  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 ps s =+>    readP_to_S (choice ps) s =~.+>      readP_to_S (foldr (+++) pfail ps) s+>+>  prop_ReadS r s =+>    readP_to_S (readS_to_P r) s =~. r s+-}+
+ cabal/cabal/Distribution/Compat/TempFile.hs view
@@ -0,0 +1,204 @@+{-# OPTIONS -cpp #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP #-}+{-# OPTIONS_GHC -cpp #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp #-}+-- #hide+module Distribution.Compat.TempFile (+  openTempFile,+  openBinaryTempFile,+  openNewBinaryFile,+  createTempDirectory,+  ) where+++import System.FilePath        ((</>))+import Foreign.C              (eEXIST)++#if __NHC__ || __HUGS__+import System.IO              (openFile, openBinaryFile,+                               Handle, IOMode(ReadWriteMode))+import System.Directory       (doesFileExist)+import System.FilePath        ((<.>), splitExtension)+import System.IO.Error        (try, isAlreadyExistsError)+#else+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)+#if __GLASGOW_HASKELL__ >= 611+import System.Posix.Internals (withFilePath)+#else+import Foreign.C              (withCString)+#endif+import Foreign.C              (CInt)+#if __GLASGOW_HASKELL__ >= 611+import GHC.IO.Handle.FD       (fdToHandle)+#else+import GHC.Handle             (fdToHandle)+#endif+import Distribution.Compat.Exception (onException, tryIO)+#endif+import Foreign.C              (getErrno, errnoToIOError)++#if __NHC__+import System.Posix.Types     (CPid(..))+foreign import ccall unsafe "getpid" c_getpid :: IO CPid+#else+import System.Posix.Internals (c_getpid)+#endif++#ifdef mingw32_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++#if __NHC__ || __HUGS__+-- use a temporary filename that doesn't already exist.+-- NB. *not* secure (we don't atomically lock the tmp file we get)+openTempFile :: FilePath -> String -> IO (FilePath, Handle)+openTempFile tmp_dir template+  = do x <- getProcessID+       findTempName x+  where+    (templateBase, templateExt) = splitExtension template+    findTempName :: Int -> IO (FilePath, Handle)+    findTempName x+      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt+           b  <- doesFileExist path+           if b then findTempName (x+1)+                else do hnd <- openFile path ReadWriteMode+                        return (path, hnd)++openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)+openBinaryTempFile tmp_dir template+  = do x <- getProcessID+       findTempName x+  where+    (templateBase, templateExt) = splitExtension template+    findTempName :: Int -> IO (FilePath, Handle)+    findTempName x+      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt+           b  <- doesFileExist path+           if b then findTempName (x+1)+                else do hnd <- openBinaryFile path ReadWriteMode+                        return (path, hnd)++openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)+openNewBinaryFile = openBinaryTempFile++getProcessID :: IO Int+getProcessID = fmap fromIntegral c_getpid+#else+-- 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 filepath 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++#if __GLASGOW_HASKELL__ < 611+    withFilePath = withCString+#endif++    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 filepath is,+         -- as any exceptions etc will only be able to report the+         -- fd currently+         h <-+#if __GLASGOW_HASKELL__ >= 609+              fdToHandle fd+#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)+              -- fdToHandle is borked on Windows with ghc-6.6.x+              openFd (fromIntegral fd) Nothing False filepath+                                       ReadWriteMode True+#else+              fdToHandle (fromIntegral fd)+#endif+              `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 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+#endif++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 ()+#ifdef mingw32_HOST_OS+mkPrivateDir s = createDirectory s+#else+mkPrivateDir s = System.Posix.createDirectory s 0o700+#endif
+ cabal/cabal/Distribution/Compiler.hs view
@@ -0,0 +1,158 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Compiler+-- Copyright   :  Isaac Jones 2003-2004+--+-- 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 #50.++{- 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. -}++module Distribution.Compiler (+  -- * Compiler flavor+  CompilerFlavor(..),+  buildCompilerFlavor,+  defaultCompilerFlavor,+  parseCompilerFlavorCompat,++  -- * Compiler id+  CompilerId(..),+  ) where++import Distribution.Version (Version(..))++import qualified System.Info (compilerName)+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 | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC+                    | OtherCompiler String+  deriving (Show, Read, Eq, Ord)++knownCompilerFlavors :: [CompilerFlavor]+knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]++instance Text CompilerFlavor where+  disp (OtherCompiler 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 =+  case lookup (lowercase s) compilerMap of+    Just compiler -> compiler+    Nothing       -> OtherCompiler s+  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++-- | 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, Ord, Read, Show)++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
+ cabal/cabal/Distribution/GetOpt.hs view
@@ -0,0 +1,335 @@+-----------------------------------------------------------------------------+-- |+-- 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 <Sven.Panne@informatik.uni-muenchen.de> 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!+:-)+-}++-- #hide+module Distribution.GetOpt (+   -- * GetOpt+   getOpt, getOpt',+   usageInfo,+   ArgOrder(..),+   OptDescr(..),+   ArgDescr(..),++   -- * Example++   -- $example+) where++import Data.List ( isPrefixOf, intersperse, find )++-- |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 [ (sepBy ", " (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 ' ')+         sepBy s    = concat . intersperse s++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+                          , find (p opt) xs /= Nothing]+         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/cabal/Distribution/InstalledPackageInfo.hs view
@@ -0,0 +1,294 @@+-----------------------------------------------------------------------------+-- |+-- 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.++{- 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 the University 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. -}++-- This module is meant to be local-only to Distribution...++module Distribution.InstalledPackageInfo (+        InstalledPackageInfo_(..), InstalledPackageInfo,+        ParseResult(..), PError(..), PWarning,+        emptyInstalledPackageInfo,+        parseInstalledPackageInfo,+        showInstalledPackageInfo,+        showInstalledPackageInfoField,+        fieldsInstalledPackageInfo,+  ) where++import Distribution.ParseUtils+         ( FieldDescr(..), ParseResult(..), PError(..), PWarning+         , simpleField, listField, parseLicenseQ+         , showFields, showSingleNamedField, parseFieldsFlat+         , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ+         , showFilePath, showToken, boolField, parseOptVersion+         , parseFreeText, showFreeText )+import Distribution.License     ( License(..) )+import Distribution.Package+         ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..)+         , packageName, packageVersion )+import qualified Distribution.Package as Package+         ( Package(..) )+import Distribution.ModuleName+         ( ModuleName )+import Distribution.Version+         ( Version(..) )+import Distribution.Text+         ( Text(disp, parse) )++-- -----------------------------------------------------------------------------+-- The InstalledPackageInfo type++data InstalledPackageInfo_ m+   = InstalledPackageInfo {+        -- these parts are exactly the same as PackageDescription+        installedPackageId :: InstalledPackageId,+        sourcePackageId    :: PackageId,+        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    :: [m],+        hiddenModules     :: [m],+        trusted           :: Bool,+        importDirs        :: [FilePath],  -- contain sources in case of Hugs+        libraryDirs       :: [FilePath],+        hsLibraries       :: [String],+        extraLibraries    :: [String],+        extraGHCiLibraries:: [String],    -- overrides extraLibraries for GHCi+        includeDirs       :: [FilePath],+        includes          :: [String],+        depends           :: [InstalledPackageId],+        hugsOptions       :: [String],+        ccOptions         :: [String],+        ldOptions         :: [String],+        frameworkDirs     :: [FilePath],+        frameworks        :: [String],+        haddockInterfaces :: [FilePath],+        haddockHTMLs      :: [FilePath]+    }+    deriving (Read, Show)++instance Package.Package          (InstalledPackageInfo_ str) where+   packageId = sourcePackageId++type InstalledPackageInfo = InstalledPackageInfo_ ModuleName++emptyInstalledPackageInfo :: InstalledPackageInfo_ m+emptyInstalledPackageInfo+   = InstalledPackageInfo {+        installedPackageId = InstalledPackageId "",+        sourcePackageId    = PackageIdentifier (PackageName "") noVersion,+        license           = AllRightsReserved,+        copyright         = "",+        maintainer        = "",+        author            = "",+        stability         = "",+        homepage          = "",+        pkgUrl            = "",+        synopsis          = "",+        description       = "",+        category          = "",+        exposed           = False,+        exposedModules    = [],+        hiddenModules     = [],+        trusted           = False,+        importDirs        = [],+        libraryDirs       = [],+        hsLibraries       = [],+        extraLibraries    = [],+        extraGHCiLibraries= [],+        includeDirs       = [],+        includes          = [],+        depends           = [],+        hugsOptions       = [],+        ccOptions         = [],+        ldOptions         = [],+        frameworkDirs     = [],+        frameworks        = [],+        haddockInterfaces = [],+        haddockHTMLs      = []+    }++noVersion :: Version+noVersion = Version{ versionBranch=[], versionTags=[] }++-- -----------------------------------------------------------------------------+-- Parsing++parseInstalledPackageInfo :: String -> ParseResult InstalledPackageInfo+parseInstalledPackageInfo =+    parseFieldsFlat fieldsInstalledPackageInfo emptyInstalledPackageInfo++-- -----------------------------------------------------------------------------+-- Pretty-printing++showInstalledPackageInfo :: InstalledPackageInfo -> String+showInstalledPackageInfo = showFields fieldsInstalledPackageInfo++showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)+showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo++-- -----------------------------------------------------------------------------+-- 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 "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})+ , listField   "exposed-modules"+        disp               parseModuleNameQ+        exposedModules     (\xs    pkg -> pkg{exposedModules=xs})+ , listField   "hidden-modules"+        disp               parseModuleNameQ+        hiddenModules      (\xs    pkg -> pkg{hiddenModules=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})+ , 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   "hugs-options"+        showToken          parseTokenQ+        hugsOptions        (\path  pkg -> pkg{hugsOptions=path})+ , 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})+ ]
+ cabal/cabal/Distribution/License.hs view
@@ -0,0 +1,138 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.License+-- Copyright   :  Isaac Jones 2003-2005+--                Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- The License datatype.  For more information about these and other+-- open-source licenses, you may visit <http://www.opensource.org/>.+--+-- The @.cabal@ file allows you to specify a license file. Of course you can+-- use any license you like but people often pick common open source licenses+-- and it's useful if we can automatically recognise that (eg so we can display+-- it on the hackage web pages). So you can also specify the license itself in+-- the @.cabal@ file from a short enumeration defined in this module. It+-- includes 'GPL', 'LGPL' and 'BSD3' licenses.++{- 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. -}++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 qualified Data.Char as Char (isAlphaNum)++-- |This datatype indicates the license under which your package is+-- released.  It is also wise to add your license to each source file+-- using the license-file field.  The 'AllRightsReserved' constructor+-- is not actually a license, but states that you are not giving+-- anyone else a license to use or distribute your work.  The comments+-- below are general guidelines.  Please read the licenses themselves+-- and consult a lawyer if you are unsure of your rights to release+-- the software.+--+data License =++--TODO: * remove BSD4++    -- | GNU Public License. Source code must accompany alterations.+    GPL (Maybe Version)++    -- | Lesser GPL, Less restrictive than GPL, useful for libraries.+  | LGPL (Maybe Version)++    -- | 3-clause BSD license, newer, no advertising clause. Very free license.+  | BSD3++    -- | 4-clause BSD license, older, with advertising clause. You almost+    -- certainly want to use the BSD3 license instead.+  | BSD4++    -- | The MIT license, similar to the BSD3. Very free license.+  | MIT++    -- | Holder makes no claim to ownership, least restrictive license.+  | PublicDomain++    -- | No rights are granted to others. Undistributable. Most restrictive.+  | AllRightsReserved++    -- | Some other license.+  | OtherLicense++    -- | Not a recognised license.+    -- Allows us to deal with future extensions more gracefully.+  | UnknownLicense String+  deriving (Read, Show, Eq)++knownLicenses :: [License]+knownLicenses = [ GPL  unversioned, GPL  (version [2]),   GPL  (version [3])+                , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])+                , BSD3, MIT+                , 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 (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+      ("BSD3",              Nothing) -> BSD3+      ("BSD4",              Nothing) -> BSD4+      ("MIT",               Nothing) -> MIT+      ("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) = Disp.char '-' <> disp v
+ cabal/cabal/Distribution/Make.hs view
@@ -0,0 +1,213 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Make+-- Copyright   :  Martin Sj&#xF6;gren 2004+--+-- 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 backend 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) \++{- 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. -}++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  (intersperse)+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 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 (concat (intersperse "\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/cabal/Distribution/ModuleName.hs view
@@ -0,0 +1,130 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.ModuleName+-- Copyright   :  Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Data type for Haskell module names.++{- 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. -}++module Distribution.ModuleName (+        ModuleName,+        fromString,+        components,+        toFilePath,+        main,+        simple,+  ) 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, isUpper )+import System.FilePath+         ( pathSeparator )+import Data.List+         ( intersperse )++-- | A valid Haskell module name.+--+newtype ModuleName = ModuleName [String]+  deriving (Eq, Ord, Read, Show)++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 = concat . intersperse [pathSeparator] . components
+ cabal/cabal/Distribution/Package.hs view
@@ -0,0 +1,193 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Package+-- Copyright   :  Isaac Jones 2003-2004+--+-- 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\"@.++{- 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. -}++module Distribution.Package (+        -- * Package ids+        PackageName(..),+        PackageIdentifier(..),+        PackageId,++        -- * Installed package identifiers+        InstalledPackageId(..),++        -- * Package source dependencies+        Dependency(..),+        thisPackageVersion,+        notThisPackageVersion,+        simplifyDependency,++        -- * Package classes+        Package(..), packageName, packageVersion,+        PackageFixedDeps(..),+  ) where++import Distribution.Version+         ( Version(..), VersionRange, anyVersion, thisVersion+         , notThisVersion, simplifyVersionRange )++import Distribution.Text (Text(..))+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP ((<++))+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<>), (<+>), text)+import qualified Data.Char as Char ( isDigit, isAlphaNum )+import Data.List ( intersperse )++newtype PackageName = PackageName String+    deriving (Read, Show, Eq, Ord)++instance Text PackageName where+  disp (PackageName n) = Disp.text n+  parse = do+    ns <- Parse.sepBy1 component (Parse.char '-')+    return (PackageName (concat (intersperse "-" 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).++-- | 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 (Read, Show, Eq, Ord)++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)++-- ------------------------------------------------------------+-- * 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 (Read,Show,Eq,Ord)++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 source dependencies+-- ------------------------------------------------------------++-- | Describes a dependency on a source package (API)+--+data Dependency = Dependency PackageName VersionRange+                  deriving (Read, Show, Eq)++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]
+ cabal/cabal/Distribution/PackageDescription.hs view
@@ -0,0 +1,895 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PackageDescription+-- Copyright   :  Isaac Jones 2003-2005+--+-- 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', and 'TestSuite' sections each of which have associated+-- 'BuildInfo' data that's used to build the library, exe, or test. 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.++{- 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. -}++module Distribution.PackageDescription (+        -- * Package descriptions+        PackageDescription(..),+        emptyPackageDescription,+        specVersion,+        descCabalVersion,+        BuildType(..),+        knownBuildTypes,++        -- ** Libraries+        Library(..),+        emptyLibrary,+        withLib,+        hasLibs,+        libModules,++        -- ** Executables+        Executable(..),+        emptyExecutable,+        withExe,+        hasExes,+        exeModules,++        -- * Tests+        TestSuite(..),+        TestSuiteInterface(..),+        TestType(..),+        testType,+        knownTestTypes,+        emptyTestSuite,+        hasTests,+        withTest,+        testModules,+        enabledTests,++        -- * Build information+        BuildInfo(..),+        emptyBuildInfo,+        allBuildInfo,+        allLanguages,+        allExtensions,+        usedExtensions,+        hcOptions,++        -- ** Supplementary build information+        HookedBuildInfo,+        emptyHookedBuildInfo,+        updatePackageDescription,++        -- * package configuration+        GenericPackageDescription(..),+        Flag(..), FlagName(..), FlagAssignment,+        CondTree(..), ConfVar(..), Condition(..),++        -- * Source repositories+        SourceRepo(..),+        RepoKind(..),+        RepoType(..),+        knownRepoTypes,+  ) where++import Data.List   (nub, intersperse)+import Data.Maybe  (maybeToList)+import Data.Monoid (Monoid(mempty, mappend))+import Control.Monad (MonadPlus(mplus))+import Text.PrettyPrint.HughesPJ as Disp+import qualified Distribution.Compat.ReadP as Parse+import qualified Data.Char as Char (isAlphaNum, isDigit, toLower)++import Distribution.Package+         ( PackageName(PackageName), PackageIdentifier(PackageIdentifier)+         , Dependency, Package(..) )+import Distribution.ModuleName ( ModuleName )+import Distribution.Version+         ( Version(Version), VersionRange, anyVersion, orLaterVersion+         , asVersionIntervals, LowerBound(..) )+import Distribution.License  (License(AllRightsReserved))+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,+        licenseFile    :: 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.+        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],+        dataFiles      :: [FilePath],+        dataDir        :: FilePath,+        extraSrcFiles  :: [FilePath],+        extraTmpFiles  :: [FilePath]+    }+    deriving (Show, Read, Eq)++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      = AllRightsReserved,+                      licenseFile  = "",+                      specVersionRaw = Right anyVersion,+                      buildType    = Nothing,+                      copyright    = "",+                      maintainer   = "",+                      author       = "",+                      stability    = "",+                      testedWith   = [],+                      buildDepends = [],+                      homepage     = "",+                      pkgUrl       = "",+                      bugReports   = "",+                      sourceRepos  = [],+                      synopsis     = "",+                      description  = "",+                      category     = "",+                      customFieldsPD = [],+                      library      = Nothing,+                      executables  = [],+                      testSuites   = [],+                      dataFiles    = [],+                      dataDir      = "",+                      extraSrcFiles = [],+                      extraTmpFiles = []+                     }++-- | 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 (Show, Read, Eq)++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++-- ---------------------------------------------------------------------------+-- The Library type++data Library = Library {+        exposedModules    :: [ModuleName],+        libExposed        :: Bool, -- ^ Is the lib to be exposed by default?+        libBuildInfo      :: BuildInfo+    }+    deriving (Show, Eq, Read)++instance Monoid Library where+  mempty = Library {+    exposedModules = mempty,+    libExposed     = True,+    libBuildInfo   = mempty+  }+  mappend a b = Library {+    exposedModules = combine exposedModules,+    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)+libModules :: Library -> [ModuleName]+libModules lib = exposedModules lib+              ++ otherModules (libBuildInfo lib)++-- ---------------------------------------------------------------------------+-- The Executable type++data Executable = Executable {+        exeName    :: String,+        modulePath :: FilePath,+        buildInfo  :: BuildInfo+    }+    deriving (Show, Read, Eq)++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 (Show, Read, Eq)++-- | 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, Read, Show)++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   = if testEnabled a then True else 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 (Show, Read, Eq)++knownTestTypes :: [TestType]+knownTestTypes = [ TestTypeExe (Version [1,0] [])+                   -- 'detailed-0.9' test type is disabled in Cabal-1.10.x+                   -- needs more work on the details of the library interface+              {- , TestTypeLib (Version [0,9] []) -} ]++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 = do+    cs   <- Parse.sepBy1 component (Parse.char '-')+    _    <- Parse.char '-'+    ver  <- parse+    let name = concat (intersperse "-" cs)+    return $! case lowercase name of+      "exitcode-stdio" -> TestTypeExe ver+      "detailed"       -> TestTypeLib ver+      _                -> TestTypeUnknown name ver++    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).++testType :: TestSuite -> TestType+testType test = case testInterface test of+  TestSuiteExeV10 ver _         -> TestTypeExe ver+  TestSuiteLibV09 ver _         -> TestTypeLib ver+  TestSuiteUnsupported testtype -> testtype++-- ---------------------------------------------------------------------------+-- 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],+        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+        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])],+        ghcProfOptions    :: [String],+        ghcSharedOptions  :: [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+    }+    deriving (Show,Read,Eq)++instance Monoid BuildInfo where+  mempty = BuildInfo {+    buildable         = True,+    buildTools        = [],+    cppOptions        = [],+    ccOptions         = [],+    ldOptions         = [],+    pkgconfigDepends  = [],+    frameworks        = [],+    cSources          = [],+    hsSourceDirs      = [],+    otherModules      = [],+    defaultLanguage   = Nothing,+    otherLanguages    = [],+    defaultExtensions = [],+    otherExtensions   = [],+    oldExtensions     = [],+    extraLibs         = [],+    extraLibDirs      = [],+    includeDirs       = [],+    includes          = [],+    installIncludes   = [],+    options           = [],+    ghcProfOptions    = [],+    ghcSharedOptions  = [],+    customFieldsBI    = [],+    targetBuildDepends = []+  }+  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,+    hsSourceDirs      = combineNub hsSourceDirs,+    otherModules      = combineNub otherModules,+    defaultLanguage   = combineMby defaultLanguage,+    otherLanguages    = combineNub otherLanguages,+    defaultExtensions = combineNub defaultExtensions,+    otherExtensions   = combineNub otherExtensions,+    oldExtensions     = combineNub oldExtensions,+    extraLibs         = combine    extraLibs,+    extraLibDirs      = combineNub extraLibDirs,+    includeDirs       = combineNub includeDirs,+    includes          = combineNub includes,+    installIncludes   = combineNub installIncludes,+    options           = combine    options,+    ghcProfOptions    = combine    ghcProfOptions,+    ghcSharedOptions  = combine    ghcSharedOptions,+    customFieldsBI    = combine    customFieldsBI,+    targetBuildDepends = combineNub targetBuildDepends+  }+    where+      combine    field = field a `mappend` field b+      combineNub field = nub (combine field)+      combineMby field = field b `mplus` field a++emptyBuildInfo :: BuildInfo+emptyBuildInfo = mempty++-- | The 'BuildInfo' for the library (if there is one and it's buildable), and+-- all buildable executables and test suites.  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 ]+  --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 hc bi = [ opt | (hc',opts) <- options 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, Read, Show)++-- | 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, Ord, Read, Show)++-- | 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, Ord, Read, Show)++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 =+  case lookup (lowercase s) repoTypeMap of+    Just repoType' -> repoType'+    Nothing        -> OtherRepoType s+  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]        -- ^libst 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)]+      }+    deriving (Show, Eq)++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)++-- | A 'FlagName' is the name of a user-defined configuration flag+newtype FlagName = FlagName String+    deriving (Eq, Ord, Show, Read)++-- | 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)++--instance Text ConfVar where+--    disp (OS os) = "os(" ++ display os ++ ")"+--    disp (Arch arch) = "arch(" ++ display arch ++ ")"+--    disp (Flag (ConfFlag f)) = "flag(" ++ f ++ ")"+--    disp (Impl c v) = "impl(" ++ display c+--                       ++ " " ++ display v ++ ")"++-- | 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)++--instance Text c => Text (Condition c) where+--  disp (Var x) = text (show x)+--  disp (Lit b) = text (show b)+--  disp (CNot c) = char '!' <> parens (ppCond c)+--  disp (COr c1 c2) = parens $ sep [ppCond c1, text "||" <+> ppCond c2]+--  disp (CAnd c1 c2) = parens $ sep [ppCond c1, text "&&" <+> ppCond c2]++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)++--instance (Text v, Text c) => Text (CondTree v c a) where+--  disp (CondNode _dat cs ifs) =+--    (text "build-depends: " <+>+--      disp cs)+--    $+$+--    (vcat $ map ppIf ifs)+--  where+--    ppIf (c,thenTree,mElseTree) =+--        ((text "if" <+> ppCond c <> colon) $$+--          nest 2 (ppCondTree thenTree disp))+--        $+$ (maybe empty (\t -> text "else: " $$ nest 2 (ppCondTree t disp))+--                   mElseTree)
+ cabal/cabal/Distribution/PackageDescription/Check.hs view
@@ -0,0 +1,1441 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PackageDescription.Check+-- Copyright   :  Lennart Kolmodin 2008+--+-- 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.++{- 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. -}++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 Distribution.Package ( pkgName )+import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription, finalizePackageDescription )+import Distribution.Compiler+         ( CompilerFlavor(..), buildCompilerFlavor, CompilerId(..) )+import Distribution.System+         ( OS(..), Arch(..), buildPlatform )+import Distribution.License+         ( License(..), knownLicenses )+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(..) )++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 determental 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 }++instance Show PackageCheck where+    show notice = explanation notice++check :: Bool -> PackageCheck -> Maybe PackageCheck+check False _  = Nothing+check True  pc = Just pc++-- ------------------------------------------------------------+-- * Standard checks+-- ------------------------------------------------------------++-- | Check for common mistakes and problems in package descriptions.+--+-- This is the standard collection of checks covering all apsects 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 alwaws know the GenericPackageDescription+checkConfiguredPackage :: PackageDescription -> [PackageCheck]+checkConfiguredPackage pkg =+    checkSanity pkg+ ++ checkFields pkg+ ++ checkLicense pkg+ ++ checkSourceRepos pkg+ ++ checkGhcOptions pkg+ ++ checkCCOptions 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 exeDuplicates)) $+      PackageBuildImpossible $ "Duplicate executable sections "+        ++ commaSep exeDuplicates+  , check (not (null testDuplicates)) $+      PackageBuildImpossible $ "Duplicate test sections "+        ++ commaSep testDuplicates++    --TODO: this seems to duplicate a check on the testsuites+  , check (not (null testsThatAreExes)) $+      PackageBuildImpossible $ "These test sections share names with executable sections: "+        ++ commaSep testsThatAreExes+  ]+  --TODO: check for name clashes case insensitively: windows file systems cannot cope.++  ++ maybe []  checkLibrary    (library pkg)+  ++ concatMap checkExecutable (executables pkg)+  ++ concatMap (checkTestSuite pkg) (testSuites 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+    exeDuplicates = dups exeNames+    testDuplicates = dups testNames+    testsThatAreExes = filter (flip elem exeNames) testNames++checkLibrary :: Library -> [PackageCheck]+checkLibrary lib =+  catMaybes [++    check (not (null moduleDuplicates)) $+       PackageBuildWarning $+            "Duplicate modules in library: "+         ++ commaSep (map display moduleDuplicates)+  ]++  where+    moduleDuplicates = dups (libModules lib)++checkExecutable :: Executable -> [PackageCheck]+checkExecutable exe =+  catMaybes [++    check (null (modulePath exe)) $+      PackageBuildImpossible $+        "No 'Main-Is' field found for executable " ++ exeName exe++  , check (not (null (modulePath exe))+       && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $+      PackageBuildImpossible $+           "The 'Main-Is' field must specify a '.hs' or '.lhs' file "+        ++ "(even if it is generated by a preprocessor)."++  , check (not (null moduleDuplicates)) $+       PackageBuildWarning $+            "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) $+      PackageBuildWarning $+           "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)."++  , check exeNameClash $+      PackageBuildImpossible $+           "The test suite " ++ testName test+        ++ " has the same name as an executable."++  , 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 -> takeExtension f `notElem` [".hs", ".lhs"]+      _                   -> False++    exeNameClash = testName test `elem` [ exeName exe | exe <- executables pkg ]+    libNameClash = testName test `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)+        ++ ". " ++ intercalate " "+             [ "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 == AllRightsReserved) $+      PackageDistInexcusable+        "The 'license' field is missing or specified as AllRightsReserved."++  , 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, PublicDomain]+           -- AllRightsReserved and PublicDomain are not strictly+           -- licenses so don't need license files.+        && null (licenseFile 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 _ = 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 (repoType repo == Nothing) $+      PackageDistInexcusable+        "The source-repository 'type' is a required field."++  , check (repoLocation repo == Nothing) $+      PackageDistInexcusable+        "The source-repository 'location' is a required field."++  , check (repoType repo == Just CVS && repoModule repo == Nothing) $+      PackageDistInexcusable+        "For a CVS source-repository, the 'module' is a required field."++  , check (repoKind repo == RepoThis && repoTag repo == Nothing) $+      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 $+      PackageDistInexcusable $+           "'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 ["-fhpc"] $+      PackageDistInexcusable $+        "'ghc-options: -fhpc' is not appropriate for a distributed package."++  , check (any ("-d" `isPrefixOf`) 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."++  , 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 = [ strs | bi <- allBuildInfo pkg+                         , (GHC, strs) <- options bi ]+    all_ghc_options = concat ghc_options+    lib_ghc_options = maybe [] (hcOptions GHC . libBuildInfo) (library pkg)++    checkFlags :: [String] -> PackageCheck -> Maybe PackageCheck+    checkFlags flags = check (any (`elem` flags) all_ghc_options)++    ghcExtension ('-':'f':name) = case name of+      "allow-overlapping-instances"    -> Just (EnableExtension  OverlappingInstances)+      "no-allow-overlapping-instances" -> Just (DisableExtension OverlappingInstances)+      "th"                             -> Just (EnableExtension  TemplateHaskell)+      "no-th"                          -> Just (DisableExtension TemplateHaskell)+      "ffi"                            -> Just (EnableExtension  ForeignFunctionInterface)+      "no-ffi"                         -> Just (DisableExtension ForeignFunctionInterface)+      "fi"                             -> Just (EnableExtension  ForeignFunctionInterface)+      "no-fi"                          -> Just (DisableExtension ForeignFunctionInterface)+      "monomorphism-restriction"       -> Just (EnableExtension  MonomorphismRestriction)+      "no-monomorphism-restriction"    -> Just (DisableExtension MonomorphismRestriction)+      "mono-pat-binds"                 -> Just (EnableExtension  MonoPatBinds)+      "no-mono-pat-binds"              -> Just (DisableExtension MonoPatBinds)+      "allow-undecidable-instances"    -> Just (EnableExtension  UndecidableInstances)+      "no-allow-undecidable-instances" -> Just (DisableExtension UndecidableInstances)+      "allow-incoherent-instances"     -> Just (EnableExtension  IncoherentInstances)+      "no-allow-incoherent-instances"  -> Just (DisableExtension IncoherentInstances)+      "arrows"                         -> Just (EnableExtension  Arrows)+      "no-arrows"                      -> Just (DisableExtension Arrows)+      "generics"                       -> Just (EnableExtension  Generics)+      "no-generics"                    -> Just (DisableExtension Generics)+      "implicit-prelude"               -> Just (EnableExtension  ImplicitPrelude)+      "no-implicit-prelude"            -> Just (DisableExtension ImplicitPrelude)+      "implicit-params"                -> Just (EnableExtension  ImplicitParams)+      "no-implicit-params"             -> Just (DisableExtension ImplicitParams)+      "bang-patterns"                  -> Just (EnableExtension  BangPatterns)+      "no-bang-patterns"               -> Just (DisableExtension BangPatterns)+      "scoped-type-variables"          -> Just (EnableExtension  ScopedTypeVariables)+      "no-scoped-type-variables"       -> Just (DisableExtension ScopedTypeVariables)+      "extended-default-rules"         -> Just (EnableExtension  ExtendedDefaultRules)+      "no-extended-default-rules"      -> Just (DisableExtension ExtendedDefaultRules)+      _                                -> Nothing+    ghcExtension "-cpp"             = Just (EnableExtension CPP)+    ghcExtension _                  = Nothing++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)++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, "data-files")      | path <- dataFiles     pkg ]+      ++ [ (path, "data-dir")        | path <- [dataDir      pkg]]+      ++ concat+         [    [ (path, "c-sources")        | path <- cSources        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 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 compatability "+        ++ "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 compatability "+        ++ "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 compatability 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 "+        ++ "compatability 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 "+        ++ "compatability 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 "+        ++ "compatability 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 "+        ++ "compatability 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 ]++    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, BSD3, BSD4+                     , PublicDomain, AllRightsReserved, 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 presense 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 unboudned 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+                              (CompilerId buildCompilerFlavor (Version [] []))+                              [] 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 filepath.+--+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+  licenseError    <- checkLicenseExists   ops pkg+  setupError      <- checkSetupExists     ops pkg+  configureError  <- checkConfigureExists ops pkg+  localPathErrors <- checkLocalPathsExist ops pkg+  vcsLocation     <- checkMissingVcsInfo  ops pkg++  return $ catMaybes [licenseError, setupError, configureError]+        ++ localPathErrors+        ++ vcsLocation++checkLicenseExists :: Monad m => CheckPackageContentOps m+                   -> PackageDescription+                   -> m (Maybe PackageCheck)+checkLicenseExists ops pkg+  | null (licenseFile pkg) = return Nothing+  | otherwise = do+    exists <- doesFileExist ops file+    return $ check (not exists) $+      PackageBuildWarning $+           "The 'license-file' field refers to the file " ++ quote file+        ++ " which does not exist."++  where+    file = licenseFile pkg++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."+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) ]
+ cabal/cabal/Distribution/PackageDescription/Configuration.hs view
@@ -0,0 +1,618 @@+{-# OPTIONS -cpp #-}+-- OPTIONS required for ghc-6.4.x compat, and must appear first+{-# LANGUAGE CPP #-}+-- -fno-warn-deprecations for use of Map.foldWithKey+{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Configuration+-- Copyright   :  Thomas Schilling, 2007+--+-- 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.++{- 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. -}++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+         , CondTree(..), ConfVar(..), Condition(..), TestSuite(..) )+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.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+import Data.Monoid++#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)+import qualified Text.Read as R+import qualified Text.Read.Lex as L+#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 -> CompilerId -> Condition ConfVar+                      -> (Condition FlagName, [FlagName])+simplifyWithSysParams os arch (CompilerId comp compVer) 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) = Right $ comp' == comp+                                  && compVer `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 constaints 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+  -> CompilerId -- ^ Compiler flavour + version+  -> [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 }+#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)+  deriving (Show, Read)+#else+-- The Show/Read instance for Data.Map in ghc-6.4 is useless+-- so we have to re-implement it here:+instance Show DependencyMap where+  showsPrec d (DependencyMap m) =+      showParen (d > 10) (showString "DependencyMap" . shows (M.toList m))++instance Read DependencyMap where+  readPrec = parens $ R.prec 10 $ do+    R.Ident "DependencyMap" <- R.lexP+    xs <- R.readPrec+    return (DependencyMap (M.fromList xs))+      where parens :: R.ReadPrec a -> R.ReadPrec a+            parens p = optional+             where+               optional  = p R.+++ mandatory+               mandatory = paren optional++            paren :: R.ReadPrec a -> R.ReadPrec a+            paren p = do L.Punc "(" <- R.lexP+                         x          <- R.reset p+                         L.Punc ")" <- R.lexP+                         return x++  readListPrec = R.readListPrecDefault+#endif++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) =+    foldr mappend (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 (removeDisabledTests . snd) targets+    removeDisabledTests :: PDTagged -> Bool+    removeDisabledTests (Lib _) = True+    removeDisabledTests (Exe _ _) = True+    removeDisabledTests (Test _ t) = testEnabled t+    removeDisabledTests 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)])+flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], []) targets+  where+    untag (_, Lib _) (Just _, _, _) = bug "Only one library expected"+    untag (deps, Lib l) (Nothing, exes, tests) = (Just l', exes, tests)+      where+        l' = l {+                libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }+            }+    untag (deps, Exe n e) (mlib, exes, tests)+        | any ((== n) . fst) exes = bug "Exe with same name found"+        | any ((== n) . fst) tests = bug "Test sharing name of exe found"+        | otherwise = (mlib, exes ++ [(n, e')], tests)+      where+        e' = e {+                buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }+            }+    untag (deps, Test n t) (mlib, exes, tests)+        | any ((== n) . fst) tests = bug "Test with same name found"+        | any ((== n) . fst) exes = bug "Test sharing name of exe found"+        | otherwise = (mlib, exes, tests ++ [(n, t')])+      where+        t' = t {+            testBuildInfo = (testBuildInfo t)+                { 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 | 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')+    _ `mappend` _ = bug "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 depenency satisfiable from the set of available packages?+                          -- If this is unknown then use True.+  -> Platform      -- ^ The 'Arch' and 'OS'+  -> CompilerId    -- ^ Compiler + Version+  -> [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) =+    case resolveFlags of+      Right ((mlib, exes', tests'), targetSet, flagVals) ->+        Right ( pkg { library = mlib+                    , executables = exes'+                    , testSuites = tests'+                    , 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++    resolveFlags =+        case resolveWithFlags flagChoices os arch impl constraints condTrees check of+          Right (targetSet, fs) ->+              let (mlib, exes, tests) = flattenTaggedTargets targetSet in+              Right ( (fmap libFillInDefaults mlib,+                       map (\(n,e) -> (exeFillInDefaults e) { exeName = n }) exes,+                       map (\(n,t) -> (testFillInDefaults t) { testName = n }) tests),+                     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     = if all satisfyDep ds+                   then DepOk+                   else MissingDeps $ filter (not . satisfyDep) ds++{-+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) =+    pkg { library = mlib+        , executables = reverse exes+        , testSuites = reverse tests+        , buildDepends = ldeps ++ reverse edeps ++ reverse tdeps+        }+  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+    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 )++-- 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 }++biFillInDefaults :: BuildInfo -> BuildInfo+biFillInDefaults bi =+    if null (hsSourceDirs bi)+    then bi { hsSourceDirs = [currentDir] }+    else bi++bug :: String -> a+bug msg = error $ msg ++ ". Consider this a bug."
+ cabal/cabal/Distribution/PackageDescription/Parse.hs view
@@ -0,0 +1,1074 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PackageDescription.Parse+-- Copyright   :  Isaac Jones 2003-2005+--+-- 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.++{- 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. -}++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)+import Data.Monoid ( Monoid(..) )+import Data.List  (nub, unfoldr, partition, (\\))+import Control.Monad (liftM, foldM, when, unless)+import System.Directory (doesFileExist)++import Distribution.Text+         ( Text(disp, parse), display, simpleParse )+import Distribution.Compat.ReadP+         ((+++), option)+import Text.PrettyPrint.HughesPJ++import Distribution.ParseUtils hiding (parseFields)+import Distribution.PackageDescription+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})+ , simpleField "license-file"+           showFilePath           parseFilePathQ+           licenseFile            (\l pkg -> pkg{licenseFile=l})+ , simpleField "copyright"+           showFreeText           parseFreeText+           copyright              (\val pkg -> pkg{copyright=val})+ , simpleField "maintainer"+           showFreeText           parseFreeText+           maintainer             (\val pkg -> pkg{maintainer=val})+ , commaListField  "build-depends"+           disp                   parse+           buildDepends           (\xs    pkg -> pkg{buildDepends=xs})+ , 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})+ , listField "data-files"+           showFilePath           parseFilePathQ+           dataFiles              (\val pkg -> pkg{dataFiles=val})+ , simpleField "data-dir"+           showFilePath           parseFilePathQ+           dataDir                (\val pkg -> pkg{dataDir=val})+ , listField "extra-source-files"+           showFilePath    parseFilePathQ+           extraSrcFiles          (\val pkg -> pkg{extraSrcFiles=val})+ , listField "extra-tmp-files"+           showFilePath       parseFilePathQ+           extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=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 =+  [ listField "exposed-modules" disp parseModuleNameQ+      exposedModules (\mods lib -> lib{exposedModules=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 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})+ , 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})+ , listField   "c-sources"+           showFilePath       parseFilePathQ+           cSources           (\paths binfo -> binfo{cSources=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})++ , listField   "extra-libraries"+           showToken          parseTokenQ+           extraLibs          (\xs    binfo -> binfo{extraLibs=xs})+ , listField   "extra-lib-dirs"+           showFilePath       parseFilePathQ+           extraLibDirs       (\xs    binfo -> binfo{extraLibDirs=xs})+ , listField   "includes"+           showFilePath       parseFilePathQ+           includes           (\paths binfo -> binfo{includes=paths})+ , listField   "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})+ , listField   "other-modules"+           disp               parseModuleNameQ+           otherModules       (\val binfo -> binfo{otherModules=val})+ , listField   "ghc-prof-options"+           text               parseTokenQ+           ghcProfOptions        (\val binfo -> binfo{ghcProfOptions=val})+ , listField   "ghc-shared-options"+           text               parseTokenQ+           ghcSharedOptions      (\val binfo -> binfo{ghcSharedOptions=val})+ , optsField   "ghc-options"  GHC+           options            (\path  binfo -> binfo{options=path})+ , optsField   "hugs-options" Hugs+           options            (\path  binfo -> binfo{options=path})+ , optsField   "nhc98-options"  NHC+           options            (\path  binfo -> binfo{options=path})+ , optsField   "jhc-options"  JHC+           options            (\path  binfo -> binfo{options=path})+ ]++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+  when (not 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 fs = mapM walk fs+  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 [Dependency]+parseConstraint (F l n v)+    | n == "build-depends" = runP l n (parseCommaList parse) v+parseConstraint f = bug $ "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 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 = runStT st s >>= return . fst++-- 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 = get >>= return . listToMaybe++-- 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) <- 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++  where+    oldSyntax flds = all isSimpleField flds+    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 implementatition 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 _ = bug "unexpeced 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)])+    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) <- getBody+            return (repos, flags, lib, (exename, flds): exes, tests)++        | 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) <- getBody+                    return (repos, flags, lib, exes, (testname, flds) : tests)+                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 == "library" -> do+            when (not (null sec_label)) $ lift $+              syntaxError line_no "'library' expects no argument"+            flds <- collectFields parseLibFields sec_fields+            skipField+            (repos, flags, lib, exes, tests) <- 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)++        | 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) <- getBody+            return (repos, flag:flags, lib, exes, tests)++        | 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) <- getBody+            return (repo:repos, flags, lib, exes, tests)++        | otherwise -> do+            lift $ warning $ "Ignoring unknown section type: " ++ sec_type+            skipField+            getBody+      Just f -> do+            _ <- lift $ syntaxError (lineNo f) $+              "Construct not supported at this position: " ++ 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 ]++        let (depFlds, dataFlds) = partition isConstraint simplFlds++        a <- parser dataFlds+        deps <- liftM concat . mapM (lift . 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 _ = bug "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++    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+        when (not . 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+       when (not (null unknowns)) $ do+         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 _ _ _ _ = bug "'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 _ = bug "'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 (_:_) = bug "`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 . 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" ]++bug :: String -> a+bug msg = error $ msg ++ ". Consider this a bug."
+ cabal/cabal/Distribution/PackageDescription/PrettyPrint.hs view
@@ -0,0 +1,238 @@+-----------------------------------------------------------------------------+--+-- Module      :  Distribution.PackageDescription.PrettyPrint+-- Copyright   :  Jürgen Nicklisch-Franken 2010+-- License     :  AllRightsReserved+--+-- Maintainer  : cabal-devel@haskell.org+-- Stability   : provisional+-- Portability : portable+--+-- | Pretty printing for cabal files+--+-----------------------------------------------------------------------------+{- 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. -}++module Distribution.PackageDescription.PrettyPrint (+    writeGenericPackageDescription,+    showGenericPackageDescription,+) where++import Distribution.PackageDescription+       ( TestSuite(..), TestSuiteInterface(..), testType+       , SourceRepo(..),+        customFieldsBI, CondTree(..), Condition(..),+        FlagName(..), ConfVar(..), Executable(..), Library(..),+        Flag(..), PackageDescription(..),+        GenericPackageDescription(..))+import Text.PrettyPrint+       (hsep, comma, punctuate, fsep, parens, char, nest, empty,+        isEmpty, ($$), (<+>), colon, (<>), text, vcat, ($+$), Doc, render)+import Distribution.Simple.Utils (writeUTF8File)+import Distribution.ParseUtils (showFreeText, FieldDescr(..))+import Distribution.PackageDescription.Parse (pkgDescrFieldDescrs,binfoFieldDescrs,libFieldDescrs,+       sourceRepoFieldDescrs)+import Distribution.Package (Dependency(..))+import Distribution.Text (Text(..))+import Data.Maybe (isJust, fromJust, isNothing)++indentWith :: Int+indentWith = 4++-- | 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)++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"]++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+                      | otherwise        = text name <> colon <+> fielddoc++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 (MkFlag name desc dflt manual)    =+    emptyLine $ text "flag" <+> ppFlagName name $+$+            (nest indentWith ((if null desc+                                then empty+                                else  text "Description: " <+> showFreeText desc) $+$+                     (if dflt then empty else text "Default: False") $+$+                     (if manual then text "Manual: True" else empty)))++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     = ppFields 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')+            $+$ ppFields 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 =+                text "type:" <+> disp (testType testsuite)+            $+$ maybe empty (\f -> text "main-is:"     <+> text f)+                            (testSuiteMainIs testsuite)+            $+$ maybe empty (\m -> text "test-module:" <+> disp m)+                            (testSuiteModule testsuite)+            $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)+            $+$ ppCustomFields (customFieldsBI (testBuildInfo 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++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 deps ifs) mbIt ppIt =+    let res = ppDeps deps+                $+$ (vcat $ map ppIf ifs)+                $+$ ppIt it mbIt+    in if isJust mbIt && isEmpty res+        then ppCondTree ct Nothing ppIt+        else res+  where+    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))++ppDeps :: [Dependency] -> Doc+ppDeps []                                = empty+ppDeps deps                              =+    text "build-depends:" <+> fsep (punctuate comma (map disp deps))++emptyLine :: Doc -> Doc+emptyLine d                              = text " " $+$ d+++
+ cabal/cabal/Distribution/ParseUtils.hs view
@@ -0,0 +1,715 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.ParseUtils+-- Copyright   :  (c) The University of Glasgow 2004+--+-- 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.++{- 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 the University 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. -}++-- This module is meant to be local-only to Distribution...++-- #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, 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, spaceListField, commaListField,+        optsField, liftField, boolField, parseQuoted,++        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, intercalate, lowercase, normaliseLineEndings )+import Language.Haskell.Extension+         ( Language, Extension )++import Text.PrettyPrint.HughesPJ 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)+import System.FilePath (normalise)+import Data.List (sortBy)++-- -----------------------------------------------------------------------------++type LineNo = Int++data PError = AmbigousParse String LineNo+            | NoParse String LineNo+            | TabsError LineNo+            | FromString String (Maybe LineNo)+        deriving Show++data PWarning = PWarning String+              | UTFWarning LineNo String+        deriving 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 Monad ParseResult where+        return x = ParseOk [] x+        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 (AmbigousParse fieldname line)+    _   -> ParseFailed (AmbigousParse 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 (AmbigousParse 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 (\b -> showF (get b))+        (\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++commaListField :: String -> (a -> Doc) -> (ReadP [a] a)+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+commaListField name showF readF get set =+  liftField get set' $+    field name (fsep . punctuate comma . map showF) (parseCommaList readF)+  where+    set' xs b = set (get b ++ xs) b++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 (fsep . map showF) (parseSpaceList readF)+  where+    set' xs b = set (get b ++ xs) b++listField :: String -> (a -> Doc) -> (ReadP [a] a)+                 -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b+listField name showF readF get set =+  liftField get set' $+    field name (fsep . map showF) (parseOptCommaList readF)+  where+    set' xs b = set (get b ++ xs) b++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 (hsep . map text)+                   (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)++-- 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 framwork!+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 = text name <> colon <+> fielddoc++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)++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 _ x = Just x++------------------------------------------------------------------------------++-- The data type for our three syntactic categories+data Field+    = F LineNo String String+      -- ^ A regular @<property>: <value>@ field+    | Section LineNo String String [Field]+      -- ^ A section with a name and possible parameter.  The syntactic+      -- structure is:+      --+      -- @+      --   <sectionname> <arg> {+      --     <field>*+      --   }+      -- @+    | IfBlock LineNo String [Field] [Field]+      -- ^ A conditional block with an optional else branch:+      --+      -- @+      --  if <condition> {+      --    <field>*+      --  } else {+      --    <field>*+      --  }+      -- @+      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 inbetween.+-- 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 = reverse . dropWhile isSpace . reverse+++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 backets, unexpected {"+    CloseBracket n:_ -> syntaxError n "mismatched backets, 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++parseBuildTool :: ReadP r Dependency+parseBuildTool = do name <- parseBuildToolNameQ+                    skipSpaces+                    ver <- parseVersionRangeQ <++ return anyVersion+                    skipSpaces+                    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` "+-._")+                              skipSpaces+                              ver <- parseVersionRangeQ <++ return anyVersion+                              skipSpaces+                              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{ versionBranch=[], versionTags=[] }++parseTestedWithQ :: ReadP r (CompilerFlavor,VersionRange)+parseTestedWithQ = parseQuoted tw <++ tw+  where+    tw :: ReadP r (CompilerFlavor,VersionRange)+    tw = do compiler <- parseCompilerFlavorCompat+            skipSpaces+            version <- parse <++ return anyVersion+            skipSpaces+            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 (\x -> not (isSpace x))++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 = skipSpaces >> sepr >> skipSpaces++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 p = between (ReadP.char '"') (ReadP.char '"') p++parseFreeText :: ReadP.ReadP s String+parseFreeText = ReadP.munch (const True)++-- --------------------------------------------+-- ** Pretty printing++showFilePath :: FilePath -> Doc+showFilePath = showToken++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 ('\n' :r)  = text " " $+$ text "." $+$ showFreeText r+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''
+ cabal/cabal/Distribution/ReadE.hs view
@@ -0,0 +1,81 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.ReadE+-- Copyright   :  Jose Iborra 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Simple parsing with failure++{- Copyright (c) 2007, Jose Iborra+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. -}++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/cabal/Distribution/Simple.hs view
@@ -0,0 +1,677 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple+-- Copyright   :  Isaac Jones 2003-2005+--+-- 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.++{- 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. -}++{-+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 moule.+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 )+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.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, getEnvironment)+import System.Directory(removeFile, doesFileExist,+                        doesDirectoryExist, removeDirectoryRecursive)+import System.Exit+import System.IO.Error   (isDoesNotExistError)+import Distribution.Compat.Exception (catchIO, throwIOIO)++import Control.Monad   (when)+import Data.List       (intersperse, 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 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 (concat (intersperse "\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+      ,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+      ]++-- | 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 args++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+    --FIXME: this is a hack, passing the args inside the flags+    -- it's because the args to not get passed to the main test hook+    let flags' = flags { testList = Flag args }+    hookedAction preTest testHook postTest+            (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 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 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 conigure 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 if isFile then removeFile fname+              else return ()+        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,+       copyHook  = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params+       testHook = defaultTestHook,+       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:+    -- http://hackage.haskell.org/trac/hackage/ticket/165+    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    = readHook buildVerbosity,+       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 throwIOIO 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 :: PackageDescription -> LocalBuildInfo+                -> UserHooks -> TestFlags -> IO ()+defaultTestHook pkg_descr localbuildinfo _ flags =+    test 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)++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/cabal/Distribution/Simple/Build.hs view
@@ -0,0 +1,274 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Build+-- Copyright   :  Isaac Jones 2003-2005,+--                Ross Paterson 2006,+--                Duncan Coutts 2007-2008+--+-- 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.+--++{- Copyright (c) 2003-2005, Isaac Jones+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. -}++module Distribution.Simple.Build (+    build,++    initialBuildSteps,+    writeAutogenFiles,+  ) where++import qualified Distribution.Simple.GHC  as GHC+import qualified Distribution.Simple.JHC  as JHC+import qualified Distribution.Simple.LHC  as LHC+import qualified Distribution.Simple.NHC  as NHC+import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC++import qualified Distribution.Simple.Build.Macros      as Build.Macros+import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule++import Distribution.Package+         ( Package(..), PackageName(..), PackageIdentifier(..)+         , thisPackageVersion )+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )+import Distribution.PackageDescription+         ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)+         , TestSuite(..), TestSuiteInterface(..) )+import qualified Distribution.InstalledPackageInfo as IPI+import qualified Distribution.ModuleName as ModuleName++import Distribution.Simple.Setup+         ( BuildFlags(..), fromFlag )+import Distribution.Simple.PreProcess+         ( preprocessComponent, PPSuffixHandler )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(compiler, buildDir, withPackageDB)+         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI+         , inplacePackageId )+import Distribution.Simple.BuildPaths+         ( autogenModulesDir, autogenModuleName, cppHeaderName )+import Distribution.Simple.Register+         ( registerPackage, inplaceInstalledPackageInfo )+import Distribution.Simple.Test ( stubFilePath, stubName )+import Distribution.Simple.Utils+         ( createDirectoryIfMissingVerbose, rewriteFile+         , die, info, setupMessage )++import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text+         ( display )++import Data.Maybe+         ( maybeToList )+import Control.Monad+         ( unless )+import System.FilePath+         ( (</>), (<.>) )+import System.Directory+         ( getCurrentDirectory )++-- -----------------------------------------------------------------------------+-- |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)+  initialBuildSteps distPref pkg_descr lbi verbosity+  setupMessage verbosity "Building" (packageId pkg_descr)++  internalPackageDB <- createInternalPackageDB distPref++  let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes+      lbi'  = lbi {withPackageDB = withPackageDB lbi ++ [internalPackageDB]}+              -- Use the internal package DB for the exes.+  withComponentsLBI pkg_descr lbi $ \comp clbi -> do+    pre comp+    case comp of+      CLib lib -> do+        info verbosity "Building library..."+        buildLib verbosity pkg_descr lbi lib clbi++        -- Register the library in-place, so exes can depend+        -- on internally defined libraries.+        pwd <- getCurrentDirectory+        let installedPkgInfo =+              (inplaceInstalledPackageInfo pwd distPref pkg_descr lib lbi clbi) {+                -- The inplace registration uses the "-inplace" suffix,+                -- not an ABI hash.+                IPI.installedPackageId = inplacePackageId (packageId installedPkgInfo)+              }+        registerPackage verbosity+          installedPkgInfo pkg_descr lbi True -- True meaning inplace+          (withPackageDB lbi ++ [internalPackageDB])++      CExe exe -> do+        info verbosity $ "Building executable " ++ exeName exe ++ "..."+        buildExe verbosity pkg_descr lbi' exe clbi++      CTest test -> do+        case testInterface test of+            TestSuiteExeV10 _ f -> do+                let exe = Executable+                        { exeName = testName test+                        , modulePath = f+                        , buildInfo = testBuildInfo test+                        }+                info verbosity $ "Building test suite " ++ testName test ++ "..."+                buildExe verbosity pkg_descr lbi' exe clbi+            TestSuiteLibV09 _ m -> do+                pwd <- getCurrentDirectory+                let lib = Library+                        { exposedModules = [ m ]+                        , libExposed = True+                        , libBuildInfo = testBuildInfo test+                        }+                    pkg = pkg_descr+                        { package = (package pkg_descr)+                            { pkgName = PackageName $ testName test+                            }+                        , buildDepends = targetBuildDepends $ testBuildInfo test+                        , executables = []+                        , testSuites = []+                        , library = Just lib+                        }+                    ipi = (inplaceInstalledPackageInfo+                        pwd distPref pkg lib lbi clbi)+                        { IPI.installedPackageId = inplacePackageId $ packageId ipi+                        }+                    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)+                            }+                        }+                    -- | The stub executable needs a new 'ComponentLocalBuildInfo'+                    -- that exposes the relevant test suite library.+                    exeClbi = clbi+                        { componentPackageDeps =+                            (IPI.installedPackageId ipi, packageId ipi)+                            : (filter (\(_, x) -> let PackageName name = pkgName x in name == "Cabal" || name == "base")+                                $ componentPackageDeps clbi)+                        }+                info verbosity $ "Building test suite " ++ testName test ++ "..."+                buildLib verbosity pkg lbi' lib clbi+                registerPackage verbosity ipi pkg lbi' True $ withPackageDB lbi'+                buildExe verbosity pkg_descr lbi' exe exeClbi+            TestSuiteUnsupported tt -> die $ "No support for building test suite "+                                          ++ "type " ++ display tt++-- | Initialize a new package db file for libraries defined+-- internally to the package.+createInternalPackageDB :: FilePath -> IO PackageDB+createInternalPackageDB distPref = do+    let dbFile = distPref </> "package.conf.inplace"+        packageDB = SpecificPackageDB dbFile+    writeFile dbFile "[]"+    return packageDB++-- TODO: build separate libs in separate dirs so that we can build+-- multiple libs, e.g. for 'LibTest' library-style testsuites+buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib verbosity pkg_descr lbi lib clbi =+  case compilerFlavor (compiler lbi) of+    GHC  -> GHC.buildLib  verbosity pkg_descr lbi lib clbi+    JHC  -> JHC.buildLib  verbosity pkg_descr lbi lib clbi+    LHC  -> LHC.buildLib  verbosity pkg_descr lbi lib clbi+    Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi+    NHC  -> NHC.buildLib  verbosity pkg_descr lbi lib clbi+    UHC  -> UHC.buildLib  verbosity pkg_descr lbi lib clbi+    _    -> die "Building is not supported with this compiler."++buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe verbosity pkg_descr lbi exe clbi =+  case compilerFlavor (compiler lbi) of+    GHC  -> GHC.buildExe  verbosity pkg_descr lbi exe clbi+    JHC  -> JHC.buildExe  verbosity pkg_descr lbi exe clbi+    LHC  -> LHC.buildExe  verbosity pkg_descr lbi exe clbi+    Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi+    NHC  -> NHC.buildExe  verbosity pkg_descr lbi exe clbi+    UHC  -> UHC.buildExe  verbosity pkg_descr lbi exe clbi+    _    -> die "Building is not supported with 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_<pkg>.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)
+ cabal/cabal/Distribution/Simple/Build/Macros.hs view
@@ -0,0 +1,57 @@+-----------------------------------------------------------------------------+-- |+-- 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_<package>+-- > MIN_VERSION_<package>(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+  ) where++import Distribution.Package+         ( PackageIdentifier(PackageIdentifier) )+import Distribution.Version+         ( Version(versionBranch) )+import Distribution.PackageDescription+         ( PackageDescription )+import Distribution.Simple.LocalBuildInfo+        ( LocalBuildInfo, externalPackageDeps )+import Distribution.Text+         ( display )++-- ------------------------------------------------------------+-- * Generate cabal_macros.h+-- ------------------------------------------------------------++generate :: PackageDescription -> LocalBuildInfo -> String+generate _pkg_descr lbi = concat $+  "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" :+  [ concat+    ["/* package ",display pkgid," */\n"+    ,"#define VERSION_",pkgname," ",show (display version),"\n"+    ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"+    ,"  (major1) <  ",major1," || \\\n"+    ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+    ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+    ,"\n\n"+    ]+  | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi+  , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)+        pkgname = map fixchar (display name)+  ]+  where fixchar '-' = '_'+        fixchar c   = c+
+ cabal/cabal/Distribution/Simple/Build/PathsModule.hs view
@@ -0,0 +1,258 @@+-----------------------------------------------------------------------------+-- |+-- 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 )+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.Text+         ( display )+import Distribution.Version+         ( Version(..), orLaterVersion, withinRange )++import System.FilePath+         ( pathSeparator )+import Data.Maybe+         ( fromJust, isNothing )++-- ------------------------------------------------------------+-- * Building Paths_<pkg>.hs+-- ------------------------------------------------------------++generate :: PackageDescription -> LocalBuildInfo -> String+generate pkg_descr lbi =+   let pragmas+        | absolute || isHugs = ""+        | supports_language_pragma =+          "{-# LANGUAGE ForeignFunctionInterface #-}\n"+        | otherwise =+          "{-# OPTIONS_GHC -fffi #-}\n"+++          "{-# OPTIONS_JHC -fffi #-}\n"++       foreign_imports+        | absolute = ""+        | isHugs = "import System.Environment\n"+        | otherwise =+          "import Foreign\n"+++          "import Foreign.C\n"++       header =+        pragmas+++        "module " ++ display paths_modulename ++ " (\n"+++        "    version,\n"+++        "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"+++        "    getDataFileName\n"+++        "  ) where\n"+++        "\n"+++        foreign_imports+++        "import qualified Control.Exception as Exception\n"+++        "import Data.Version (Version(..))\n"+++        "import System.Environment (getEnv)"+++        "\n"+++        "catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a\n"+++        "catchIO = Exception.catch\n" +++        "\n"+++        "\nversion :: Version"+++        "\nversion = " ++ show (packageVersion pkg_descr)++       body+        | absolute =+          "\nbindir, libdir, datadir, libexecdir :: FilePath\n"+++          "\nbindir     = " ++ show flat_bindir +++          "\nlibdir     = " ++ show flat_libdir +++          "\ndatadir    = " ++ show flat_datadir +++          "\nlibexecdir = " ++ show flat_libexecdir +++          "\n"+++          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: 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"+++          "\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"+++          "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+        } = absoluteInstallDirs pkg_descr lbi NoCopyDest+        InstallDirs {+          bindir     = flat_bindirrel,+          libdir     = flat_libdirrel,+          datadir    = flat_datadirrel,+          libexecdir = flat_libexecdirrel,+          progdir    = flat_progdirrel+        } = prefixRelativeInstallDirs (packageId pkg_descr) lbi++        mkGetDir _   (Just dirrel) = "getPrefixDirRel " ++ show dirrel+        mkGetDir dir Nothing       = "return " ++ show dir++        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+          || (isHugs && isNothing flat_progdirrel)+          || not (supportsRelocatableProgs (compilerFlavor (compiler lbi)))++        supportsRelocatableProgs Hugs = True+        supportsRelocatableProgs GHC  = case buildOS of+                           Windows   -> True+                           _         -> False+        supportsRelocatableProgs _    = False++        paths_modulename = autogenModuleName pkg_descr++        isHugs = compilerFlavor (compiler lbi) == Hugs+        get_prefix_stuff+          | isHugs    = "progdirrel :: String\n"+++                        "progdirrel = "++show (fromJust flat_progdirrel)++"\n\n"+++                        get_prefix_hugs+          | otherwise = get_prefix_win32++        path_sep = show [pathSeparator]++        supports_language_pragma =+          compilerFlavor (compiler lbi) == GHC &&+            (compilerVersion (compiler lbi)+              `withinRange` orLaterVersion (Version [6,6,1] []))++-- | Generates the name of the environment variable controlling the path+-- component of interest.+pkgPathEnvVar :: PackageDescription+              -> String     -- ^ path component; one of \"bindir\", \"libdir\",+                            -- \"datadir\" or \"libexecdir\"+              -> String     -- ^ environment variable name+pkgPathEnvVar pkg_descr var =+    showPkgName (packageName pkg_descr) ++ "_" ++ var+    where+        showPkgName = map fixchar . display+        fixchar '-' = '_'+        fixchar c   = c++get_prefix_win32 :: String+get_prefix_win32 =+  "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 stdcall unsafe \"windows.h GetModuleFileNameW\"\n"+++  "  c_GetModuleFileName :: Ptr () -> CWString -> Int32 -> IO Int32\n"+++get_prefix_hugs :: String+get_prefix_hugs =+  "getPrefixDirRel :: FilePath -> IO FilePath\n"+++  "getPrefixDirRel dirRel = do\n"+++  "  mainPath <- getProgName\n"+++  "  let (progPath,_) = splitFileName mainPath\n"+++  "  let (progdir,_) = splitFileName progPath\n"+++  "  return ((progdir `minusFileName` progdirrel) `joinFileName` dirRel)\n"++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/cabal/Distribution/Simple/BuildPaths.hs view
@@ -0,0 +1,150 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.BuildPaths+-- Copyright   :  Isaac Jones 2003-2004,+--                Duncan Coutts 2008+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A bunch of dirs, paths and file names used for intermediate build steps.+--++{- 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. -}++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+         ( PackageIdentifier, 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))+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 :: PackageIdentifier -> String+mkLibName lib = "libHS" ++ display lib <.> "a"++mkProfLibName :: PackageIdentifier -> String+mkProfLibName lib =  "libHS" ++ display lib ++ "_p" <.> "a"++-- Implement proper name mangling for dynamical shared objects+-- libHS<packagename>-<compilerFlavour><compilerVersion>+-- e.g. libHSbase-2.1-ghc6.6.1.so+mkSharedLibName :: PackageIdentifier -> CompilerId -> String+mkSharedLibName lib (CompilerId compilerFlavor compilerVersion)+  = "libHS" ++ display 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 and NHC the extension is @\"o\"@.+-- Hugs uses either @\"o\"@ or @\"obj\"@ depending on the used C compiler.+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/cabal/Distribution/Simple/Command.hs view
@@ -0,0 +1,545 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Command+-- Copyright   :  Duncan Coutts 2007+--+-- 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@.++{- 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. -}++module Distribution.Simple.Command (++  -- * Command interface+  CommandUI(..),+  commandShowOptions,+  CommandParse(..),+  commandParseArgs,++  -- ** Constructing commands+  ShowOrParseArgs(..),+  makeCommand,++  -- ** 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+import Data.Monoid+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.HughesPJ    ( punctuate, cat, comma, text, 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,+    -- | The useage line summary for this command+    commandUsage    :: String -> String,+    -- | Additional explanation of the command to use in help texts.+    commandDescription :: 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 datatype 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 datatype.+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) (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+          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 t = case optDescr of+                    ReqArg _ _ _ _ ppr ->+                     (cat . punctuate comma . map text . ppr) t+                    OptArg _ _ _ _ _ ppr ->+                     case ppr t of+                        []        -> empty+                        (Nothing : _) -> text "True"+                        (Just a  : _) -> text a+                    ChoiceOpt alts ->+                     fromMaybe empty $ listToMaybe+                         [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]+                    BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t+          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 _ _ -> -- The behaviour in this case is not clear, and it has no use so far,+                                               -- so we avoid future surprises by not implementing it.+                                               error "Command.optionToFieldDescr: feature not implemented"++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+    showOptDescr :: a -> OptDescr a -> [String]+    showOptDescr x (BoolOpt _ (_,lfT:_) (_,lfF:_) _ enabled)+      = case enabled x of+          Nothing -> []+          Just True  -> ["--" ++ lfT]+          Just False -> ["--" ++ lfF]+    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 =+    commandUsage command pname+ ++ (GetOpt.usageInfo ""+  . addCommonFlags ShowArgs+  $ commandGetOpts ShowArgs command)+ ++ case commandDescription command of+      Nothing   -> ""+      Just desc -> '\n': desc pname++-- | Make a Command from standard 'GetOpt' options.+makeCommand :: String                         -- ^ name+            -> String                         -- ^ short description+            -> Maybe (String -> String)       -- ^ long description+            -> flags                          -- ^ initial\/empty flags+            -> (ShowOrParseArgs -> [OptionField flags]) -- ^ options+            -> CommandUI flags+makeCommand name shortDesc longDesc defaultFlags options =+  CommandUI {+    commandName         = name,+    commandSynopsis     = shortDesc,+    commandDescription  = longDesc,+    commandUsage        = usage,+    commandDefaultFlags = defaultFlags,+    commandOptions      = options+  }+  where usage pname = "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n\n"+                   ++ "Flags for " ++ name ++ ":"++-- | 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 compsition is right to left.+        accum flags = foldr (flip (.)) id [ f | Right f <- flags ]+        unrecognised opts = [ "unrecognized 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 Command action = Command String String ([String] -> CommandParse action)++commandAddAction :: CommandUI flags+                 -> (flags -> [String] -> action)+                 -> Command action+commandAddAction command action =+  Command (commandName command)+          (commandSynopsis command)+          (fmap (uncurry applyDefaultArgs)+         . commandParseArgs command False)++  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 _ _ <- commands' ]+    globalCommand' = globalCommand {+      commandUsage = \pname ->+           (case commandUsage globalCommand pname of+             ""       -> ""+             original -> original ++ "\n")+        ++ "Usage: " ++ pname ++ " COMMAND [FLAGS]\n"+        ++ "   or: " ++ pname ++ " [GLOBAL FLAGS]\n\n"+        ++ "Global flags:",+      commandDescription = Just $ \pname ->+           "Commands:\n"+        ++ unlines [ "  " ++ align name ++ "    " ++ description+                   | Command name description _ <- commands' ]+        ++ case commandDescription globalCommand of+             Nothing   -> ""+             Just desc -> '\n': desc pname+    }+      where maxlen = maximum [ length name | Command name _ _ <- commands' ]+            align str = str ++ replicate (maxlen - length str) ' '++    -- 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'+    helpCommandUI =+      (makeCommand "help" "Help about commands" Nothing () (const [])) {+        commandUsage = \pname ->+             "Usage: " ++ pname ++ " help [FLAGS]\n"+          ++ "   or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"+          ++ "Flags for help:"+      }++-- | 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]
+ cabal/cabal/Distribution/Simple/Compiler.hs view
@@ -0,0 +1,194 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Compiler+-- Copyright   :  Isaac Jones 2003-2004+--+-- 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.++{- 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. -}++module Distribution.Simple.Compiler (+        -- * Haskell implementations+        module Distribution.Compiler,+        Compiler(..),+        showCompilerId, compilerFlavor, compilerVersion,++        -- * Support for package databases+        PackageDB(..),+        PackageDBStack,+        registrationPackageDB,++        -- * Support for optimisation levels+        OptimisationLevel(..),+        flagToOptimisationLevel,++        -- * Support for language extensions+        Flag,+        languageToFlags,+        unsupportedLanguages,+        extensionsToFlags,+        unsupportedExtensions+  ) where++import Distribution.Compiler+import Distribution.Version (Version(..))+import Distribution.Text (display)+import Language.Haskell.Extension (Language(Haskell98), Extension)++import Data.List (nub)+import Data.Maybe (catMaybes, isNothing)++data Compiler = Compiler {+        compilerId              :: CompilerId,+        compilerLanguages       :: [(Language, Flag)],+        compilerExtensions      :: [(Extension, Flag)]+    }+    deriving (Show, Read)++showCompilerId :: Compiler -> String+showCompilerId = display . compilerId++compilerFlavor ::  Compiler -> CompilerFlavor+compilerFlavor = (\(CompilerId f _) -> f) . compilerId++compilerVersion :: Compiler -> Version+compilerVersion = (\(CompilerId _ v) -> v) . compilerId++-- ------------------------------------------------------------+-- * 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, Ord, Show, Read)++-- | 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++-- ------------------------------------------------------------+-- * Optimisation levels+-- ------------------------------------------------------------++-- | Some compilers support optimising. Some have different levels.+-- For compliers that do not the level is just capped to the level+-- they do support.+--+data OptimisationLevel = NoOptimisation+                       | NormalOptimisation+                       | MaximumOptimisation+    deriving (Eq, Show, Read, Enum, Bounded)++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++-- ------------------------------------------------------------+-- * 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)
+ cabal/cabal/Distribution/Simple/Configure.hs view
@@ -0,0 +1,1036 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Configure+-- Copyright   :  Isaac Jones 2003-2005+--+-- 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.++{- 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. -}++module Distribution.Simple.Configure (configure,+                                      writePersistBuildConfig,+                                      getPersistBuildConfig,+                                      checkPersistBuildConfigOutdated,+                                      maybeGetPersistBuildConfig,+                                      localBuildInfoFile,+                                      getInstalledPackages,+                                      configCompiler, configCompilerAux,+                                      ccLdOptionsBuildInfo,+                                      tryGetConfigStateFile,+                                      checkForeignDeps,+                                     )+    where++import Distribution.Simple.Compiler+    ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion+    , showCompilerId, unsupportedLanguages, unsupportedExtensions+    , PackageDB(..), PackageDBStack )+import Distribution.Package+    ( PackageName(PackageName), PackageIdentifier(..), PackageId+    , packageName, packageVersion, Package(..)+    , Dependency(Dependency), simplifyDependency+    , InstalledPackageId(..) )+import Distribution.InstalledPackageInfo as Installed+    ( InstalledPackageInfo, InstalledPackageInfo_(..)+    , emptyInstalledPackageInfo )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.PackageDescription as PD+    ( PackageDescription(..), specVersion, GenericPackageDescription(..)+    , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions+    , HookedBuildInfo, updatePackageDescription, allBuildInfo+    , FlagName(..), TestSuite(..) )+import Distribution.PackageDescription.Configuration+    ( finalizePackageDescription, mapTreeData )+import Distribution.PackageDescription.Check+    ( PackageCheck(..), checkPackage, checkPackageFiles )+import Distribution.Simple.Hpc ( enableCoverage )+import Distribution.Simple.Program+    ( Program(..), ProgramLocation(..), ConfiguredProgram(..)+    , ProgramConfiguration, defaultProgramConfiguration+    , configureAllKnownPrograms, knownPrograms, lookupKnownProgram, addKnownProgram+    , userSpecifyArgss, userSpecifyPaths+    , requireProgram, requireProgramVersion+    , pkgConfigProgram, gccProgram, rawSystemProgramStdoutConf )+import Distribution.Simple.Setup+    ( ConfigFlags(..), CopyDest(..), fromFlag, fromFlagOrDefault, flagToMaybe )+import Distribution.Simple.InstallDirs+    ( InstallDirs(..), defaultInstallDirs, combineInstallDirs )+import Distribution.Simple.LocalBuildInfo+    ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+    , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId+    , allComponentsBy, Component(..), foldComponent, ComponentName(..) )+import Distribution.Simple.BuildPaths+    ( autogenModulesDir )+import Distribution.Simple.Utils+    ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose+    , intercalate, cabalVersion+    , withFileContents, writeFileAtomic+    , withTempFile )+import Distribution.System+    ( OS(..), buildOS, 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.JHC  as JHC+import qualified Distribution.Simple.LHC  as LHC+import qualified Distribution.Simple.NHC  as NHC+import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC++import Control.Monad+    ( when, unless, foldM, filterM, forM )+import Data.List+    ( nub, partition, isPrefixOf, inits, find )+import Data.Maybe+    ( isNothing, catMaybes, mapMaybe )+import Data.Monoid+    ( Monoid(..) )+import Data.Graph+    ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR )+import System.Directory+    ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory )+import System.Exit+    ( ExitCode(..), exitWith )+import System.FilePath+    ( (</>), isAbsolute )+import qualified System.Info+    ( compilerName, compilerVersion )+import System.IO+    ( hPutStrLn, stderr, hClose )+import Distribution.Text+    ( Text(disp), display, simpleParse )+import Text.PrettyPrint.HughesPJ+    ( comma, punctuate, render, nest, sep )+import Distribution.Compat.Exception ( catchExit, catchIO )++import Prelude hiding (catch)++tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)+tryGetConfigStateFile filename = do+  exists <- doesFileExist filename+  if not exists+    then return (Left missing)+    else withFileContents filename $ \str ->+      case lines str of+        [headder, rest] -> case checkHeader headder of+          Just msg -> return (Left msg)+          Nothing  -> case reads rest of+            [(bi,_)] -> return (Right bi)+            _        -> return (Left cantParse)+        _            -> return (Left cantParse)+  where+    checkHeader :: String -> Maybe String+    checkHeader header = case parseHeader header of+      Just (cabalId, compId)+        | cabalId+       == currentCabalId -> Nothing+        | otherwise      -> Just (badVersion cabalId compId)+      Nothing            -> Just cantParse++    missing   = "Run the 'configure' command first."+    cantParse = "Saved package config file seems to be corrupt. "+             ++ "Try re-running the 'configure' command."+    badVersion cabalId compId+              = "You need to re-run the 'configure' command. "+             ++ "The version of Cabal being used has changed (was "+             ++ display cabalId ++ ", now "+             ++ display currentCabalId ++ ")."+             ++ badcompiler compId+    badcompiler compId | compId == currentCompilerId = ""+                       | otherwise+              = " Additionally the compiler is different (was "+             ++ display compId ++ ", now "+             ++ display currentCompilerId+             ++ ") which is probably the cause of the problem."++-- internal function+tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)+tryGetPersistBuildConfig distPref+    = tryGetConfigStateFile (localBuildInfoFile distPref)++-- |Read the 'localBuildInfoFile'.  Error if it doesn't exist.  Also+-- fail if the file containing LocalBuildInfo is older than the .cabal+-- file, indicating that a re-configure is required.+getPersistBuildConfig :: FilePath -> IO LocalBuildInfo+getPersistBuildConfig distPref = do+  lbi <- tryGetPersistBuildConfig distPref+  either die return lbi++-- |Try to read the 'localBuildInfoFile'.+maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)+maybeGetPersistBuildConfig distPref = do+  lbi <- tryGetPersistBuildConfig distPref+  return $ either (const Nothing) Just lbi++-- |After running configure, output the 'LocalBuildInfo' to the+-- 'localBuildInfoFile'.+writePersistBuildConfig :: FilePath -> LocalBuildInfo -> IO ()+writePersistBuildConfig distPref lbi = do+  createDirectoryIfMissing False distPref+  writeFileAtomic (localBuildInfoFile distPref)+                  (showHeader pkgid ++ '\n' : show lbi)+  where+    pkgid   = packageId (localPkgDescr lbi)++showHeader :: PackageIdentifier -> String+showHeader pkgid =+     "Saved package config for " ++ display pkgid+  ++ " written by " ++ display currentCabalId+  ++      " using " ++ display currentCompilerId+  where++currentCabalId :: PackageIdentifier+currentCabalId = PackageIdentifier (PackageName "Cabal") cabalVersion++currentCompilerId :: PackageIdentifier+currentCompilerId = PackageIdentifier (PackageName System.Info.compilerName)+                                      System.Info.compilerVersion++parseHeader :: String -> Maybe (PackageIdentifier, PackageIdentifier)+parseHeader header = case words header of+  ["Saved", "package", "config", "for", pkgid,+   "written", "by", cabalid, "using", compilerid]+    -> case (simpleParse pkgid :: Maybe PackageIdentifier,+             simpleParse cabalid,+             simpleParse compilerid) of+        (Just _,+         Just cabalid',+         Just compilerid') -> Just (cabalid', compilerid')+        _                  -> Nothing+  _                        -> Nothing++-- |Check that localBuildInfoFile is up-to-date with respect to the+-- .cabal file.+checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool+checkPersistBuildConfigOutdated distPref pkg_descr_file = do+  t0 <- getModificationTime pkg_descr_file+  t1 <- getModificationTime $ localBuildInfoFile distPref+  return (t0 > t1)++-- |@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)++        createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref++        let programsConfig = userSpecifyArgss (configProgramArgs cfg)+                           . userSpecifyPaths (configProgramPaths cfg)+                           $ configPrograms cfg+            userInstall = fromFlag (configUserInstall cfg)+            packageDbs = implicitPackageDbStack userInstall+                           (flagToMaybe $ configPackageDB cfg)++        -- detect compiler+        (comp, programsConfig') <- configCompiler+          (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'++        let -- Constraint test function for the solver+            dependencySatisfiable =+                not . null . PackageIndex.lookupDependency pkgs'+              where+                pkgs' = PackageIndex.insert internalPackage installedPackageSet+            enableTest t = t { testEnabled = fromFlag (configTests cfg) }+            flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))+                               (condTestSuites pkg_descr0)+            pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests }++        (pkg_descr0', flags) <-+                case finalizePackageDescription+                       (configConfigurationsFlags cfg)+                       dependencySatisfiable+                       Distribution.System.buildPlatform+                       (compilerId comp)+                       (configConstraints cfg)+                       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)++        -- add extra include/lib dirs as specified in cfg+        -- we do it here so that those get checked too+        let pkg_descr =+                enableCoverage (fromFlag (configLibCoverage cfg)) distPref+                $ addExtraIncludeLibDirs pkg_descr0'++        when (not (null flags)) $+          info verbosity $ "Flags chosen: "+                        ++ intercalate ", " [ name ++ "=" ++ display value+                                            | (FlagName name, value) <- flags ]++        checkPackageProblems verbosity pkg_descr0+          (updatePackageDescription pbi pkg_descr)++        let selectDependencies =+                (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))+              . map (selectDependency internalPackageSet installedPackageSet)++            (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++        packageDependsIndex <-+          case PackageIndex.dependencyClosure installedPackageSet+                  (map Installed.installedPackageId externalPkgDeps) 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 externalPkgDeps+              }+        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 ]++        -- 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 & build tools+        let requiredBuildTools = concatMap buildTools (allBuildInfo pkg_descr)++        -- add all exes built by this package ("internal exes") to the program+        -- conf; this makes the namespace of build-tools include intrapackage+        -- references to executables+        let programsConfig'' = foldr (addInternalExe buildDir') programsConfig'+                                 (executables pkg_descr)++        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+                            _ -> do warn verbosity+                                         ("this compiler does not support " +++                                          "--enable-split-objs; ignoring")+                                    return False++        -- 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.+        let configLib lib = configComponent (libBuildInfo lib)+            configExe exe = (exeName exe, configComponent (buildInfo exe))+            configTest test = (testName test,+                    configComponent(testBuildInfo test))+            configComponent bi = ComponentLocalBuildInfo {+              componentPackageDeps =+                if newPackageDepsBehaviour pkg_descr'+                  then [ (installedPackageId pkg, packageId pkg)+                       | pkg <- selectSubset bi externalPkgDeps ]+                    ++ [ (inplacePackageId pkgid, pkgid)+                       | pkgid <- selectSubset bi internalPkgDeps ]+                  else [ (installedPackageId pkg, packageId pkg)+                       | pkg <- externalPkgDeps ]+            }+            selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]+            selectSubset bi pkgs =+                [ pkg | pkg <- pkgs, packageName pkg `elem` names ]+              where+                names = [ name | Dependency name _ <- targetBuildDepends bi ]++        -- Obtains the intrapackage dependencies for the given component+        let ipDeps component =+                 mapMaybe exeDepToComp (buildTools bi)+              ++ mapMaybe libDepToComp (targetBuildDepends bi)+              where+                bi = foldComponent libBuildInfo buildInfo testBuildInfo component+                exeDepToComp (Dependency (PackageName name) _) =+                  CExe `fmap` find ((==) name . exeName)+                                (executables pkg_descr')+                libDepToComp (Dependency pn _)+                  | pn `elem` map packageName internalPkgDeps =+                    CLib `fmap` library pkg_descr'+                libDepToComp _ = Nothing++        let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g+              where (g, lkup, _) = graphFromEdges+                                 $ allComponentsBy pkg_descr'+                                 $ \c -> (c, key c, map key (ipDeps c))+                    key          = foldComponent (const "library") exeName testName++        -- check for cycles in the dependency graph+        buildOrder <- forM sccs $ \scc -> case scc of+          AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName)+                                                      (CExeName . exeName)+                                                      (CTestName . testName)+                                                      c)+          CyclicSCC vs ->+            die $ "Found cycle in intrapackage dependency graph:\n  "+                ++ intercalate " depends on "+                     (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs]))++        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,+                    buildDir            = buildDir',+                    scratchDir          = fromFlagOrDefault+                                            (distPref </> "scratch")+                                            (configScratchDir cfg),+                    libraryConfig       = configLib `fmap` library pkg_descr',+                    executableConfigs   = configExe `fmap` executables pkg_descr',+                    testSuiteConfigs    = configTest `fmap` testSuites pkg_descr',+                    compBuildOrder      = buildOrder,+                    installedPkgs       = packageDependsIndex,+                    pkgDescrFile        = Nothing,+                    localPkgDescr       = pkg_descr',+                    withPrograms        = programsConfig'''',+                    withVanillaLib      = fromFlag $ configVanillaLib cfg,+                    withProfLib         = fromFlag $ configProfLib cfg,+                    withSharedLib       = fromFlag $ configSharedLib cfg,+                    withDynExe          = fromFlag $ configDynExe cfg,+                    withProfExe         = fromFlag $ configProfExe cfg,+                    withOptimization    = fromFlag $ configOptimization cfg,+                    withGHCiLib         = fromFlag $ configGHCiLib cfg,+                    splitObjs           = split_objs,+                    stripExes           = fromFlag $ configStripExes cfg,+                    withPackageDB       = packageDbs,+                    progPrefix          = fromFlag $ configProgPrefix cfg,+                    progSuffix          = fromFlag $ configProgSuffix cfg+                  }++        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)++        sequence_ [ reportProgram verbosity prog configuredProg+                  | (prog, configuredProg) <- knownPrograms programsConfig'''' ]++        return lbi++    where+      addInternalExe bd exe =+        let nm = exeName exe in+        addKnownProgram Program {+          programName         = nm,+          programFindLocation = \_ -> return $ Just $ bd </> nm </> nm,+          programFindVersion  = \_ _ -> return Nothing,+          programPostConf     = \_ _ -> return []+        }++      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}++-- -----------------------------------------------------------------------------+-- 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 :: PackageIndex  -- ^ Internally defined packages+                 -> PackageIndex  -- ^ Installed packages+                 -> Dependency+                 -> Either FailedDependency ResolvedDependency+selectDependency internalIndex installedIndex+  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 PackageIndex.lookupDependency installedIndex dep of+      []   -> Left  $ DependencyNotExists pkgname+      pkgs -> Right $ ExternalDependency dep $+                -- by default we just pick the latest+                case last pkgs of+                  (_ver, instances) -> head instances -- the first preference++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 PackageIndex+getInstalledPackages verbosity comp packageDBs progconf = do+  info verbosity "Reading installed packages..."+  case compilerFlavor comp of+    GHC -> GHC.getInstalledPackages verbosity packageDBs progconf+    Hugs->Hugs.getInstalledPackages verbosity packageDBs progconf+    JHC -> JHC.getInstalledPackages verbosity packageDBs progconf+    LHC -> LHC.getInstalledPackages verbosity packageDBs progconf+    NHC -> NHC.getInstalledPackages verbosity packageDBs progconf+    UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf+    flv -> die $ "don't know how to find the installed packages for "+              ++ display flv++-- | Currently the user interface specifies the package dbs to use with just a+-- single valued option, a 'PackageDB'. However internally we represent the+-- stack of 'PackageDB's explictly as a list. This function converts encodes+-- the package db stack implicit in a single packagedb.+--+implicitPackageDbStack :: Bool -> Maybe PackageDB -> PackageDBStack+implicitPackageDbStack userInstall maybePackageDB+  | userInstall = GlobalPackageDB : UserPackageDB : extra+  | otherwise   = GlobalPackageDB : extra+  where+    extra = case maybePackageDB of+      Just (SpecificPackageDB db) -> [SpecificPackageDB db]+      _                           -> []++newPackageDepsBehaviourMinVersion :: Version+newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] }++-- 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++-- -----------------------------------------------------------------------------+-- 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'  <- updateLibrary (library pkg_descr)+    exes' <- mapM updateExecutable (executables pkg_descr)+    let pkg_descr' = pkg_descr { library = lib', executables = exes' }+    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++    updateLibrary Nothing    = return Nothing+    updateLibrary (Just lib) = do+      bi <- pkgconfigBuildInfo (pkgconfigDepends (libBuildInfo lib))+      return $ Just lib { libBuildInfo = libBuildInfo lib `mappend` bi }++    updateExecutable exe = do+      bi <- pkgconfigBuildInfo (pkgconfigDepends (buildInfo exe))+      return exe { buildInfo = buildInfo exe `mappend` 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++configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration)+configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg)+                                       (flagToMaybe $ configHcPath cfg)+                                       (flagToMaybe $ configHcPkg cfg)+                                       programsConfig+                                       (fromFlag (configVerbosity cfg))+  where+    programsConfig = userSpecifyArgss (configProgramArgs cfg)+                   . userSpecifyPaths (configProgramPaths cfg)+                   $ defaultProgramConfiguration++configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath+               -> ProgramConfiguration -> Verbosity+               -> IO (Compiler, ProgramConfiguration)+configCompiler Nothing _ _ _ _ = die "Unknown compiler"+configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do+  case hcFlavor of+      GHC  -> GHC.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+      Hugs -> Hugs.configure verbosity hcPath hcPkg conf+      NHC  -> NHC.configure  verbosity hcPath hcPkg conf+      UHC  -> UHC.configure  verbosity hcPath hcPkg conf+      _    -> die "Unknown compiler"+++-- 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 = hcDefines (compiler 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 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."++        --FIXME: share this with the PreProcessor module+        hcDefines :: Compiler -> [String]+        hcDefines comp =+          case compilerFlavor comp of+            GHC  -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]+            JHC  -> ["-D__JHC__=" ++ versionInt version]+            NHC  -> ["-D__NHC__=" ++ versionInt version]+            Hugs -> ["-D__HUGS__"]+            _    -> []+          where+            version = compilerVersion 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++-- | 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 do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors+            exitWith (ExitFailure 1)
+ cabal/cabal/Distribution/Simple/GHC.hs view
@@ -0,0 +1,1079 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.GHC+-- Copyright   :  Isaac Jones 2003-2007+--+-- 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.++{- Copyright (c) 2003-2005, Isaac Jones+All rights reserved.++Redistribution and use in source and binary forms, with or without+modiication, 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.GHC (+        configure, getInstalledPackages,+        buildLib, buildExe,+        installLib, installExe,+        libAbiHash,+        registerPackage,+        ghcOptions,+        ghcVerbosityOptions,+        ghcPackageDbOptions,+        ghcLibDir,+ ) where++import qualified Distribution.Simple.GHC.IPI641 as IPI641+import qualified Distribution.Simple.GHC.IPI642 as IPI642+import Distribution.PackageDescription as PD+         ( PackageDescription(..), BuildInfo(..), Executable(..)+         , Library(..), libModules, hcOptions, usedExtensions, allExtensions )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo )+import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo+                                ( InstalledPackageInfo_(..) )+import Distribution.Simple.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , absoluteInstallDirs )+import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs )+import Distribution.Simple.BuildPaths+import Distribution.Simple.Utils+import Distribution.Package+         ( PackageIdentifier, Package(..), PackageName(..) )+import qualified Distribution.ModuleName as ModuleName+import Distribution.Simple.Program+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg+         , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf+         , rawSystemProgramStdout, rawSystemProgramStdoutConf+         , requireProgramVersion, requireProgram, getProgramOutput+         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram+         , ghcProgram, ghcPkgProgram, hsc2hsProgram+         , arProgram, ranlibProgram, ldProgram+         , gccProgram, 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 Distribution.Simple.Compiler+         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion+         , OptimisationLevel(..), PackageDB(..), PackageDBStack+         , Flag, languageToFlags, extensionsToFlags )+import Distribution.Version+         ( Version(..), anyVersion, orLaterVersion )+import Distribution.System+         ( OS(..), buildOS )+import Distribution.Verbosity+import Distribution.Text+         ( display, simpleParse )+import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..))++import Control.Monad            ( unless, when, liftM )+import Data.Char                ( isSpace )+import Data.List+import Data.Maybe               ( catMaybes )+import Data.Monoid              ( Monoid(..) )+import System.Directory+         ( removeFile, getDirectoryContents, doesFileExist+         , getTemporaryDirectory )+import System.FilePath          ( (</>), (<.>), takeExtension,+                                  takeDirectory, replaceExtension, splitExtension )+import System.IO (hClose, hPutStrLn)+import Distribution.Compat.Exception (catchExit, catchIO)++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+configure verbosity hcPath hcPkgPath conf0 = do++  (ghcProg, ghcVersion, conf1) <-+    requireProgramVersion verbosity ghcProgram+      (orLaterVersion (Version [6,4] []))+      (userMaybeSpecifyPath "ghc" hcPath conf0)++  -- 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  <- getLanguages verbosity ghcProg+  extensions <- getExtensions verbosity ghcProg++  ghcInfo <- if ghcVersion >= Version [6,7] []+             then do xs <- getProgramOutput verbosity ghcProg ["--info"]+                     case reads xs of+                         [(i, ss)]+                          | all isSpace ss ->+                             return i+                         _ ->+                             die "Can't parse --info output of GHC"+             else return []++  let comp = Compiler {+        compilerId             = CompilerId GHC ghcVersion,+        compilerLanguages      = languages,+        compilerExtensions     = extensions+      }+      conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld+  return (comp, 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 :: FilePath -> ConfiguredProgram -> Verbosity+                     -> IO (Maybe FilePath)+guessToolFromGhcPath tool ghcProg verbosity+  = do let path              = programPath ghcProg+           dir               = takeDirectory path+           versionSuffix     = takeVersionSuffix (dropExeExtension path)+           guessNormal       = dir </> tool <.> exeExtension+           guessGhcVersioned = dir </> (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension+           guessVersioned    = dir </> (tool ++ versionSuffix) <.> exeExtension+           guesses | null versionSuffix = [guessNormal]+                   | otherwise          = [guessGhcVersioned,+                                           guessVersioned,+                                           guessNormal]+       info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir+       exists <- mapM doesFileExist guesses+       case [ file | (file, True) <- zip guesses exists ] of+         [] -> return Nothing+         (fp:_) -> do info verbosity $ "found " ++ tool ++ " 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 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 -> IO (Maybe FilePath)+guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg"++-- | 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 -> IO (Maybe FilePath)+guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs"++-- | Adjust the way we find and configure gcc and ld+--+configureToolchain :: ConfiguredProgram -> [(String, String)]+                                        -> ProgramConfiguration+                                        -> ProgramConfiguration+configureToolchain ghcProg ghcInfo =+    addKnownProgram gccProgram {+      programFindLocation = findProg gccProgram+                              [ if ghcVersion >= Version [6,12] []+                                  then mingwBinDir </> "gcc.exe"+                                  else baseDir     </> "gcc.exe" ],+      programPostConf     = configureGcc+    }+  . addKnownProgram ldProgram {+      programFindLocation = findProg ldProgram+                              [ if ghcVersion >= Version [6,12] []+                                  then mingwBinDir </> "ld.exe"+                                  else libDir      </> "ld.exe" ],+      programPostConf     = configureLd+    }+  . addKnownProgram arProgram {+      programFindLocation = findProg arProgram+                              [ if ghcVersion >= Version [6,12] []+                                  then mingwBinDir </> "ar.exe"+                                  else libDir      </> "ar.exe" ]+    }+  where+    Just ghcVersion = programVersion ghcProg+    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++    -- on Windows finding and configuring ghc's gcc and ld is a bit special+    findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath)+    findProg prog locations+      | isWindows = \verbosity -> look locations verbosity+      | otherwise = programFindLocation prog+      where+        look [] verbosity = do+          warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")+          programFindLocation prog verbosity+        look (f:fs) verbosity = do+          exists <- doesFileExist f+          if exists then return (Just f)+                    else look fs verbosity++    ccFlags        = getFlags "C compiler flags"+    gccLinkerFlags = getFlags "Gcc Linker flags"+    ldLinkerFlags  = getFlags "Ld Linker flags"++    getFlags key = case lookup key ghcInfo of+                   Nothing -> []+                   Just flags ->+                       case reads flags of+                       [(args, "")] -> args+                       _ -> [] -- XXX Should should be an error really++    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags))+                      $ configureGcc' v cp++    configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    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 {}+           | ghcVersion < Version [6,11] [] ->+              return ["-B" ++ libDir, "-I" ++ includeDir]+          _ -> return []+      | otherwise = \_ _   -> return []++    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp++    -- we need to find out if ld supports the -x flag+    configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureLd' verbosity ldProg = do+      tempDir <- getTemporaryDirectory+      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->+             withTempFile tempDir ".o" $ \testofile testohnd -> do+               hPutStrLn testchnd "int foo() {}"+               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 ["-x"]+        else return []++getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)]+getLanguages _ ghcProg+  -- TODO: should be using --supported-languages rather than hard coding+  | ghcVersion >= Version [7] [] = return [(Haskell98,   "-XHaskell98")+                                          ,(Haskell2010, "-XHaskell2010")]+  | otherwise                    = return [(Haskell98,   "")]+  where+    Just ghcVersion = programVersion ghcProg++getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)]+getExtensions verbosity ghcProg+  | ghcVersion >= Version [6,7] [] = do++    str <- rawSystemStdout verbosity (programPath ghcProg)+              ["--supported-languages"]+    let extStrs = if ghcVersion >= Version [7] []+                  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 ghcVersion >= Version [6,8]  [] &&+                         ghcVersion <  Version [6,10] []+                      then -- ghc-6.8 introduced RecordPuns however it+                           -- should have been NamedFieldPuns. We now+                           -- encourage packages to use NamedFieldPuns+                           -- so for compatability 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 ghcVersion <  Version [7,1] []+                      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++  where+    Just ghcVersion = programVersion ghcProg++-- | For GHC 6.6.x and earlier, the mapping from supported extensions to flags+oldLanguageExtensions :: [(Extension, Flag)]+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)+    ]++getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+                     -> IO PackageIndex+getInstalledPackages verbosity packagedbs conf = do+  checkPackageDbStack packagedbs+  pkgss <- getInstalledPackages' verbosity packagedbs conf+  topDir <- ghcLibDir' verbosity ghcProg+  let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)+                | (_, pkgs) <- pkgss ]+  return $! hackRtsPackage (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 ghcProgram conf++    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 testsuite does some crazy stuff.++ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath+ghcLibDir verbosity lbi =+    (reverse . dropWhile isSpace . reverse) `fmap`+     rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]++ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath+ghcLibDir' verbosity ghcProg =+    (reverse . dropWhile isSpace . reverse) `fmap`+     rawSystemProgramStdout verbosity ghcProg ["--print-libdir"]++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"++-- 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 verbosity ghcPkgProg packagedb+         return (packagedb, pkgs)+    | packagedb <- packagedbs ]++  where+    Just ghcPkgProg = lookupProgram ghcPkgProgram conf+    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++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 GHC.+--+buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib verbosity pkg_descr lbi lib clbi = do+  let pref = buildDir lbi+      pkgid = packageId pkg_descr+      runGhcProg = rawSystemProgramConf verbosity ghcProgram (withPrograms lbi)+      ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)+      ifProfLib = when (withProfLib lbi)+      ifSharedLib = when (withSharedLib lbi)+      ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)+      comp = compiler lbi++  libBi <- hackThreadedFlag verbosity+             comp (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 recurive modules?+  let ghcArgs =+             "--make"+          :  ["-package-name", display pkgid ]+          ++ constructGHCCmdLine lbi libBi clbi libTargetDir verbosity+          ++ map display (libModules lib)+      ghcArgsProf = ghcArgs+          ++ ["-prof",+              "-hisuf", "p_hi",+              "-osuf", "p_o"+             ]+          ++ ghcProfOptions libBi+      ghcArgsShared = ghcArgs+          ++ ["-dynamic",+              "-hisuf", "dyn_hi",+              "-osuf", "dyn_o", "-fPIC"+             ]+          ++ ghcSharedOptions libBi+  unless (null (libModules lib)) $+    do ifVanillaLib forceVanillaLib (runGhcProg ghcArgs)+       ifProfLib (runGhcProg ghcArgsProf)+       ifSharedLib (runGhcProg 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+                                                        False+                                                        (withProfLib lbi)+                   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)+      vanillaLibFilePath = libTargetDir </> mkLibName pkgid+      profileLibFilePath = libTargetDir </> mkProfLibName pkgid+      sharedLibFilePath  = libTargetDir </> mkSharedLibName pkgid+                                              (compilerId (compiler lbi))+      ghciLibFilePath    = libTargetDir </> mkGHCiLibName pkgid+      libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest+      sharedLibInstallPath = libInstallPath </> mkSharedLibName pkgid+                                              (compilerId (compiler lbi))++  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 staticObjectFiles =+               hObjs+            ++ map (pref </>) cObjs+            ++ stubObjs+        profObjectFiles =+               hProfObjs+            ++ map (pref </>) cObjs+            ++ stubProfObjs+        ghciObjFiles =+               hObjs+            ++ map (pref </>) cObjs+            ++ stubObjs+        dynamicObjectFiles =+               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 ]+            -- For dynamic libs, Mac OS/X needs to know the install location+            -- at build time.+            ++ (if buildOS == OSX+                then ["-dylib-install-name", sharedLibInstallPath]+                else [])+            ++ dynamicObjectFiles+            ++ ["-package-name", display pkgid ]+            ++ ghcPackageFlags lbi clbi+            ++ ["-l"++extraLib | extraLib <- extraLibs libBi]+            ++ ["-L"++extraLibDir | extraLibDir <- extraLibDirs libBi]++    ifVanillaLib False $ do+      (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)+      Ar.createArLibArchive verbosity arProg+        vanillaLibFilePath staticObjectFiles++    ifProfLib $ do+      (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)+      Ar.createArLibArchive verbosity arProg+        profileLibFilePath profObjectFiles++    ifGHCiLib $ do+      (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)+      Ld.combineObjectFiles verbosity ldProg+        ghciLibFilePath ghciObjFiles++    ifSharedLib $+      runGhcProg ghcSharedLinkArgs+++-- | Build an executable with GHC.+--+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 ghcProgram (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+                                          (withDynExe lbi) (withProfExe lbi)+                 createDirectoryIfMissingVerbose verbosity True odir+                 runGhcProg args+             | filename <- cSources exeBi]++  srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath++  let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)+  let binArgs linkExe dynExe profExe =+             "--make"+          :  (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 dynExe+                then ["-dynamic"]+                else []+          ++ if profExe+                then ["-prof",+                      "-hisuf", "p_hi",+                      "-osuf", "p_o"+                     ] ++ ghcProfOptions 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 (binArgs False (withDynExe lbi) False))++  runGhcProg (binArgs True (withDynExe lbi) (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 splitSuffix = if compilerVersion (compiler lbi) <+                             Version [6, 11] []+                          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 ]++-- | 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+      ghcArgs =+             "--abi-hash"+          :  ["-package-name", display (packageId pkg_descr) ]+          ++ constructGHCCmdLine lbi libBi clbi (buildDir lbi) verbosity+          ++ map display (exposedModules lib)+  --+  rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ghcArgs+++constructGHCCmdLine+        :: LocalBuildInfo+        -> BuildInfo+        -> ComponentLocalBuildInfo+        -> FilePath+        -> Verbosity+        -> [String]+constructGHCCmdLine lbi bi clbi odir verbosity =+        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"]+     ++ ["-fbuilding-cabal-package" | ghcVer >= Version [6,11] [] ]+     ++ ghcPackageDbOptions (withPackageDB lbi)+     ++ ["-split-objs" | splitObjs lbi ]+     ++ ["-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 ++ "\"" | ghcVer < Version [6,11] []+                                        , inc <- PD.includes bi ]+     ++ [ "-odir",  odir, "-hidir", odir ]+     ++ concat [ ["-stubdir", odir] | ghcVer >=  Version [6,8] [] ]+     ++ ghcPackageFlags lbi clbi+     ++ (case withOptimization lbi of+           NoOptimisation      -> []+           NormalOptimisation  -> ["-O"]+           MaximumOptimisation -> ["-O2"])+     ++ hcOptions GHC bi+     ++ languageToFlags   (compiler lbi) (defaultLanguage bi)+     ++ extensionsToFlags (compiler lbi) (usedExtensions bi)+    where+      ghcVer = compilerVersion (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 :: PackageDBStack -> [String]+ghcPackageDbOptions dbstack = case dbstack of+  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+  (GlobalPackageDB:dbs)               -> "-no-user-package-conf"+                                       : concatMap specific dbs+  _                                   -> ierror+  where+    specific (SpecificPackageDB db) = [ "-package-conf", db ]+    specific _ = ierror+    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)++constructCcCmdLine :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo+                   -> FilePath -> FilePath -> Verbosity -> Bool -> Bool+                   ->(FilePath,[String])+constructCcCmdLine lbi bi clbi pref filename verbosity dynamic profiling+  =  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]+         -- Note: When building with profiling enabled, we pass the -prof+         -- option to ghc here when compiling C code, so that the PROFILING+         -- macro gets defined. The macro is used in ghc's Rts.h in the+         -- definitions of closure layouts (Closures.h).+         ++ ["-dynamic" | dynamic]+         ++ ["-prof" | profiling])++ghcCcOptions :: LocalBuildInfo -> BuildInfo -> ComponentLocalBuildInfo+             -> FilePath -> [String]+ghcCcOptions lbi bi clbi odir+     =  ["-I" ++ dir | dir <- odir : PD.includeDirs bi]+     ++ ghcPackageDbOptions (withPackageDB lbi)+     ++ ghcPackageFlags lbi clbi+     ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]+     ++ (case withOptimization lbi of+           NoOptimisation -> []+           _              -> ["-optc-O2"])+     ++ ["-odir", odir]++mkGHCiLibName :: PackageIdentifier -> String+mkGHCiLibName lib = "HS" ++ display 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 librarys+              -> FilePath  -- ^Build location+              -> PackageDescription+              -> Library+              -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+  -- copy .hi files over:+  let copyHelper installFun src dst n = do+        createDirectoryIfMissingVerbose verbosity True dst+        installFun verbosity (src </> n) (dst </> n)+      copy       = copyHelper installOrdinaryFile+      copyShared = copyHelper installExecutableFile+      copyModuleFiles ext =+        findModuleFiles [builtDir] [ext] (libModules lib)+          >>= installOrdinaryFiles verbosity targetDir+  ifVanilla $ copyModuleFiles "hi"+  ifProf    $ copyModuleFiles "p_hi"+  ifShared  $ copyModuleFiles "dyn_hi"++  -- copy the built library files over:+  ifVanilla $ copy builtDir targetDir vanillaLibName+  ifProf    $ copy builtDir targetDir profileLibName+  ifGHCi    $ copy builtDir targetDir ghciLibName+  ifShared  $ copyShared builtDir dynlibTargetDir sharedLibName++  -- run ranlib if necessary:+  ifVanilla $ updateLibArchive verbosity lbi+                               (targetDir </> vanillaLibName)+  ifProf    $ updateLibArchive verbosity lbi+                               (targetDir </> profileLibName)++  where+    vanillaLibName = mkLibName pkgid+    profileLibName = mkProfLibName pkgid+    ghciLibName    = mkGHCiLibName pkgid+    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))++    pkgid          = packageId pkg++    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)++-- | On MacOS X we have to call @ranlib@ to regenerate the archive index after+-- copying. This is because the silly MacOS X linker checks that the archive+-- index is not older than the file itself, which means simply+-- copying/installing the file breaks it!!+--+updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()+updateLibArchive verbosity lbi path+  | buildOS == OSX = do+    (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)+    rawSystemProgram verbosity ranlib [path]+  | otherwise = return ()+++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do+  let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)+  HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)
+ cabal/cabal/Distribution/Simple/GHC/IPI641.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.GHC.IPI641+-- Copyright   :  (c) The University of Glasgow 2004+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--++{- 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 the University 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.GHC.IPI641 (+    InstalledPackageInfo,+    toCurrent,+  ) where++import qualified Distribution.InstalledPackageInfo as Current+import qualified Distribution.Package as Current hiding (depends)+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{} = Current.InstalledPackageInfo {+    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),+    Current.sourcePackageId    = convertPackageId (package ipi),+    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 convertModuleName (exposedModules ipi),+    Current.hiddenModules      = map convertModuleName (hiddenModules ipi),+    Current.trusted            = False,+    Current.importDirs         = importDirs ipi,+    Current.libraryDirs        = libraryDirs ipi,+    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.hugsOptions        = hugsOptions 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+  }
+ cabal/cabal/Distribution/Simple/GHC/IPI642.hs view
@@ -0,0 +1,164 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.GHC.IPI642+-- Copyright   :  (c) The University of Glasgow 2004+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--++{- 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 the University 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.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)+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{} = Current.InstalledPackageInfo {+    Current.installedPackageId = mkInstalledPackageId (convertPackageId (package ipi)),+    Current.sourcePackageId    = convertPackageId (package ipi),+    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 convertModuleName (exposedModules ipi),+    Current.hiddenModules      = map convertModuleName (hiddenModules ipi),+    Current.trusted            = False,+    Current.importDirs         = importDirs ipi,+    Current.libraryDirs        = libraryDirs ipi,+    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.hugsOptions        = hugsOptions 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+  }
+ cabal/cabal/Distribution/Simple/Haddock.hs view
@@ -0,0 +1,629 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Haddock+-- Copyright   :  Isaac Jones 2003-2005+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is+-- a rather complicated module. It deals with two versions of haddock (0.x and+-- 2.x). It has to do pre-processing for haddock 0.x which involves+-- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. 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.++{- 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. -}++module Distribution.Simple.Haddock (+  haddock, hscolour+  ) where++-- local+import Distribution.Package+         ( PackageIdentifier, Package(..), packageName )+import qualified Distribution.ModuleName as ModuleName+import Distribution.PackageDescription as PD+         ( PackageDescription(..), BuildInfo(..), allExtensions+         , Library(..), hasLibs, Executable(..) )+import Distribution.Simple.Compiler+         ( Compiler(..), compilerVersion )+import Distribution.Simple.GHC ( ghcLibDir )+import Distribution.Simple.Program+         ( ConfiguredProgram(..), requireProgramVersion+         , rawSystemProgram, rawSystemProgramStdout+         , hscolourProgram, haddockProgram )+import Distribution.Simple.PreProcess (ppCpp', ppUnlit+                                      , PPSuffixHandler, runSimplePreProcessor+                                      , preprocessComponent)+import Distribution.Simple.Setup+        ( defaultHscolourFlags, Flag(..), flagToMaybe, fromFlag+        , HaddockFlags(..), HscolourFlags(..) )+import Distribution.Simple.Build (initialBuildSteps)+import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplate,+                                        PathTemplateVariable(..),+                                        toPathTemplate, fromPathTemplate,+                                        substPathTemplate,+                                        initialPathTemplateEnv)+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), externalPackageDeps+         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI )+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, warn, notice, intercalate, setupMessage+         , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose+         , withTempDirectory+         , findFileWithExtension, findFile )+import Distribution.Simple.GHC (ghcOptions)+import Distribution.Text+         ( display, simpleParse )++import Distribution.Verbosity+import Language.Haskell.Extension+-- Base+import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing)++import Control.Monad ( when, guard )+import Control.Exception (assert)+import Data.Monoid+import Data.Maybe    ( fromMaybe, listToMaybe )++import System.FilePath((</>), (<.>), splitFileName, splitExtension,+                       normalise, splitPath, joinPath)+import System.IO (hClose, hPutStrLn)+import Distribution.Version++-- Types++-- | record that represents the arguments to the haddock executable, a product monoid.+data HaddockArgs = HaddockArgs {+ argInterfaceFile :: Flag FilePath,               -- ^ path of the interface file, relative to argOutputDir, required.+ argPackageName :: Flag PackageIdentifier,        -- ^ package name,                                         required.+ argHideModules :: (All,[ModuleName.ModuleName]), -- ^ (hide modules ?, modules to hide)+ argIgnoreExports :: Any,                         -- ^ ingore export lists in modules?+ argLinkSource :: Flag (Template,Template),       -- ^ (template for modules, template for symbols)+ argCssFile :: Flag FilePath,                     -- ^ optinal custom css file.+ argVerbose :: Any,+ argOutput :: Flag [Output],                      -- ^ Html or Hoogle doc or both?                                   required.+ argInterfaces :: [(FilePath, Maybe FilePath)],   -- ^ [(interface file, path to the html docs for links)]+ argOutputDir :: Directory,                       -- ^ where to generate the documentation.+ argTitle :: Flag String,                         -- ^ page's title,                                         required.+ argPrologue :: Flag String,                      -- ^ prologue text,                                        required.+ argGhcFlags :: [String],                         -- ^ additional flags to pass to ghc for haddock-2+ argGhcLibDir :: Flag FilePath,                   -- ^ to find the correct ghc,                              required by haddock-2.+ 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) =+      warn (fromFlag $ haddockVerbosity haddockFlags) $+           "No documentation was generated as this package does not contain "+        ++ "a library. Perhaps you want to use the --executables flag."++haddock pkg_descr lbi suffixes flags = do++    setupMessage verbosity "Running Haddock for" (packageId pkg_descr)+    (confHaddock, version, _) <-+      requireProgramVersion verbosity haddockProgram+        (orLaterVersion (Version [0,6] [])) (withPrograms lbi)++    -- various sanity checks+    let isVersion2   = version >= Version [2,0] []++    when ( flag haddockHoogle+           && version > Version [2] []+           && version < Version [2,2] []) $+         die "haddock 2.0 and 2.1 do not support the --hoogle flag."++    when (flag haddockHscolour && version < Version [0,8] []) $+         die "haddock --hyperlink-source requires Haddock version 0.8 or later"++    when isVersion2 $ do+      haddockGhcVersionStr <- rawSystemProgramStdout verbosity confHaddock+                                ["--ghc-version"]+      case simpleParse haddockGhcVersionStr of+        Nothing -> die "Could not get GHC version from Haddock"+        Just haddockGhcVersion+          | 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+          where ghcVersion = compilerVersion (compiler lbi)++    -- the tools match the requests, we can proceed++    initialBuildSteps (flag haddockDistPref) pkg_descr lbi verbosity++    when (flag haddockHscolour) $ hscolour' pkg_descr lbi suffixes $+         defaultHscolourFlags `mappend` haddockToHscolour flags++    args <- fmap mconcat . sequence $+            [ getInterfaces verbosity lbi (flagToMaybe (haddockHtmlLocation flags))+            , getGhcLibDir  verbosity lbi isVersion2 ]+           ++ map return+            [ fromFlags flags+            , fromPackageDescription pkg_descr ]++    let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes+    withComponentsLBI pkg_descr lbi $ \comp clbi -> do+      pre comp+      case comp of+        CLib lib -> do+          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do+            let bi = libBuildInfo lib+            libArgs  <- fromLibrary tmp lbi lib clbi+            libArgs' <- prepareSources verbosity tmp+                          lbi isVersion2 bi (args `mappend` libArgs)+            runHaddock verbosity confHaddock libArgs'+        CExe exe -> when (flag haddockExecutables) $ do+          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do+            let bi = buildInfo exe+            exeArgs  <- fromExecutable tmp lbi exe clbi+            exeArgs' <- prepareSources verbosity tmp+                          lbi isVersion2 bi (args `mappend` exeArgs)+            runHaddock verbosity confHaddock exeArgs'+        _ -> return ()+  where+    verbosity = flag haddockVerbosity+    flag f    = fromFlag $ f flags++-- | performs cpp and unlit preprocessing where needed on the files in+-- | argTargets, which must have an .hs or .lhs extension.+prepareSources :: Verbosity+                  -> FilePath+                  -> LocalBuildInfo+                  -> Bool            -- haddock == 2.*+                  -> BuildInfo+                  -> HaddockArgs+                  -> IO HaddockArgs+prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} =+              mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}+          where+            mockPP pref file = do+                 let (filePref, fileName) = splitFileName file+                     targetDir  = pref </> filePref+                     targetFile = targetDir </> fileName+                     (targetFileNoext, targetFileExt) = splitExtension $ targetFile+                     hsFile = targetFileNoext <.> "hs"++                 assert (targetFileExt `elem` [".lhs",".hs"]) $ return ()++                 createDirectoryIfMissing True targetDir++                 if needsCpp+                    then do+                      runSimplePreProcessor (ppCpp' defines bi lbi)+                                            file targetFile verbosity+                    else+                      copyFileVerbose verbosity file targetFile++                 when (targetFileExt == ".lhs") $ do+                     runSimplePreProcessor ppUnlit targetFile hsFile verbosity+                     removeFile targetFile++                 return hsFile+            needsCpp = EnableExtension CPP `elem` allExtensions bi+            defines | isVersion2 = []+                    | otherwise  = ["-D__HADDOCK__"]++--------------------------------------------------------------------------------------------------+-- constributions to HaddockArgs++fromFlags :: HaddockFlags -> HaddockArgs+fromFlags 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}")+                               else NoFlag,+      argCssFile = haddockCss 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++fromLibrary :: FilePath+            -> LocalBuildInfo -> Library -> ComponentLocalBuildInfo+            -> IO HaddockArgs+fromLibrary tmp lbi lib clbi =+            do inFiles <- map snd `fmap` getLibSourceFiles lbi lib+               return $ mempty {+                            argHideModules = (mempty,otherModules $ bi),+                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)+                                       -- Noooooooooo!!!!!111+                                       -- haddock stomps on our precious .hi+                                       -- and .o files. Workaround by telling+                                       -- haddock to write them elsewhere.+                                       ++ [ "-odir", tmp, "-hidir", tmp+                                          , "-stubdir", tmp ],+                            argTargets = inFiles+                          }+    where+      bi = libBuildInfo lib++fromExecutable :: FilePath+               -> LocalBuildInfo -> Executable -> ComponentLocalBuildInfo+               -> IO HaddockArgs+fromExecutable tmp lbi exe clbi =+            do inFiles <- map snd `fmap` getExeSourceFiles lbi exe+               return $ mempty {+                            argGhcFlags = ghcOptions lbi bi clbi (buildDir lbi)+                                       -- Noooooooooo!!!!!111+                                       -- haddock stomps on our precious .hi+                                       -- and .o files. Workaround by telling+                                       -- haddock to write them elsewhere.+                                       ++ [ "-odir", tmp, "-hidir", tmp+                                          , "-stubdir", tmp ],+                            argOutputDir = Dir (exeName exe),+                            argTitle = Flag (exeName exe),+                            argTargets = inFiles+                          }+    where+      bi = buildInfo exe++getInterfaces :: Verbosity+                 -> LocalBuildInfo+                 -> Maybe String -- ^ template for html location+                 -> IO HaddockArgs+getInterfaces verbosity lbi location = do+    let htmlTemplate = fmap toPathTemplate $ location+    (packageFlags, warnings) <- haddockPackageFlags lbi htmlTemplate+    maybe (return ()) (warn verbosity) warnings+    return $ mempty {+                 argInterfaces = packageFlags+               }++getGhcLibDir :: Verbosity -> LocalBuildInfo+             -> Bool -- ^ are we using haddock-2.x ?+             -> IO HaddockArgs+getGhcLibDir verbosity lbi isVersion2+    | isVersion2 =+        do l <- ghcLibDir verbosity lbi+           return $ mempty { argGhcLibDir = Flag l }+    | otherwise  =+        return mempty++----------------------------------------------------------------------------------------------++-- | Call haddock with the specified arguments.+runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO ()+runHaddock verbosity confHaddock args = do+  let haddockVersion = fromMaybe (error "unable to determine haddock version")+                       (programVersion confHaddock)+  renderArgs verbosity haddockVersion args $ \(flags,result)-> do++      rawSystemProgram verbosity confHaddock flags++      notice verbosity $ "Documentation created: " ++ result+++renderArgs :: Verbosity+              -> Version+              -> HaddockArgs+              -> (([[Char]], FilePath) -> IO a)+              -> IO a+renderArgs verbosity version args k = do+  createDirectoryIfMissingVerbose verbosity True outputDir+  withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do+          do+             hPutStrLn h $ fromFlag $ argPrologue args+             hClose h+             let pflag = (:[]).("--prologue="++) $ prologFileName+             k $ (pflag ++ renderPureArgs version args, result)+    where+      isVersion2 = version >= Version [2,0] []+      outputDir = (unDir $ argOutputDir args)+      result = intercalate ", "+             . map (\o -> outputDir </>+                            case o of+                              Html -> "index.html"+                              Hoogle -> pkgstr <.> "txt")+             $ arg argOutput+            where+              pkgstr | isVersion2 = display $ packageName pkgid+                     | otherwise = display pkgid+              pkgid = arg argPackageName+      arg f = fromFlag $ f args++renderPureArgs :: Version -> HaddockArgs -> [[Char]]+renderPureArgs version args = concat+    [+     (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)+     . fromFlag . argInterfaceFile $ args,+     (\pkgName -> if isVersion2+                  then ["--optghc=-package-name", "--optghc=" ++ pkgName]+                  else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args,+     (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,+     bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,+     maybe [] (\(m,e) -> ["--source-module=" ++ m+                         ,"--source-entity=" ++ e]) . flagToMaybe . argLinkSource $ args,+     maybe [] ((:[]).("--css="++)) . flagToMaybe . argCssFile $ 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,+     bool id (const []) isVersion2 . map ("--optghc=" ++) . argGhcFlags $ args,+     maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?+     argTargets $ args+    ]+    where+      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)+      bool a b c = if c then a else b+      isVersion2 = version >= Version [2,0] []+      isVersion2_5 = version >= Version [2,5] []+      verbosityFlag+       | isVersion2_5 = "--verbosity=1"+       | otherwise = "--verbose"++-----------------------------------------------------------------------------------------------------------++haddockPackageFlags :: LocalBuildInfo+                    -> Maybe PathTemplate+                    -> IO ([(FilePath,Maybe FilePath)], Maybe String)+haddockPackageFlags lbi htmlTemplate = do+  let allPkgs = installedPkgs lbi+      directDeps = map fst (externalPackageDeps lbi)+  transitiveDeps <- case dependencyClosure allPkgs directDeps of+                    Left x -> return x+                    Right _ -> die "Can't find transitive deps for haddock"+  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 (packageId ipkg))+    | ipkg <- PackageIndex.allPackages transitiveDeps ]++  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 = [ (interface, if null html then Nothing else Just html)+              | Right (interface, html) <- interfaces ]++  return (flags, if null missing then Nothing else Just warning)++  where+    interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)+    interfaceAndHtmlPath pkg = do+      interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)+      html <- case htmlTemplate of+        Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)+        Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)+      return (interface, html)++      where expandTemplateVars = fromPathTemplate . substPathTemplate env+            env = (PrefixVar, prefix (installDirTemplates lbi))+                : initialPathTemplateEnv (packageId pkg) (compilerId (compiler 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' pkg_descr lbi suffixes flags+ where+   verbosity  = fromFlag (hscolourVerbosity flags)+   distPref = fromFlag $ hscolourDistPref flags++hscolour' :: PackageDescription+          -> LocalBuildInfo+          -> [PPSuffixHandler]+          -> HscolourFlags+          -> IO ()+hscolour' pkg_descr lbi suffixes flags = do+    let distPref = fromFlag $ hscolourDistPref flags+    (hscolourProg, _, _) <-+      requireProgramVersion+        verbosity hscolourProgram+        (orLaterVersion (Version [1,8] [])) (withPrograms lbi)++    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+    withComponentsLBI pkg_descr lbi $ \comp _ -> do+      pre comp+      case comp of+        CLib lib -> do+          let outputDir = hscolourPref distPref pkg_descr </> "src"+          runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib+        CExe exe | fromFlag (hscolourExecutables flags) -> do+          let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"+          runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe+        _ -> return ()+  where+    stylesheet = flagToMaybe (hscolourCSS flags)++    verbosity  = fromFlag (hscolourVerbosity 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")++         flip mapM_ 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,+      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,+                argVerbose = mempty,+                argOutput = mempty,+                argInterfaces = mempty,+                argOutputDir = mempty,+                argTitle = mempty,+                argPrologue = mempty,+                argGhcFlags = 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,+                argVerbose = mult argVerbose,+                argOutput = mult argOutput,+                argInterfaces = mult argInterfaces,+                argOutputDir = mult argOutputDir,+                argTitle = mult argTitle,+                argPrologue = mult argPrologue,+                argGhcFlags = mult argGhcFlags,+                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/cabal/Distribution/Simple/Hpc.hs view
@@ -0,0 +1,185 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Hpc+-- Copyright   :  Thomas Tuegel 2011+--+-- 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.++{- 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. -}++module Distribution.Simple.Hpc+    ( hpcDir+    , enableCoverage+    , tixDir+    , tixFilePath+    , doHpcMarkup+    , findTixFiles+    ) where++import Control.Exception ( bracket )+import Control.Monad ( unless, when )+import Distribution.Compiler ( CompilerFlavor(..) )+import Distribution.ModuleName ( main )+import Distribution.PackageDescription+    ( BuildInfo(..)+    , Library(..)+    , PackageDescription(..)+    , TestSuite(..)+    , testModules+    )+import Distribution.Simple.Utils ( die, notice )+import Distribution.Text+import Distribution.Verbosity ( Verbosity() )+import System.Directory ( doesFileExist, getDirectoryContents, removeFile )+import System.Exit ( ExitCode(..) )+import System.FilePath+import System.IO ( hClose, IOMode(..), openFile, openTempFile )+import System.Process ( runProcess, waitForProcess )++-- -------------------------------------------------------------------------+-- Haskell Program Coverage++-- | Conditionally enable Haskell Program Coverage by adding the necessary+-- GHC options to a PackageDescription.+--+-- TODO: do this differently in the build stage by constructing local build+-- info, not by modifying the original PackageDescription.+--+enableCoverage :: Bool                  -- ^ Enable coverage?+               -> String                -- ^ \"dist/\" prefix+               -> PackageDescription+               -> PackageDescription+enableCoverage False _ x = x+enableCoverage True distPref p =+    p { library = fmap enableLibCoverage (library p)+      , testSuites = map enableTestCoverage (testSuites p)+      }+  where+    enableBICoverage name oldBI =+        let oldOptions = options oldBI+            oldGHCOpts = lookup GHC oldOptions+            newGHCOpts = case oldGHCOpts of+                             Just xs -> (GHC, hpcOpts ++ xs)+                             _ -> (GHC, hpcOpts)+            newOptions = (:) newGHCOpts $ filter ((== GHC) . fst) oldOptions+            hpcOpts = ["-fhpc", "-hpcdir", hpcDir distPref name]+        in oldBI { options = newOptions }+    enableLibCoverage l =+        l { libBuildInfo = enableBICoverage (display $ package p)+                                            (libBuildInfo l)+          }+    enableTestCoverage t =+        t { testBuildInfo = enableBICoverage (testName t) (testBuildInfo t) }++hpcDir :: FilePath  -- ^ \"dist/\" prefix+       -> FilePath  -- ^ Component subdirectory name+       -> FilePath  -- ^ Directory containing component's HPC .mix files+hpcDir distPref name = distPref </> "hpc" </> name++tixDir :: FilePath  -- ^ \"dist/\" prefix+       -> TestSuite -- ^ Test suite+       -> FilePath  -- ^ Directory containing test suite's .tix files+tixDir distPref suite = distPref </> "test" </> testName suite++-- | Path to the .tix file containing a test suite's sum statistics.+tixFilePath :: FilePath     -- ^ \"dist/\" prefix+            -> TestSuite    -- ^ Test suite+            -> FilePath     -- Path to test suite's .tix file+tixFilePath distPref suite = tixDir distPref suite </> testName suite <.> "tix"++-- | Returns a list of all the .tix files in a test suite's .tix file+-- directory. Returned paths are the complete relative path to each file.+findTixFiles :: FilePath        -- ^ \"dist/\" prefix+             -> TestSuite       -- ^ Test suite+             -> IO [FilePath]   -- ^ All .tix files belonging to test suite+findTixFiles distPref suite = do+    files <- getDirectoryContents $ tixDir distPref suite+    let tixFiles = flip filter files $ \x -> takeExtension x == ".tix"+    return $ map (tixDir distPref suite </>) tixFiles++-- | Generate the HTML markup for a test suite.+doHpcMarkup :: Verbosity+            -> FilePath     -- ^ \"dist/\" prefix+            -> String       -- ^ Library name+            -> TestSuite+            -> IO ()+doHpcMarkup verbosity distPref libName suite = do+    tixFiles <- findTixFiles distPref suite+    when (not $ null tixFiles) $ do+        let hpcOptions = map (\x -> "--exclude=" ++ display x) excluded+            unionOptions = [ "sum"+                           , "--union"+                           , "--output=" ++ tixFilePath distPref suite+                           ]+                           ++ hpcOptions ++ tixFiles+            markupOptions = [ "markup"+                            , tixFilePath distPref suite+                            , "--hpcdir=" ++ hpcDir distPref libName+                            , "--destdir=" ++ tixDir distPref suite+                            ]+                            ++ hpcOptions+            excluded = testModules suite ++ [ main ]+            --TODO: use standard process utilities from D.S.Utils+            runHpc opts h = runProcess "hpc" opts Nothing Nothing Nothing+                                       (Just h) (Just h)+        bracket (openHpcTemp $ tixDir distPref suite) deleteIfExists+            $ \hpcOut -> do+            hUnion <- openFile hpcOut AppendMode+            procUnion <- runHpc unionOptions hUnion+            exitUnion <- waitForProcess procUnion+            success <- case exitUnion of+                ExitSuccess -> do+                    hMarkup <- openFile hpcOut AppendMode+                    procMarkup <- runHpc markupOptions hMarkup+                    exitMarkup <- waitForProcess procMarkup+                    case exitMarkup of+                        ExitSuccess -> return True+                        _ -> return False+                _ -> return False+            unless success $ do+                errs <- readFile hpcOut+                die $ "HPC failed:\n" ++ errs+            when success $ notice verbosity+                $ "Test coverage report written to "+                  ++ tixDir distPref suite </> "hpc_index"+                  <.> "html"+            return ()+  where openHpcTemp dir = do+            (f, h) <- openTempFile dir $ "cabal-test-hpc-" <.> "log"+            hClose h >> return f+        deleteIfExists path = do+            exists <- doesFileExist path+            when exists $ removeFile path
+ cabal/cabal/Distribution/Simple/Hugs.hs view
@@ -0,0 +1,632 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Hugs+-- Copyright   :  Isaac Jones 2003-2006+--                Duncan Coutts 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains most of the NHC-specific code for configuring, building+-- and installing packages.++{- Copyright (c) 2003-2005, Isaac Jones+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. -}++module Distribution.Simple.Hugs (+    configure,+    getInstalledPackages,+    buildLib,+    buildExe,+    install,+    registerPackage,+  ) where++import Distribution.Package+         ( PackageName, PackageIdentifier(..), InstalledPackageId(..)+         , packageName )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo, emptyInstalledPackageInfo+         , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId+                                , sourcePackageId )+         , parseInstalledPackageInfo, showInstalledPackageInfo )+import Distribution.PackageDescription+         ( PackageDescription(..), BuildInfo(..), hcOptions, allExtensions+         , Executable(..), withExe, Library(..), withLib, libModules )+import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as ModuleName+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), CompilerId(..)+         , Compiler(..), Flag, languageToFlags, extensionsToFlags+         , PackageDB(..), PackageDBStack )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.Program+         ( Program(programFindVersion)+         , ProgramConfiguration, userMaybeSpecifyPath+         , requireProgram, requireProgramVersion+         , rawSystemProgramConf, programPath+         , ffihugsProgram, hugsProgram )+import Distribution.Version+         ( Version(..), orLaterVersion )+import Distribution.Simple.PreProcess   ( ppCpp, runSimplePreProcessor )+import Distribution.Simple.PreProcess.Unlit+                                ( unlit )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , InstallDirs(..), absoluteInstallDirs )+import Distribution.Simple.BuildPaths+                                ( autogenModuleName, autogenModulesDir,+                                  dllExtension )+import Distribution.Simple.Setup+         ( CopyDest(..) )+import Distribution.Simple.Utils+         ( createDirectoryIfMissingVerbose+         , installOrdinaryFiles, setFileExecutable+         , withUTF8FileContents, writeFileAtomic, writeUTF8File+         , copyFileVerbose, findFile, findFileWithExtension, findModuleFiles+         , rawSystemStdInOut+         , die, info, notice )+import Language.Haskell.Extension+         ( Language(Haskell98), Extension(..), KnownExtension(..) )+import System.FilePath          ( (</>), takeExtension, (<.>),+                                  searchPathSeparator, normalise, takeDirectory )+import Distribution.System+         ( OS(..), buildOS )+import Distribution.Text+         ( display, simpleParse )+import Distribution.ParseUtils+         ( ParseResult(..) )+import Distribution.Verbosity++import Data.Char                ( isSpace )+import Data.Maybe               ( mapMaybe, catMaybes )+import Data.Monoid              ( Monoid(..) )+import Control.Monad            ( unless, when, filterM )+import Data.List                ( nub, sort, isSuffixOf )+import System.Directory+         ( doesFileExist, doesDirectoryExist, getDirectoryContents+         , removeDirectoryRecursive, getHomeDirectory )+import System.Exit+         ( ExitCode(ExitSuccess) )+import Distribution.Compat.Exception++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+configure verbosity hcPath _hcPkgPath conf = do++  (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram+                            (userMaybeSpecifyPath "ffihugs" hcPath conf)+  (_hugsProg, version, conf'')+                        <- requireProgramVersion verbosity hugsProgram'+                            (orLaterVersion (Version [2006] [])) conf'++  let comp = Compiler {+        compilerId             = CompilerId Hugs version,+        compilerLanguages      = hugsLanguages,+        compilerExtensions     = hugsLanguageExtensions+      }+  return (comp, conf'')++  where+    hugsProgram' = hugsProgram { programFindVersion = getVersion }++getVersion :: Verbosity -> FilePath -> IO (Maybe Version)+getVersion verbosity hugsPath = do+  (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath []+                              (Just (":quit", False)) False+  if exit == ExitSuccess+    then return $! findVersion output+    else return Nothing++  where+    findVersion output = do+      (monthStr, yearStr) <- selectWords output+      year  <- convertYear yearStr+      month <- convertMonth monthStr+      return (Version [year, month] [])++    selectWords output =+      case [ (month, year)+           | [_,_,"Version:", month, year,_] <- map words (lines output) ] of+        [(month, year)] -> Just (month, year)+        _               -> Nothing+    convertYear year = case reads year of+      [(y, [])] | y >= 1999 && y < 2020 -> Just y+      _                                 -> Nothing+    convertMonth month = lookup month (zip months [1..])+    months = [ "January", "February", "March", "April", "May", "June", "July"+             , "August", "September", "October", "November", "December" ]++hugsLanguages :: [(Language, Flag)]+hugsLanguages = [(Haskell98, "")] --default is 98 mode++-- | The flags for the supported extensions+hugsLanguageExtensions :: [(Extension, Flag)]+hugsLanguageExtensions =+    let doFlag (f, (enable, disable)) = [(EnableExtension  f, enable),+                                         (DisableExtension f, disable)]+        alwaysOn = ("", ""{- wrong -})+        ext98 = ("-98", ""{- wrong -})+    in concatMap doFlag+    [(OverlappingInstances       , ("+o",  "-o"))+    ,(IncoherentInstances        , ("+oO", "-O"))+    ,(HereDocuments              , ("+H",  "-H"))+    ,(TypeSynonymInstances       , ext98)+    ,(RecursiveDo                , ext98)+    ,(ParallelListComp           , ext98)+    ,(MultiParamTypeClasses      , ext98)+    ,(FunctionalDependencies     , ext98)+    ,(Rank2Types                 , ext98)+    ,(PolymorphicComponents      , ext98)+    ,(ExistentialQuantification  , ext98)+    ,(ScopedTypeVariables        , ext98)+    ,(ImplicitParams             , ext98)+    ,(ExtensibleRecords          , ext98)+    ,(RestrictedTypeSynonyms     , ext98)+    ,(FlexibleContexts           , ext98)+    ,(FlexibleInstances          , ext98)+    ,(ForeignFunctionInterface   , alwaysOn)+    ,(EmptyDataDecls             , alwaysOn)+    ,(CPP                        , alwaysOn)+    ]++getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+                     -> IO PackageIndex+getInstalledPackages verbosity packagedbs conf = do+  homedir       <- getHomeDirectory+  (hugsProg, _) <- requireProgram verbosity hugsProgram conf+  let hugsbindir = takeDirectory (programPath hugsProg)+      hugslibdir = takeDirectory hugsbindir </> "lib" </> "hugs"+      dbdirs = nub (concatMap (packageDbPaths homedir hugslibdir) packagedbs)+  indexes  <- mapM getIndividualDBPackages dbdirs+  return $! mconcat indexes++  where+    getIndividualDBPackages :: FilePath -> IO PackageIndex+    getIndividualDBPackages dbdir = do+      pkgdirs <- getPackageDbDirs dbdir+      pkgs    <- sequence [ getInstalledPackage pkgname pkgdir+                          | (pkgname, pkgdir) <- pkgdirs ]+      let pkgs' = map setInstalledPackageId (catMaybes pkgs)+      return (PackageIndex.fromList pkgs')++packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]+packageDbPaths home hugslibdir db = case db of+  GlobalPackageDB        -> [ hugslibdir </> "packages"+                            , "/usr/local/lib/hugs/packages" ]+  UserPackageDB          -> [ home </> "lib/hugs/packages" ]+  SpecificPackageDB path -> [ path ]++getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)]+getPackageDbDirs dbdir = do+  dbexists <- doesDirectoryExist dbdir+  if not dbexists+    then return []+    else do+      entries  <- getDirectoryContents dbdir+      pkgdirs  <- sequence+        [ do pkgdirExists <- doesDirectoryExist pkgdir+             return (pkgname, pkgdir, pkgdirExists)+        | (entry, Just pkgname) <- [ (entry, simpleParse entry)+                                   | entry <- entries ]+        , let pkgdir = dbdir </> entry ]+      return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ]++getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo)+getInstalledPackage pkgname pkgdir = do+  let pkgconfFile = pkgdir </> "package.conf"+  pkgconfExists <- doesFileExist pkgconfFile++  let pathsModule = pkgdir </> ("Paths_" ++ display pkgname)  <.> "hs"+  pathsModuleExists <- doesFileExist pathsModule++  case () of+    _ | pkgconfExists     -> getFullInstalledPackageInfo pkgname pkgconfFile+      | pathsModuleExists -> getPhonyInstalledPackageInfo pkgname pathsModule+      | otherwise         -> return Nothing++getFullInstalledPackageInfo :: PackageName -> FilePath+                            -> IO (Maybe InstalledPackageInfo)+getFullInstalledPackageInfo pkgname pkgconfFile =+  withUTF8FileContents pkgconfFile $ \contents ->+    case parseInstalledPackageInfo contents of+      ParseOk _ pkginfo | packageName pkginfo == pkgname+                        -> return (Just pkginfo)+      _                 -> return Nothing++-- | This is a backup option for existing versions of Hugs which do not supply+-- proper installed package info files for the bundled libs. Instead we look+-- for the Paths_pkgname.hs file and extract the package version from that.+-- We don't know any other details for such packages, in particular we pretend+-- that they have no dependencies.+--+getPhonyInstalledPackageInfo :: PackageName -> FilePath+                             -> IO (Maybe InstalledPackageInfo)+getPhonyInstalledPackageInfo pkgname pathsModule = do+  content <- readFile pathsModule+  case extractVersion content of+    Nothing      -> return Nothing+    Just version -> return (Just pkginfo)+      where+        pkgid   = PackageIdentifier pkgname version+        pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid }+  where+    -- search through the Paths_pkgname.hs file, looking for a line like:+    --+    -- > version = Version {versionBranch = [2,0], versionTags = []}+    --+    -- and parse it using 'Read'. Yes we are that evil.+    --+    extractVersion content =+      case [ version+           | ("version":"=":rest) <- map words (lines content)+           , (version, []) <- reads (concat rest) ] of+        [version] -> Just version+        _         -> 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++-- -----------------------------------------------------------------------------+-- Building++-- |Building a package for Hugs.+buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib verbosity pkg_descr lbi lib _clbi = do+    let pref = scratchDir lbi+    createDirectoryIfMissingVerbose verbosity True pref+    copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)+                              (pref </> paths_modulename)+    compileBuildInfo verbosity pref [] (libModules lib) (libBuildInfo lib) lbi+  where+    paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr)+                         <.> ".hs"+    --TODO: switch to using autogenModulesDir as a search dir, rather than+    --      always copying the file over.++-- |Building an executable for Hugs.+buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe verbosity pkg_descr lbi+  exe@Executable {modulePath=mainPath, buildInfo=bi} _clbi = do+    let pref = scratchDir lbi+    createDirectoryIfMissingVerbose verbosity True pref+    +    let destDir = pref </> "programs"+    let exeMods = otherModules bi+    srcMainFile <- findFile (hsSourceDirs bi) mainPath+    let exeDir = destDir </> exeName exe+    let destMainFile = exeDir </> hugsMainFilename exe+    copyModule verbosity (EnableExtension CPP `elem` allExtensions bi) bi lbi srcMainFile destMainFile+    let destPathsFile = exeDir </> paths_modulename+    copyFileVerbose verbosity (autogenModulesDir lbi </> paths_modulename)+                              destPathsFile+    compileBuildInfo verbosity exeDir +      (maybe [] (hsSourceDirs . libBuildInfo) (library pkg_descr)) exeMods bi lbi+    compileFiles verbosity bi lbi exeDir [destMainFile, destPathsFile]++  where+    paths_modulename = ModuleName.toFilePath (autogenModuleName pkg_descr)+                         <.> ".hs"++compileBuildInfo :: Verbosity+                 -> FilePath -- ^output directory+                 -> [FilePath] -- ^library source dirs, if building exes+                 -> [ModuleName] -- ^Modules+                 -> BuildInfo+                 -> LocalBuildInfo+                 -> IO ()+--TODO: should not be using mLibSrcDirs at all+compileBuildInfo verbosity destDir mLibSrcDirs mods bi lbi = do+    -- Pass 1: copy or cpp files from build directory to scratch directory+    let useCpp = EnableExtension CPP `elem` allExtensions bi+    let srcDir = buildDir lbi+        srcDirs = nub $ srcDir : hsSourceDirs bi ++ mLibSrcDirs+    info verbosity $ "Source directories: " ++ show srcDirs+    flip mapM_ mods $ \ m -> do+        fs <- findFileWithExtension suffixes srcDirs (ModuleName.toFilePath m)+        case fs of+          Nothing ->+            die ("can't find source for module " ++ display m)+          Just srcFile -> do+            let ext = takeExtension srcFile+            copyModule verbosity useCpp bi lbi srcFile+                (destDir </> ModuleName.toFilePath m <.> ext)+    -- Pass 2: compile foreign stubs in scratch directory+    stubsFileLists <- fmap catMaybes $ sequence+      [ findFileWithExtension suffixes [destDir] (ModuleName.toFilePath modu)+      | modu <- mods]+    compileFiles verbosity bi lbi destDir stubsFileLists++suffixes :: [String]+suffixes = ["hs", "lhs"]++-- Copy or cpp a file from the source directory to the build directory.+copyModule :: Verbosity -> Bool -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO ()+copyModule verbosity cppAll bi lbi srcFile destFile = do+    createDirectoryIfMissingVerbose verbosity True (takeDirectory destFile)+    (exts, opts, _) <- getOptionsFromSource srcFile+    let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ]+    if cppAll || EnableExtension CPP `elem` exts || "-cpp" `elem` ghcOpts then do+        runSimplePreProcessor (ppCpp bi lbi) srcFile destFile verbosity+        return ()+      else+        copyFileVerbose verbosity srcFile destFile++compileFiles :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> [FilePath] -> IO ()+compileFiles verbosity bi lbi modDir fileList = do+    ffiFileList <- filterM testFFI fileList+    unless (null ffiFileList) $ do+        notice verbosity "Compiling FFI stubs"+        mapM_ (compileFFI verbosity bi lbi modDir) ffiFileList++-- Only compile FFI stubs for a file if it contains some FFI stuff+testFFI :: FilePath -> IO Bool+testFFI file =+  withHaskellFile file $ \inp ->+    return $! "foreign" `elem` symbols (stripComments False inp)++compileFFI :: Verbosity -> BuildInfo -> LocalBuildInfo -> FilePath -> FilePath -> IO ()+compileFFI verbosity bi lbi modDir file = do+    (_, opts, file_incs) <- getOptionsFromSource file+    let ghcOpts = [ op | (GHC, ops) <- opts, op <- ops ]+    let pkg_incs = ["\"" ++ inc ++ "\"" | inc <- includes bi]+    let incs = nub (sort (file_incs ++ includeOpts ghcOpts ++ pkg_incs))+    let pathFlag = "-P" ++ modDir ++ [searchPathSeparator]+    let hugsArgs = "-98" : pathFlag : map ("-i" ++) incs+    cfiles <- getCFiles file+    let cArgs =+            ["-I" ++ dir | dir <- includeDirs bi] +++            ccOptions bi +++            cfiles +++            ["-L" ++ dir | dir <- extraLibDirs bi] +++            ldOptions bi +++            ["-l" ++ lib | lib <- extraLibs bi] +++            concat [["-framework", f] | f <- frameworks bi]+    rawSystemProgramConf verbosity ffihugsProgram (withPrograms lbi)+      (hugsArgs ++ file : cArgs)++includeOpts :: [String] -> [String]+includeOpts [] = []+includeOpts ("-#include" : arg : opts) = arg : includeOpts opts+includeOpts (_ : opts) = includeOpts opts++-- get C file names from CFILES pragmas throughout the source file+getCFiles :: FilePath -> IO [String]+getCFiles file =+  withHaskellFile file $ \inp ->+    let cfiles =+          [ normalise cfile+          | "{-#" : "CFILES" : rest <- map words+                                     $ lines+                                     $ stripComments True inp+          , last rest == "#-}"+          , cfile <- init rest]+     in seq (length cfiles) (return cfiles)++-- List of terminal symbols in a source file.+symbols :: String -> [String]+symbols cs = case lex cs of+    (sym, cs'):_ | not (null sym) -> sym : symbols cs'+    _ -> []++-- Get the non-literate source of a Haskell module.+withHaskellFile :: FilePath -> (String -> IO a) -> IO a+withHaskellFile file action =+    withUTF8FileContents file $ \text ->+        if ".lhs" `isSuffixOf` file+          then either action die (unlit file text)+          else action text++-- ------------------------------------------------------------+-- * options in source files+-- ------------------------------------------------------------++-- |Read the initial part of a source file, before any Haskell code,+-- and return the contents of any LANGUAGE, OPTIONS and INCLUDE pragmas.+getOptionsFromSource+    :: FilePath+    -> IO ([Extension],                 -- LANGUAGE pragma, if any+           [(CompilerFlavor,[String])], -- OPTIONS_FOO pragmas+           [String]                     -- INCLUDE pragmas+          )+getOptionsFromSource file =+    withHaskellFile file $+        (return $!)+      . foldr appendOptions ([],[],[]) . map getOptions+      . takeWhileJust . map getPragma+      . filter textLine . map (dropWhile isSpace) . lines+      . stripComments True++  where textLine [] = False+        textLine ('#':_) = False+        textLine _ = True++        getPragma :: String -> Maybe [String]+        getPragma line = case words line of+            ("{-#" : rest) | last rest == "#-}" -> Just (init rest)+            _ -> Nothing++        getOptions ("OPTIONS":opts) = ([], [(GHC, opts)], [])+        getOptions ("OPTIONS_GHC":opts) = ([], [(GHC, opts)], [])+        getOptions ("OPTIONS_NHC98":opts) = ([], [(NHC, opts)], [])+        getOptions ("OPTIONS_HUGS":opts) = ([], [(Hugs, opts)], [])+        getOptions ("LANGUAGE":ws) = (mapMaybe readExtension ws, [], [])+          where readExtension :: String -> Maybe Extension+                readExtension w = case reads w of+                    [(ext, "")] -> Just ext+                    [(ext, ",")] -> Just ext+                    _ -> Nothing+        getOptions ("INCLUDE":ws) = ([], [], ws)+        getOptions _ = ([], [], [])++        appendOptions (exts, opts, incs) (exts', opts', incs')+          = (exts++exts', opts++opts', incs++incs')++-- takeWhileJust f = map fromJust . takeWhile isJust+takeWhileJust :: [Maybe a] -> [a]+takeWhileJust (Just x:xs) = x : takeWhileJust xs+takeWhileJust _ = []++-- |Strip comments from Haskell source.+stripComments+    :: Bool     -- ^ preserve pragmas?+    -> String   -- ^ input source text+    -> String+stripComments keepPragmas = stripCommentsLevel 0+  where stripCommentsLevel :: Int -> String -> String+        stripCommentsLevel 0 ('"':cs) = '"':copyString cs+        stripCommentsLevel 0 ('-':'-':cs) =     -- FIX: symbols like -->+            stripCommentsLevel 0 (dropWhile (/= '\n') cs)+        stripCommentsLevel 0 ('{':'-':'#':cs)+          | keepPragmas = '{' : '-' : '#' : copyPragma cs+        stripCommentsLevel n ('{':'-':cs) = stripCommentsLevel (n+1) cs+        stripCommentsLevel 0 (c:cs) = c : stripCommentsLevel 0 cs+        stripCommentsLevel n ('-':'}':cs) = stripCommentsLevel (n-1) cs+        stripCommentsLevel n (_:cs) = stripCommentsLevel n cs+        stripCommentsLevel _ [] = []++        copyString ('\\':c:cs) = '\\' : c : copyString cs+        copyString ('"':cs) = '"' : stripCommentsLevel 0 cs+        copyString (c:cs) = c : copyString cs+        copyString [] = []++        copyPragma ('#':'-':'}':cs) = '#' : '-' : '}' : stripCommentsLevel 0 cs+        copyPragma (c:cs) = c : copyPragma cs+        copyPragma [] = []++-- -----------------------------------------------------------------------------+-- |Install for Hugs.+-- For install, copy-prefix = prefix, but for copy they're different.+-- The library goes in \<copy-prefix>\/lib\/hugs\/packages\/\<pkgname>+-- (i.e. \<prefix>\/lib\/hugs\/packages\/\<pkgname> on the target system).+-- Each executable goes in \<copy-prefix>\/lib\/hugs\/programs\/\<exename>+-- (i.e. \<prefix>\/lib\/hugs\/programs\/\<exename> on the target system)+-- with a script \<copy-prefix>\/bin\/\<exename> pointing at+-- \<prefix>\/lib\/hugs\/programs\/\<exename>.+install+    :: Verbosity -- ^verbosity+    -> LocalBuildInfo+    -> FilePath  -- ^Library install location+    -> FilePath  -- ^Program install location+    -> FilePath  -- ^Executable install location+    -> FilePath  -- ^Program location on target system+    -> FilePath  -- ^Build location+    -> (FilePath,FilePath)  -- ^Executable (prefix,suffix)+    -> PackageDescription+    -> IO ()+--FIXME: this script should be generated at build time, just installed at this stage+install verbosity lbi libDir installProgDir binDir targetProgDir buildPref (progprefix,progsuffix) pkg_descr = do+    removeDirectoryRecursive libDir `catchIO` \_ -> return ()+    withLib pkg_descr $ \ lib ->+      findModuleFiles [buildPref] hugsInstallSuffixes (libModules lib)+        >>= installOrdinaryFiles verbosity libDir+    let buildProgDir = buildPref </> "programs"+    when (any (buildable . buildInfo) (executables pkg_descr)) $+        createDirectoryIfMissingVerbose verbosity True binDir+    withExe pkg_descr $ \ exe -> do+        let bi = buildInfo exe+        let theBuildDir = buildProgDir </> exeName exe+        let installDir = installProgDir </> exeName exe+        let targetDir = targetProgDir </> exeName exe+        removeDirectoryRecursive installDir `catchIO` \_ -> return ()+        findModuleFiles [theBuildDir] hugsInstallSuffixes+                        (ModuleName.main : autogenModuleName pkg_descr+                                         : otherModules (buildInfo exe))+          >>= installOrdinaryFiles verbosity installDir+        let targetName = "\"" ++ (targetDir </> hugsMainFilename exe) ++ "\""+        let hugsOptions = hcOptions Hugs (buildInfo exe)+                       ++ languageToFlags (compiler lbi) (defaultLanguage bi)+                       ++ extensionsToFlags (compiler lbi) (allExtensions bi)+            --TODO: also need to consider options, extensions etc of deps+            --      see ticket #43+        let baseExeFile = progprefix ++ (exeName exe) ++ progsuffix+        let exeFile = case buildOS of+                          Windows -> binDir </> baseExeFile <.> ".bat"+                          _       -> binDir </> baseExeFile+        let script = case buildOS of+                         Windows ->+                             let args = hugsOptions ++ [targetName, "%*"]+                             in unlines ["@echo off",+                                         unwords ("runhugs" : args)]+                         _ ->+                             let args = hugsOptions ++ [targetName, "\"$@\""]+                             in unlines ["#! /bin/sh",+                                         unwords ("runhugs" : args)]+        writeFileAtomic exeFile script+        setFileExecutable exeFile++hugsInstallSuffixes :: [String]+hugsInstallSuffixes = [".hs", ".lhs", dllExtension]++-- |Filename used by Hugs for the main module of an executable.+-- This is a simple filename, so that Hugs will look for any auxiliary+-- modules it uses relative to the directory it's in.+hugsMainFilename :: Executable -> FilePath+hugsMainFilename exe = "Main" <.> ext+  where ext = takeExtension (modulePath exe)++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo pkg lbi inplace _packageDbs = do+  --TODO: prefer to have it based on the packageDbs, but how do we know+  -- the package subdir based on the name? the user can set crazy libsubdir+  let installDirs = absoluteInstallDirs pkg lbi NoCopyDest+      pkgdir  | inplace   = buildDir lbi+              | otherwise = libdir installDirs+  createDirectoryIfMissingVerbose verbosity True pkgdir+  writeUTF8File (pkgdir </> "package.conf")+                (showInstalledPackageInfo installedPkgInfo)
+ cabal/cabal/Distribution/Simple/Install.hs view
@@ -0,0 +1,214 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Install+-- Copyright   :  Isaac Jones 2003-2004+--+-- 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.++{- 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. -}++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)+import Distribution.Simple.BuildPaths (haddockName, haddockPref)+import Distribution.Simple.Utils+         ( createDirectoryIfMissingVerbose, installDirectoryContents+         , installOrdinaryFile, die, info, notice, matchDirFileGlob )+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), compilerFlavor )+import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag)++import qualified Distribution.Simple.GHC  as GHC+import qualified Distribution.Simple.NHC  as NHC+import qualified Distribution.Simple.JHC  as JHC+import qualified Distribution.Simple.LHC  as LHC+import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC++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.  FIX:+-- nhc isn't implemented yet.++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,+         progdir    = progPref,+         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 lfile = licenseFile pkg_descr+  unless (null lfile) $ do+    createDirectoryIfMissingVerbose verbosity True docPref+    installOrdinaryFile verbosity lfile (docPref </> takeFileName lfile)++  let buildPref = buildDir lbi+  when (hasLibs pkg_descr) $+    notice verbosity ("Installing library in " ++ libPref)+  when (hasExes pkg_descr) $+    notice verbosity ("Installing executable(s) in " ++ binPref)++  -- 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 withLib pkg_descr $+                  GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr+                withExe pkg_descr $+                  GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr+     LHC  -> do withLib pkg_descr $+                  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+     Hugs -> do+       let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest)+       let scratchPref = scratchDir lbi+       Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr+     NHC  -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)+                withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)+     UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr+     _    -> die $ "installing with "+                ++ display (compilerFlavor (compiler lbi))+                ++ " is not implemented"+  return ()+  -- 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/cabal/Distribution/Simple/InstallDirs.hs view
@@ -0,0 +1,600 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.InstallDirs+-- Copyright   :  Isaac Jones 2003-2004+--+-- 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.++{- 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. -}++module Distribution.Simple.InstallDirs (+        InstallDirs(..),+        InstallDirTemplates,+        defaultInstallDirs,+        combineInstallDirs,+        absoluteInstallDirs,+        CopyDest(..),+        prefixRelativeInstallDirs,+        substituteInstallDirTemplates,++        PathTemplate,+        PathTemplateVariable(..),+        toPathTemplate,+        fromPathTemplate,+        substPathTemplate,+        initialPathTemplateEnv,+        platformTemplateEnv,+        compilerTemplateEnv,+        packageTemplateEnv,+        installDirsTemplateEnv,+  ) where+++import Data.List (isPrefixOf)+import Data.Maybe (fromMaybe)+import Data.Monoid (Monoid(..))+import System.Directory (getAppUserDataDirectory)+import System.FilePath ((</>), isPathSeparator, pathSeparator)+#if __HUGS__ || __GLASGOW_HASKELL__ > 606+import System.FilePath (dropDrive)+#endif++import Distribution.Package+         ( PackageIdentifier, packageName, packageVersion )+import Distribution.System+         ( OS(..), buildOS, Platform(..), buildPlatform )+import Distribution.Compiler+         ( CompilerId, CompilerFlavor(..) )+import Distribution.Text+         ( display )++#if mingw32_HOST_OS || mingw32_TARGET_OS+import Foreign+import Foreign.C+#endif++-- ---------------------------------------------------------------------------+-- Instalation 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 direcotries. 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,+        progdir      :: dir,+        includedir   :: dir,+        datadir      :: dir,+        datasubdir   :: dir,+        docdir       :: dir,+        mandir       :: dir,+        htmldir      :: dir,+        haddockdir   :: dir+    } deriving (Read, Show)++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),+    progdir      = f (progdir 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)+  }++instance Monoid dir => Monoid (InstallDirs dir) where+  mempty = InstallDirs {+      prefix       = mempty,+      bindir       = mempty,+      libdir       = mempty,+      libsubdir    = mempty,+      dynlibdir    = mempty,+      libexecdir   = mempty,+      progdir      = mempty,+      includedir   = mempty,+      datadir      = mempty,+      datasubdir   = mempty,+      docdir       = mempty,+      mandir       = mempty,+      htmldir      = mempty,+      haddockdir   = 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,+    progdir      = progdir a    `combine` progdir 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+  }++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 substituion (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\/$pkgid\/$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+           Hugs   -> "hugs" </> "packages" </> "$pkg"+           JHC    -> "$compiler"+           LHC    -> "$compiler"+           UHC    -> "$pkgid"+           _other -> "$pkgid" </> "$compiler",+      dynlibdir    = "$libdir",+      libexecdir   = case buildOS of+        Windows   -> "$prefix" </> "$pkgid"+        _other    -> "$prefix" </> "libexec",+      progdir      = "$libdir" </> "hugs" </> "programs",+      includedir   = "$libdir" </> "$libsubdir" </> "include",+      datadir      = case buildOS of+        Windows   -> "$prefix"+        _other    -> "$prefix" </> "share",+      datasubdir   = "$pkgid",+      docdir       = "$datadir" </> "doc" </> "$pkgid",+      mandir       = "$datadir" </> "man",+      htmldir      = "$docdir"  </> "html",+      haddockdir   = "$htmldir"+  }++-- ---------------------------------------------------------------------------+-- 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,+      progdir    = subst progdir    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])+    }+    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 -> CompilerId -> CopyDest+                    -> InstallDirs PathTemplate+                    -> InstallDirs FilePath+absoluteInstallDirs pkgId compilerId copydest dirs =+    (case copydest of+       CopyTo destdir -> fmap ((destdir </>) . dropDrive)+       _              -> id)+  . appendSubdirs (</>)+  . fmap fromPathTemplate+  $ substituteInstallDirTemplates env dirs+  where+    env = initialPathTemplateEnv pkgId compilerId+++-- |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 -> CompilerId+                          -> InstallDirTemplates+                          -> InstallDirs (Maybe FilePath)+prefixRelativeInstallDirs pkgId compilerId 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 compilerId++    -- 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, posibly containing variables that need to be+-- substituted for to get a real 'FilePath'.+--+newtype PathTemplate = PathTemplate [PathComponent]++data PathComponent =+       Ordinary FilePath+     | Variable PathTemplateVariable+     deriving Eq++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@+     | 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@+     | 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@.+  deriving Eq++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 -> CompilerId -> PathTemplateEnv+initialPathTemplateEnv pkgId compilerId =+     packageTemplateEnv  pkgId+  ++ compilerTemplateEnv compilerId+  ++ platformTemplateEnv buildPlatform -- platform should be param if we want+                                       -- to do cross-platform configuation++packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv+packageTemplateEnv pkgId =+  [(PkgNameVar,  PathTemplate [Ordinary $ display (packageName pkgId)])+  ,(PkgVerVar,   PathTemplate [Ordinary $ display (packageVersion pkgId)])+  ,(PkgIdVar,    PathTemplate [Ordinary $ display pkgId])+  ]++compilerTemplateEnv :: CompilerId -> PathTemplateEnv+compilerTemplateEnv compilerId =+  [(CompilerVar, PathTemplate [Ordinary $ display compilerId])+  ]++platformTemplateEnv :: Platform -> PathTemplateEnv+platformTemplateEnv (Platform arch os) =+  [(OSVar,       PathTemplate [Ordinary $ display os])+  ,(ArchVar,     PathTemplate [Ordinary $ display arch])+  ]++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 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 ExecutableNameVar = "executablename"+  show TestSuiteNameVar   = "test-suite"+  show TestSuiteResultVar = "result"++instance Read PathTemplateVariable where+  readsPrec _ s =+    take 1+    [ (var, drop (length varStr) s)+    | (varStr, var) <- vars+    , varStr `isPrefixOf` s ]+    where vars = [("prefix",     PrefixVar)+                 ,("bindir",     BindirVar)+                 ,("libdir",     LibdirVar)+                 ,("libsubdir",  LibsubdirVar)+                 ,("datadir",    DatadirVar)+                 ,("datasubdir", DatasubdirVar)+                 ,("docdir",     DocdirVar)+                 ,("htmldir",    HtmldirVar)+                 ,("pkgid",      PkgIdVar)+                 ,("pkg",        PkgNameVar)+                 ,("version",    PkgVerVar)+                 ,("compiler",   CompilerVar)+                 ,("os",         OSVar)+                 ,("arch",       ArchVar)+                 ,("executablename", ExecutableNameVar)+                 ,("test-suite", TestSuiteNameVar)+                 ,("result", TestSuiteResultVar)]++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 colapse 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 || mingw32_TARGET_OS+  m <- shGetFolderPath csidl_PROGRAM_FILES+#else+  let m = Nothing+#endif+  return (fromMaybe "C:\\Program Files" m)++#if mingw32_HOST_OS || mingw32_TARGET_OS+shGetFolderPath :: CInt -> IO (Maybe FilePath)+shGetFolderPath n =+# if __HUGS__+  return Nothing+# else+  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+# endif++csidl_PROGRAM_FILES :: CInt+csidl_PROGRAM_FILES = 0x0026+-- csidl_PROGRAM_FILES_COMMON :: CInt+-- csidl_PROGRAM_FILES_COMMON = 0x002b++foreign import stdcall unsafe "shlobj.h SHGetFolderPathW"+            c_SHGetFolderPath :: Ptr ()+                              -> CInt+                              -> Ptr ()+                              -> CInt+                              -> CWString+                              -> IO CInt+#endif++#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606)+-- Compat: this function only appears in FilePath > 1.0+-- (which at the time of writing is unreleased)+dropDrive :: FilePath -> FilePath+dropDrive (c:cs) | isPathSeparator c = cs+dropDrive (_:':':c:cs) | isWindows+                      && isPathSeparator c = cs  -- path with drive letter+dropDrive (_:':':cs)   | isWindows         = cs+dropDrive cs = cs++isWindows :: Bool+isWindows = case buildOS of+  Windows -> True+  _       -> False+#endif
+ cabal/cabal/Distribution/Simple/JHC.hs view
@@ -0,0 +1,221 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.JHC+-- Copyright   :  Isaac Jones 2003-2006+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains most of the JHC-specific code for configuring, building+-- and installing packages.++{-+Copyright (c) 2009, Henning Thielemann+Copyright (c) 2003-2005, Isaac Jones+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. -}++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 (PackageIndex)+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(..)+         , 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 Data.List                ( nub )+import Data.Char                ( isSpace )+import Data.Maybe               ( fromMaybe )+++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration -> IO (Compiler, 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,+        compilerLanguages      = jhcLanguages,+        compilerExtensions     = jhcLanguageExtensions+      }+  return (comp, 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 PackageIndex+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 $ 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/cabal/Distribution/Simple/LHC.hs view
@@ -0,0 +1,805 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.LHC+-- Copyright   :  Isaac Jones 2003-2007+--+-- 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.++{- Copyright (c) 2003-2005, Isaac Jones+All rights reserved.++Redistribution and use in source and binary forms, with or without+modiication, 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.LHC (+        configure, getInstalledPackages,+        buildLib, buildExe,+        installLib, installExe,+        registerPackage,+        ghcOptions,+        ghcVerbosityOptions+ ) where++import Distribution.PackageDescription as PD+         ( PackageDescription(..), BuildInfo(..), Executable(..)+         , Library(..), libModules, hcOptions, 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(..) )+import Distribution.Simple.InstallDirs+import Distribution.Simple.BuildPaths+import Distribution.Simple.Utils+import Distribution.Package+         ( PackageIdentifier, Package(..) )+import qualified Distribution.ModuleName as ModuleName+import Distribution.Simple.Program+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg+         , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf+         , rawSystemProgramStdout, rawSystemProgramStdoutConf+         , requireProgramVersion+         , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram+         , arProgram, ranlibProgram, ldProgram+         , gccProgram, stripProgram+         , lhcProgram, lhcPkgProgram )+import qualified Distribution.Simple.Program.HcPkg as HcPkg+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion+         , OptimisationLevel(..), PackageDB(..), PackageDBStack+         , 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 Data.Maybe               ( catMaybes )+import Data.Monoid              ( Monoid(..) )+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)++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration -> IO (Compiler, 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,+        compilerLanguages      = languages,+        compilerExtensions     = extensions+      }+      conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld+  return (comp, 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 -> IO (Maybe FilePath)+    findProg prog location | isWindows = \verbosity -> 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+      | otherwise = programFindLocation prog++    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    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 ["-B" ++ libDir, "-I" ++ includeDir]+          UserSpecified {} -> return []+      | otherwise = \_ _   -> return []++    -- we need to find out if ld supports the -x flag+    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureLd verbosity ldProg = do+      tempDir <- getTemporaryDirectory+      ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->+             withTempFile tempDir ".o" $ \testofile testohnd -> do+               hPutStrLn testchnd "int foo() {}"+               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 ["-x"]+        else return []++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 PackageIndex+getInstalledPackages verbosity packagedbs conf = do+  checkPackageDbStack packagedbs+  pkgss <- getInstalledPackages' 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+    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' :: Verbosity -> [PackageDB] -> ProgramConfiguration+                     -> IO [(PackageDB, [InstalledPackageInfo])]+getInstalledPackages' 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) = "--package-conf=" ++ path+++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+  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 recurive 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"+             ]+          ++ ghcProfOptions libBi+      ghcArgsShared = ghcArgs+          ++ ["-dynamic",+              "-hisuf", "dyn_hi",+              "-osuf", "dyn_o", "-fPIC"+             ]+          ++ ghcSharedOptions 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)+      vanillaLibFilePath = libTargetDir </> mkLibName pkgid+      profileLibFilePath = libTargetDir </> mkProfLibName pkgid+      sharedLibFilePath  = libTargetDir </> mkSharedLibName pkgid+                                              (compilerId (compiler lbi))+      ghciLibFilePath    = libTargetDir </> mkGHCiLibName pkgid++  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 <ldLibName>.tmp, and any existing file+            -- named <ldLibName> is included when linking. The+            -- output is renamed to <libName>.+          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"+                     ] ++ ghcProfOptions 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 (withPackageDB 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 :: PackageDBStack -> [String]+ghcPackageDbOptions dbstack = case dbstack of+  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs+  (GlobalPackageDB:dbs)               -> "-no-user-package-conf"+                                       : concatMap specific dbs+  _                                   -> ierror+ where+    specific (SpecificPackageDB db) = [ "-package-conf", db ]+    specific _ = ierror+    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)++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 (withPackageDB lbi)+     ++ ghcPackageFlags lbi clbi+     ++ ["-optc" ++ opt | opt <- PD.ccOptions bi]+     ++ (case withOptimization lbi of+           NoOptimisation -> []+           _              -> ["-optc-O2"])+     ++ ["-odir", odir]++mkGHCiLibName :: PackageIdentifier -> String+mkGHCiLibName lib = "HS" ++ display 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 librarys+              -> FilePath  -- ^Build location+              -> PackageDescription+              -> Library+              -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = 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 $ copy builtDir targetDir vanillaLibName+  ifProf    $ copy builtDir targetDir profileLibName+  ifGHCi    $ copy builtDir targetDir ghciLibName+  ifShared  $ copy builtDir dynlibTargetDir sharedLibName++  -- run ranlib if necessary:+  ifVanilla $ updateLibArchive verbosity lbi+                               (targetDir </> vanillaLibName)+  ifProf    $ updateLibArchive verbosity lbi+                               (targetDir </> profileLibName)++  where+    vanillaLibName = mkLibName pkgid+    profileLibName = mkProfLibName pkgid+    ghciLibName    = mkGHCiLibName pkgid+    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))++    pkgid          = packageId pkg++    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)++-- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems+-- like MacOS X. If we can't find those, don't worry too much about it.+--+updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()+updateLibArchive verbosity lbi path =+  case lookupProgram ranlibProgram (withPrograms lbi) of+    Just ranlib -> rawSystemProgram verbosity ranlib [path]+    Nothing     -> case lookupProgram arProgram (withPrograms lbi) of+      Just ar   -> rawSystemProgram verbosity ar ["-s", path]+      Nothing   -> warn verbosity $+                        "Unable to generate a symbol index for the static "+                     ++ "library '" ++ path+                     ++ "' (missing the 'ranlib' and 'ar' programs)"++-- -----------------------------------------------------------------------------+-- Registering++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do+  let Just lhcPkg = lookupProgram lhcPkgProgram (withPrograms lbi)+  HcPkg.reregister verbosity lhcPkg packageDbs (Right installedPkgInfo)
+ cabal/cabal/Distribution/Simple/LocalBuildInfo.hs view
@@ -0,0 +1,306 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.LocalBuildInfo+-- Copyright   :  Isaac Jones 2003-2004+--+-- 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.++{- 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. -}++module Distribution.Simple.LocalBuildInfo (+        LocalBuildInfo(..),+        externalPackageDeps,+        inplacePackageId,++        -- * Buildable package components+        Component(..),+        foldComponent,+        allComponentsBy,+        ComponentName(..),+        ComponentLocalBuildInfo(..),+        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.PackageDescription+         ( PackageDescription(..), withLib, Library(libBuildInfo), withExe+         , Executable(exeName, buildInfo), withTest, TestSuite(..)+         , BuildInfo(buildable) )+import Distribution.Package+         ( PackageId, Package(..), InstalledPackageId(..) )+import Distribution.Simple.Compiler+         ( Compiler(..), PackageDBStack, OptimisationLevel )+import Distribution.Simple.PackageIndex+         ( PackageIndex )+import Distribution.Simple.Utils+         ( die )+import Distribution.Simple.Setup+         ( ConfigFlags )+import Distribution.Text+         ( display )++import Data.List (nub, find)++-- | 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 differnt+                -- kinds of files+        --TODO: inplaceDirTemplates :: InstallDirs FilePath+        compiler      :: Compiler,+                -- ^ The compiler we're building with+        buildDir      :: FilePath,+                -- ^ Where to build the package.+        --TODO: eliminate hugs's scratchDir, use builddir+        scratchDir    :: FilePath,+                -- ^ Where to put the result of the Hugs build.+        libraryConfig       :: Maybe ComponentLocalBuildInfo,+        executableConfigs   :: [(String, ComponentLocalBuildInfo)],+        compBuildOrder :: [ComponentName],+                -- ^ All the components to build, ordered by topological sort+                -- over the intrapackage dependency graph+        testSuiteConfigs    :: [(String, ComponentLocalBuildInfo)],+        installedPkgs :: PackageIndex,+                -- ^ 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.+        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).+        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+        progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables+        progSuffix    :: PathTemplate -- ^Suffix to be appended to installed executables+  } deriving (Read, Show)++-- | External package dependencies for the package as a whole, the union of the+-- individual 'targetPackageDeps'.+externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]+externalPackageDeps lbi = nub $+  -- TODO:  what about non-buildable components?+     maybe [] componentPackageDeps (libraryConfig lbi)+  ++ concatMap (componentPackageDeps . snd) (executableConfigs 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+               deriving (Show, Eq, Read)++data ComponentName = CLibName  -- currently only a single lib+                   | CExeName  String+                   | CTestName String+                   deriving (Show, Eq, Read)++data ComponentLocalBuildInfo = ComponentLocalBuildInfo {+    -- | 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)]+  }+  deriving (Read, Show)++foldComponent :: (Library -> a)+              -> (Executable -> a)+              -> (TestSuite -> a)+              -> Component+              -> a+foldComponent f _ _ (CLib  lib) = f lib+foldComponent _ f _ (CExe  exe) = f exe+foldComponent _ _ f (CTest tst) = f tst++-- | Obtains all components (libs, exes, or test suites), transformed by the+-- given function.  Useful for gathering dependencies with component context.+allComponentsBy :: PackageDescription+                -> (Component -> a)+                -> [a]+allComponentsBy pkg_descr f =+    [ f (CLib  lib) | Just lib <- [library pkg_descr]+                    , buildable (libBuildInfo lib) ]+ ++ [ f (CExe  exe) | exe <- executables pkg_descr+                    , buildable (buildInfo exe) ]+ ++ [ f (CTest tst) | tst <- testSuites pkg_descr+                    , buildable (testBuildInfo tst)+                    , testEnabled tst ]++-- |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 ->+  case libraryConfig lbi of+    Just clbi -> f lib clbi+    Nothing   -> die missingLibConf++-- | 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 ->+  case lookup (exeName exe) (executableConfigs lbi) of+    Just clbi -> f exe clbi+    Nothing   -> die (missingExeConf (exeName exe))++withTestLBI :: PackageDescription -> LocalBuildInfo+            -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()+withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test ->+  case lookup (testName test) (testSuiteConfigs lbi) of+    Just clbi -> f test clbi+    Nothing -> die (missingTestConf (testName test))++-- | 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'+withComponentsLBI :: PackageDescription -> LocalBuildInfo+                  -> (Component -> ComponentLocalBuildInfo -> IO ())+                  -> IO ()+withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi)+  where+    compF CLibName =+        case library pkg_descr of+          Nothing  -> die missinglib+          Just lib -> case libraryConfig lbi of+                        Nothing   -> die missingLibConf+                        Just clbi -> f (CLib lib) clbi+      where+        missinglib  = "internal error: component list includes a library "+                   ++ "but the package description contains no library"++    compF (CExeName name) =+        case find (\exe -> exeName exe == name) (executables pkg_descr) of+          Nothing  -> die missingexe+          Just exe -> case lookup name (executableConfigs lbi) of+                        Nothing   -> die (missingExeConf name)+                        Just clbi -> f (CExe exe) clbi+      where+        missingexe  = "internal error: component list includes an executable "+                   ++ name ++ " but the package contains no such executable."++    compF (CTestName name) =+        case find (\tst -> testName tst == name) (testSuites pkg_descr) of+          Nothing  -> die missingtest+          Just tst -> case lookup name (testSuiteConfigs lbi) of+                        Nothing   -> die (missingTestConf name)+                        Just clbi -> f (CTest tst) clbi+      where+        missingtest = "internal error: component list includes a test suite "+                   ++ name ++ " but the package contains no such test suite."++missingLibConf :: String+missingExeConf, missingTestConf :: String -> String++missingLibConf       = "internal error: the package contains a library "+                    ++ "but there is no corresponding configuration data"+missingExeConf  name = "internal error: the package contains an executable "+                    ++ name ++ " but there is no corresponding configuration data"+missingTestConf name = "internal error: the package contains a test suite "+                    ++ name ++ " but there is no corresponding configuration data"+++-- -----------------------------------------------------------------------------+-- Wrappers for a couple functions from InstallDirs++-- |See 'InstallDirs.absoluteInstallDirs'+absoluteInstallDirs :: PackageDescription -> LocalBuildInfo -> CopyDest+                    -> InstallDirs FilePath+absoluteInstallDirs pkg lbi copydest =+  InstallDirs.absoluteInstallDirs+    (packageId pkg)+    (compilerId (compiler lbi))+    copydest+    (installDirTemplates lbi)++-- |See 'InstallDirs.prefixRelativeInstallDirs'+prefixRelativeInstallDirs :: PackageId -> LocalBuildInfo+                          -> InstallDirs (Maybe FilePath)+prefixRelativeInstallDirs pkg_descr lbi =+  InstallDirs.prefixRelativeInstallDirs+    (packageId pkg_descr)+    (compilerId (compiler lbi))+    (installDirTemplates lbi)++substPathTemplate :: PackageId -> LocalBuildInfo+                  -> PathTemplate -> FilePath+substPathTemplate pkgid lbi = fromPathTemplate+                                . ( InstallDirs.substPathTemplate env )+    where env = initialPathTemplateEnv+                   pkgid+                   (compilerId (compiler lbi))
+ cabal/cabal/Distribution/Simple/NHC.hs view
@@ -0,0 +1,424 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.NHC+-- Copyright   :  Isaac Jones 2003-2006+--                Duncan Coutts 2009+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module contains most of the NHC-specific code for configuring, building+-- and installing packages.++{- Copyright (c) 2003-2005, Isaac Jones+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. -}++module Distribution.Simple.NHC (+    configure,+    getInstalledPackages,+    buildLib,+    buildExe,+    installLib,+    installExe,+  ) where++import Distribution.Package+         ( PackageName, PackageIdentifier(..), InstalledPackageId(..)+         , packageId, packageName )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo+         , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId+                                , sourcePackageId )+         , emptyInstalledPackageInfo, parseInstalledPackageInfo )+import Distribution.PackageDescription+        ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)+        , hcOptions, usedExtensions )+import Distribution.ModuleName (ModuleName)+import qualified Distribution.ModuleName as ModuleName+import Distribution.Simple.LocalBuildInfo+        ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )+import Distribution.Simple.BuildPaths+        ( mkLibName, objExtension, exeExtension )+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), CompilerId(..), Compiler(..)+         , Flag, languageToFlags, extensionsToFlags+         , PackageDB(..), PackageDBStack )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.PackageIndex (PackageIndex)+import Language.Haskell.Extension+         ( Language(Haskell98), Extension(..), KnownExtension(..) )+import Distribution.Simple.Program+         ( ProgramConfiguration, userMaybeSpecifyPath, programPath+         , requireProgram, requireProgramVersion, lookupProgram+         , nhcProgram, hmakeProgram, ldProgram, arProgram+         , rawSystemProgramConf )+import Distribution.Simple.Utils+        ( die, info, findFileWithExtension, findModuleFiles+        , installOrdinaryFile, installExecutableFile, installOrdinaryFiles+        , createDirectoryIfMissingVerbose, withUTF8FileContents )+import Distribution.Version+        ( Version(..), orLaterVersion )+import Distribution.Verbosity+import Distribution.Text+         ( display, simpleParse )+import Distribution.ParseUtils+         ( ParseResult(..) )++import System.FilePath+        ( (</>), (<.>), normalise, takeDirectory, dropExtension )+import System.Directory+         ( doesFileExist, doesDirectoryExist, getDirectoryContents+         , removeFile, getHomeDirectory )++import Data.Char ( toLower )+import Data.List ( nub )+import Data.Maybe    ( catMaybes )+import Data.Monoid   ( Monoid(..) )+import Control.Monad ( when, unless )+import Distribution.Compat.Exception++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+configure verbosity hcPath _hcPkgPath conf = do++  (_nhcProg, nhcVersion, conf') <-+    requireProgramVersion verbosity nhcProgram+      (orLaterVersion (Version [1,20] []))+      (userMaybeSpecifyPath "nhc98" hcPath conf)++  (_hmakeProg, _hmakeVersion, conf'') <-+    requireProgramVersion verbosity hmakeProgram+     (orLaterVersion (Version [3,13] [])) conf'+  (_ldProg, conf''')   <- requireProgram verbosity ldProgram conf''+  (_arProg, conf'''')  <- requireProgram verbosity arProgram conf'''++  --TODO: put this stuff in a monad so we can say just:+  -- requireProgram hmakeProgram (orLaterVersion (Version [3,13] []))+  -- requireProgram ldProgram anyVersion+  -- requireProgram ldPrograrProgramam anyVersion+  -- unless (null (cSources bi)) $ requireProgram ccProgram anyVersion++  let comp = Compiler {+        compilerId         = CompilerId NHC nhcVersion,+        compilerLanguages  = nhcLanguages,+        compilerExtensions     = nhcLanguageExtensions+      }+  return (comp, conf'''')++nhcLanguages :: [(Language, Flag)]+nhcLanguages = [(Haskell98, "-98")]++-- | The flags for the supported extensions+nhcLanguageExtensions :: [(Extension, Flag)]+nhcLanguageExtensions =+    -- TODO: pattern guards in 1.20+     -- NHC doesn't enforce the monomorphism restriction at all.+     -- Technically it therefore doesn't support MonomorphismRestriction,+     -- but that would mean it doesn't support Haskell98, so we pretend+     -- that it does.+    [(EnableExtension  MonomorphismRestriction,   "")+    ,(DisableExtension MonomorphismRestriction,   "")+     -- Similarly, I assume the FFI is always on+    ,(EnableExtension  ForeignFunctionInterface,  "")+    ,(DisableExtension ForeignFunctionInterface,  "")+     -- Similarly, I assume existential quantification is always on+    ,(EnableExtension  ExistentialQuantification, "")+    ,(DisableExtension ExistentialQuantification, "")+     -- Similarly, I assume empty data decls is always on+    ,(EnableExtension  EmptyDataDecls,            "")+    ,(DisableExtension EmptyDataDecls,            "")+    ,(EnableExtension  NamedFieldPuns,            "-puns")+    ,(DisableExtension NamedFieldPuns,            "-nopuns")+     -- CPP can't actually be turned off, but we pretend that it can+    ,(EnableExtension  CPP,                       "-cpp")+    ,(DisableExtension CPP,                       "")+    ]++getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+                     -> IO PackageIndex+getInstalledPackages verbosity packagedbs conf = do+  homedir      <- getHomeDirectory+  (nhcProg, _) <- requireProgram verbosity nhcProgram conf+  let bindir = takeDirectory (programPath nhcProg)+      incdir = takeDirectory bindir </> "include" </> "nhc98"+      dbdirs = nub (concatMap (packageDbPaths homedir incdir) packagedbs)+  indexes  <- mapM getIndividualDBPackages dbdirs+  return $! mconcat indexes++  where+    getIndividualDBPackages :: FilePath -> IO PackageIndex+    getIndividualDBPackages dbdir = do+      pkgdirs <- getPackageDbDirs dbdir+      pkgs    <- sequence [ getInstalledPackage pkgname pkgdir+                          | (pkgname, pkgdir) <- pkgdirs ]+      let pkgs' = map setInstalledPackageId (catMaybes pkgs)+      return (PackageIndex.fromList pkgs')++packageDbPaths :: FilePath -> FilePath -> PackageDB -> [FilePath]+packageDbPaths _home incdir db = case db of+  GlobalPackageDB        -> [ incdir </> "packages" ]+  UserPackageDB          -> [] --TODO any standard per-user db?+  SpecificPackageDB path -> [ path ]++getPackageDbDirs :: FilePath -> IO [(PackageName, FilePath)]+getPackageDbDirs dbdir = do+  dbexists <- doesDirectoryExist dbdir+  if not dbexists+    then return []+    else do+      entries  <- getDirectoryContents dbdir+      pkgdirs  <- sequence+        [ do pkgdirExists <- doesDirectoryExist pkgdir+             return (pkgname, pkgdir, pkgdirExists)+        | (entry, Just pkgname) <- [ (entry, simpleParse entry)+                                   | entry <- entries ]+        , let pkgdir = dbdir </> entry ]+      return [ (pkgname, pkgdir) | (pkgname, pkgdir, True) <- pkgdirs ]++getInstalledPackage :: PackageName -> FilePath -> IO (Maybe InstalledPackageInfo)+getInstalledPackage pkgname pkgdir = do+  let pkgconfFile = pkgdir </> "package.conf"+  pkgconfExists <- doesFileExist pkgconfFile++  let cabalFile = pkgdir <.> "cabal"+  cabalExists <- doesFileExist cabalFile++  case () of+    _ | pkgconfExists -> getFullInstalledPackageInfo pkgname pkgconfFile+      | cabalExists   -> getPhonyInstalledPackageInfo pkgname cabalFile+      | otherwise     -> return Nothing++getFullInstalledPackageInfo :: PackageName -> FilePath+                            -> IO (Maybe InstalledPackageInfo)+getFullInstalledPackageInfo pkgname pkgconfFile =+  withUTF8FileContents pkgconfFile $ \contents ->+    case parseInstalledPackageInfo contents of+      ParseOk _ pkginfo | packageName pkginfo == pkgname+                        -> return (Just pkginfo)+      _                 -> return Nothing++-- | This is a backup option for existing versions of nhc98 which do not supply+-- proper installed package info files for the bundled libs. Instead we look+-- for the .cabal file and extract the package version from that.+-- We don't know any other details for such packages, in particular we pretend+-- that they have no dependencies.+--+getPhonyInstalledPackageInfo :: PackageName -> FilePath+                             -> IO (Maybe InstalledPackageInfo)+getPhonyInstalledPackageInfo pkgname pathsModule = do+  content <- readFile pathsModule+  case extractVersion content of+    Nothing      -> return Nothing+    Just version -> return (Just pkginfo)+      where+        pkgid   = PackageIdentifier pkgname version+        pkginfo = emptyInstalledPackageInfo { sourcePackageId = pkgid }+  where+    -- search through the .cabal file, looking for a line like:+    --+    -- > version: 2.0+    --+    extractVersion :: String -> Maybe Version+    extractVersion content =+      case catMaybes (map extractVersionLine (lines content)) of+        [version] -> Just version+        _         -> Nothing+    extractVersionLine :: String -> Maybe Version+    extractVersionLine line =+      case words line of+        [versionTag, ":", versionStr]+          | map toLower versionTag == "version"  -> simpleParse versionStr+        [versionTag,      versionStr]+          | map toLower versionTag == "version:" -> simpleParse versionStr+        _                                        -> 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++-- -----------------------------------------------------------------------------+-- Building++-- |FIX: For now, the target must contain a main module.  Not used+-- ATM. Re-add later.+buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib verbosity pkg_descr lbi lib clbi = do+  let conf = withPrograms lbi+      Just nhcProg = lookupProgram nhcProgram conf+  let bi = libBuildInfo lib+      modules = exposedModules lib ++ otherModules bi+      -- Unsupported extensions have already been checked by configure+      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)+                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)+  inFiles <- getModulePaths lbi bi modules+  let targetDir = buildDir lbi+      srcDirs  = nub (map takeDirectory inFiles)+      destDirs = map (targetDir </>) srcDirs+  mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs+  rawSystemProgramConf verbosity hmakeProgram conf $+       ["-hc=" ++ programPath nhcProg]+    ++ nhcVerbosityOptions verbosity+    ++ ["-d", targetDir, "-hidir", targetDir]+    ++ maybe [] (hcOptions NHC . libBuildInfo)+                           (library pkg_descr)+    ++ languageFlags+    ++ concat [ ["-package", display (packageName pkgid) ]+              | (_, pkgid) <- componentPackageDeps clbi ]+    ++ inFiles+{-+  -- build any C sources+  unless (null (cSources bi)) $ do+     info verbosity "Building C Sources..."+     let commonCcArgs = (if verbosity >= deafening then ["-v"] else [])+                     ++ ["-I" ++ dir | dir <- includeDirs bi]+                     ++ [opt | opt <- ccOptions bi]+                     ++ (if withOptimization lbi then ["-O2"] else [])+     flip mapM_ (cSources bi) $ \cfile -> do+       let ofile = targetDir </> cfile `replaceExtension` objExtension+       createDirectoryIfMissingVerbose verbosity True (takeDirectory ofile)+       rawSystemProgramConf verbosity hmakeProgram conf+         (commonCcArgs ++ ["-c", cfile, "-o", ofile])+-}+  -- link:+  info verbosity "Linking..."+  let --cObjs = [ targetDir </> cFile `replaceExtension` objExtension+      --        | cFile <- cSources bi ]+      libFilePath = targetDir </> mkLibName (packageId pkg_descr)+      hObjs = [ targetDir </> ModuleName.toFilePath m <.> objExtension+              | m <- modules ]++  unless (null hObjs {-&& null cObjs-}) $ do+    -- first remove library if it exists+    removeFile libFilePath `catchIO` \_ -> return ()++    let arVerbosity | verbosity >= deafening = "v"+                    | verbosity >= normal = ""+                    | otherwise = "c"++    rawSystemProgramConf verbosity arProgram (withPrograms lbi) $+         ["q"++ arVerbosity, libFilePath]+      ++ hObjs+--    ++ cObjs++-- | Building an executable for NHC.+buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo+                      -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe verbosity pkg_descr lbi exe clbi = do+  let conf = withPrograms lbi+      Just nhcProg = lookupProgram nhcProgram conf+  when (dropExtension (modulePath exe) /= exeName exe) $+    die $ "hmake does not support exe names that do not match the name of "+       ++ "the 'main-is' file. You will have to rename your executable to "+       ++ show (dropExtension (modulePath exe))+  let bi = buildInfo exe+      modules = otherModules bi+      -- Unsupported extensions have already been checked by configure+      languageFlags = languageToFlags (compiler lbi) (defaultLanguage bi)+                   ++ extensionsToFlags (compiler lbi) (usedExtensions bi)+  inFiles <- getModulePaths lbi bi modules+  let targetDir = buildDir lbi </> exeName exe+      exeDir    = targetDir </> (exeName exe ++ "-tmp")+      srcDirs   = nub (map takeDirectory (modulePath exe : inFiles))+      destDirs  = map (exeDir </>) srcDirs+  mapM_ (createDirectoryIfMissingVerbose verbosity True) destDirs+  rawSystemProgramConf verbosity hmakeProgram conf $+       ["-hc=" ++ programPath nhcProg]+    ++ nhcVerbosityOptions verbosity+    ++ ["-d", targetDir, "-hidir", targetDir]+    ++ maybe [] (hcOptions NHC . libBuildInfo)+                           (library pkg_descr)+    ++ languageFlags+    ++ concat [ ["-package", display (packageName pkgid) ]+              | (_, pkgid) <- componentPackageDeps clbi ]+    ++ inFiles+    ++ [exeName exe]++nhcVerbosityOptions :: Verbosity -> [String]+nhcVerbosityOptions verbosity+     | verbosity >= deafening = ["-v"]+     | verbosity >= normal    = []+     | otherwise              = ["-q"]++--TODO: where to put this? it's duplicated in .Simple too+getModulePaths :: LocalBuildInfo -> BuildInfo -> [ModuleName] -> IO [FilePath]+getModulePaths lbi bi modules = sequence+   [ findFileWithExtension ["hs", "lhs"] (buildDir lbi : hsSourceDirs bi)+       (ModuleName.toFilePath module_) >>= maybe (notFound module_) (return . normalise)+   | module_ <- modules ]+   where notFound module_ = die $ "can't find source for module " ++ display module_++-- -----------------------------------------------------------------------------+-- Installing++-- |Install executables for NHC.+installExe :: Verbosity -- ^verbosity+           -> FilePath  -- ^install location+           -> FilePath  -- ^Build location+           -> (FilePath, FilePath)  -- ^Executable (prefix,suffix)+           -> Executable+           -> IO ()+installExe verbosity pref buildPref (progprefix,progsuffix) exe+    = do createDirectoryIfMissingVerbose verbosity True pref+         let exeBaseName = exeName exe+             exeFileName = exeBaseName <.> exeExtension+             fixedExeFileName = (progprefix ++ exeBaseName ++ progsuffix) <.> exeExtension+         installExecutableFile verbosity+           (buildPref </> exeBaseName </> exeFileName)+           (pref </> fixedExeFileName)++-- |Install for nhc98: .hi and .a files+installLib    :: Verbosity -- ^verbosity+              -> FilePath  -- ^install location+              -> FilePath  -- ^Build location+              -> PackageIdentifier+              -> Library+              -> IO ()+installLib verbosity pref buildPref pkgid lib+    = do let bi = libBuildInfo lib+             modules = exposedModules lib ++ otherModules bi+         findModuleFiles [buildPref] ["hi"] modules+           >>= installOrdinaryFiles verbosity pref+         let libName = mkLibName pkgid+         installOrdinaryFile verbosity (buildPref </> libName) (pref </> libName)
+ cabal/cabal/Distribution/Simple/PackageIndex.hs view
@@ -0,0 +1,562 @@+-----------------------------------------------------------------------------+-- |+-- 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+  PackageIndex,++  -- * Creating an index+  fromList,++  -- * Updates+  merge,++  insert,++  deleteInstalledPackageId,+  deleteSourcePackageId,+  deletePackageName,+--  deleteDependency,++  -- * Queries++  -- ** Precise lookups+  lookupInstalledPackageId,+  lookupSourcePackageId,+  lookupPackageName,+  lookupDependency,++  -- ** Case-insensitive searches+  searchByName,+  SearchResult(..),+  searchByNameSubstring,++  -- ** Bulk queries+  allPackages,+  allPackagesByName,++  -- ** Special queries+  brokenPackages,+  dependencyClosure,+  reverseDependencyClosure,+  topologicalOrder,+  reverseTopologicalOrder,+  dependencyInconsistencies,+  dependencyCycles,+  dependencyGraph,+  moduleNameIndex,+  ) where++import Prelude hiding (lookup)+import Control.Exception (assert)+import qualified Data.Map as Map+import Data.Map (Map)+import qualified Data.Tree  as Tree+import qualified Data.Graph as Graph+import qualified Data.Array as Array+import Data.Array ((!))+import Data.List as List+         ( null, foldl', sort+         , groupBy, sortBy, find, isInfixOf, nubBy, deleteBy, deleteFirstsBy )+import Data.Monoid (Monoid(..))+import Data.Maybe (isNothing, fromMaybe)++import Distribution.Package+         ( PackageName(..), PackageId+         , Package(..), packageName, packageVersion+         , Dependency(Dependency)--, --PackageFixedDeps(..)+         , InstalledPackageId(..) )+import Distribution.ModuleName+         ( ModuleName )+import Distribution.InstalledPackageInfo+         ( InstalledPackageInfo, installedPackageId )+import qualified Distribution.InstalledPackageInfo as IPI+import Distribution.Version+         ( Version, withinRange )+import Distribution.Simple.Utils (lowercase, comparing, equating)+++-- | The collection of information about packages from one or more 'PackageDB's.+--+-- Packages are uniquely identified in by their 'InstalledPackageId', they can+-- also be effeciently looked up by package name or by name and version.+--+data PackageIndex = PackageIndex+  -- The primary index. Each InstalledPackageInfo record is uniquely identified+  -- by its InstalledPackageId.+  --+  !(Map InstalledPackageId InstalledPackageInfo)++  -- This auxillary 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.+  --+  !(Map PackageName (Map Version [InstalledPackageInfo]))++  deriving (Show, Read)++instance Monoid PackageIndex 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 :: PackageIndex -> 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 :: Map InstalledPackageId InstalledPackageInfo+               -> Map PackageName (Map Version [InstalledPackageInfo])+               -> PackageIndex+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 :: [InstalledPackageInfo] -> PackageIndex+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 :: PackageIndex -> PackageIndex -> PackageIndex+merge (PackageIndex pids1 pnames1) (PackageIndex pids2 pnames2) =+  mkPackageIndex (Map.union 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 :: InstalledPackageInfo -> PackageIndex -> PackageIndex+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 :: InstalledPackageId -> PackageIndex -> PackageIndex+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 :: PackageId -> PackageIndex -> PackageIndex+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 :: PackageName -> PackageIndex -> PackageIndex+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 -> [InstalledPackageInfo]+allPackages (PackageIndex pids _) = Map.elems pids++-- | Get all the packages from the index.+--+-- They are grouped by package name, case-sensitively.+--+allPackagesByName :: PackageIndex -> [[InstalledPackageInfo]]+allPackagesByName (PackageIndex _ pnames) =+  concatMap Map.elems (Map.elems pnames)++--+-- * 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 :: PackageIndex -> InstalledPackageId+                         -> Maybe InstalledPackageInfo+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 :: PackageIndex -> PackageId -> [InstalledPackageInfo]+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+++-- | Does a lookup by source package name.+--+lookupPackageName :: PackageIndex -> PackageName+                  -> [(Version, [InstalledPackageInfo])]+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 :: PackageIndex -> Dependency+                 -> [(Version, [InstalledPackageInfo])]+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-insentiviely to this name+-- then the search is unambiguous and we get back all versions of that package.+-- If several match case-insentiviely but one matches exactly then it is also+-- unambiguous.+--+-- If however several match case-insentiviely 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 :: PackageIndex -> String -> SearchResult [InstalledPackageInfo]+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 :: PackageIndex -> String -> [InstalledPackageInfo]+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 :: PackageIndex -> [[InstalledPackageInfo]]+dependencyCycles index =+  [ vs | Graph.CyclicSCC vs <- Graph.stronglyConnComp adjacencyList ]+  where+    adjacencyList = [ (pkg, installedPackageId pkg, IPI.depends 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 :: PackageIndex -> [(InstalledPackageInfo, [InstalledPackageId])]+brokenPackages index =+  [ (pkg, missing)+  | pkg  <- allPackages index+  , let missing = [ pkg' | pkg' <- IPI.depends pkg+                         , isNothing (lookupInstalledPackageId index pkg') ]+  , not (null missing) ]+++-- | 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 :: PackageIndex+                  -> [InstalledPackageId]+                  -> Either PackageIndex+                            [(InstalledPackageInfo, [InstalledPackageId])]+dependencyClosure 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 lookupInstalledPackageId index pkgid of+      Nothing   -> closure completed (pkgid:failed) pkgids+      Just pkg  -> case lookupInstalledPackageId completed (installedPackageId pkg) of+        Just _  -> closure completed  failed pkgids+        Nothing -> closure completed' failed pkgids'+          where completed' = insert pkg completed+                pkgids'    = IPI.depends pkg ++ pkgids++-- | Takes the transitive closure of the packages reverse dependencies.+--+-- * The given 'PackageId's must be in the index.+--+reverseDependencyClosure :: PackageIndex+                         -> [InstalledPackageId]+                         -> [InstalledPackageInfo]+reverseDependencyClosure index =+    map vertexToPkg+  . concatMap Tree.flatten+  . Graph.dfs reverseDepGraph+  . map (fromMaybe noSuchPkgId . pkgIdToVertex)++  where+    (depGraph, vertexToPkg, pkgIdToVertex) = dependencyGraph index+    reverseDepGraph = Graph.transposeG depGraph+    noSuchPkgId = error "reverseDependencyClosure: package is not in the graph"++topologicalOrder :: PackageIndex -> [InstalledPackageInfo]+topologicalOrder index = map toPkgId+                       . Graph.topSort+                       $ graph+  where (graph, toPkgId, _) = dependencyGraph index++reverseTopologicalOrder :: PackageIndex -> [InstalledPackageInfo]+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 :: PackageIndex+                -> (Graph.Graph,+                    Graph.Vertex -> InstalledPackageInfo,+                    InstalledPackageId -> Maybe Graph.Vertex)+dependencyGraph index = (graph, vertex_to_pkg, id_to_vertex)+  where+    graph = Array.listArray bounds+              [ [ v | Just v <- map id_to_vertex (IPI.depends 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 pid 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 :: PackageIndex+                          -> [(PackageName, [(PackageId, Version)])]+dependencyInconsistencies 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 PackageName+                            (Map InstalledPackageId+                                 (InstalledPackageInfo, [PackageId]))+        inverseIndex = Map.fromListWith (Map.unionWith (\(a,b) (_,b') -> (a,b++b')))+          [ (packageName dep,+             Map.fromList [(ipid,(dep,[packageId pkg]))])+          | pkg <- allPackages index+          , ipid <- IPI.depends pkg+          , Just dep <- [lookupInstalledPackageId index ipid]+          ]++        reallyIsInconsistent :: [InstalledPackageInfo] -> Bool+        reallyIsInconsistent []       = False+        reallyIsInconsistent [_p]     = False+        reallyIsInconsistent [p1, p2] =+             installedPackageId p1 `notElem` IPI.depends p2+          && installedPackageId p2 `notElem` IPI.depends p1+        reallyIsInconsistent _ = True+++moduleNameIndex :: PackageIndex -> Map ModuleName [InstalledPackageInfo]+moduleNameIndex index =+  Map.fromListWith (++)+    [ (moduleName, [pkg])+    | pkg        <- allPackages index+    , moduleName <- IPI.exposedModules pkg ]
+ cabal/cabal/Distribution/Simple/PreProcess.hs view
@@ -0,0 +1,596 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.PreProcess+-- Copyright   :  (c) 2003-2005, Isaac Jones, Malcolm Wallace+--+-- 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.++{- Copyright (c) 2003-2005, Isaac Jones, Malcolm Wallace+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. -}++module Distribution.Simple.PreProcess (preprocessComponent, knownSuffixHandlers,+                                ppSuffixes, PPSuffixHandler, PreProcessor(..),+                                mkSimplePreProcessor, runSimplePreProcessor,+                                ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,+                                ppHappy, ppAlex, ppUnlit+                               )+    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(..) )+import qualified Distribution.InstalledPackageInfo as Installed+         ( InstalledPackageInfo_(..) )+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.Compiler+         ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), Component(..) )+import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName)+import Distribution.Simple.Utils+         ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File+         , die, setupMessage, intercalate, copyFileVerbose+         , findFileWithExtension, findFileWithExtension' )+import Distribution.Simple.Program+         ( Program(..), ConfiguredProgram(..), programPath+         , lookupProgram, requireProgram, requireProgramVersion+         , rawSystemProgramConf, rawSystemProgram+         , greencardProgram, cpphsProgram, hsc2hsProgram, c2hsProgram+         , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram )+import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName )+import Distribution.System+         ( OS(OSX, Windows), buildOS )+import Distribution.Text+import Distribution.Version+         ( Version(..), anyVersion, orLaterVersion )+import Distribution.Verbosity++import Data.Maybe (fromMaybe)+import Data.List (nub)+import System.Directory (getModificationTime, 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 genereated 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 genereated 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+  where+    builtinSuffixes+      | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]+      | otherwise                            = ["hs", "lhs"]+    localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]+    pre dirs dir lhndlrs fp =+      preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs+    preProcessTest test exePath testDir = do+        let bi = testBuildInfo test+            biHandlers = localHandlers bi+            sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]+        sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist+                (ModuleName.toFilePath modu) verbosity builtinSuffixes+                biHandlers+                | modu <- testModules test ]+        preprocessFile (testDir : (hsSourceDirs bi)) testDir 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 -> do+                              btime <- getModificationTime ppsrcFile+                              ptime <- getModificationTime psrcFile+                              return (btime < ptime)+              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 (cppArgs ++ extraArgs) bi lbi+    _   -> ppCpphs  (cppArgs ++ extraArgs) bi lbi++  where cppArgs = getCppOptions bi lbi++ppGhcCpp :: [String] -> BuildInfo -> LocalBuildInfo -> PreProcessor+ppGhcCpp extraArgs _bi lbi =+  PreProcessor {+    platformIndependent = False,+    runPreProcessor = mkSimplePreProcessor $ \inFile outFile verbosity -> do+      (ghcProg, ghcVersion, _) <- requireProgramVersion verbosity+                                    ghcProgram anyVersion (withPrograms lbi)+      rawSystemProgram verbosity ghcProg $+          ["-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 ghcVersion >= Version [6,6] [] then ["-x", "hs"] else [])+       ++ (if use_optP_P lbi then ["-optP-P"] 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+  }++-- Haddock versions before 0.8 choke on #line and #file pragmas.  Those+-- pragmas are necessary for correct links when we preprocess.  So use+-- -optP-P only if the Haddock version is prior to 0.8.+use_optP_P :: LocalBuildInfo -> Bool+use_optP_P lbi+ = case lookupProgram haddockProgram (withPrograms lbi) of+     Just (ConfiguredProgram { programVersion = Just version })+       | version >= Version [0,8] [] -> False+     _                               -> True++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 <- hcDefines (compiler lbi) ]+       ++ [ "--cflag="   ++ opt | opt <- sysDefines ]++          -- Options from the current package:+       ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]+       ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi+                                      ++ PD.cppOptions   bi ]+       ++ [ "--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 ]+                ++ [ "-I" ++ autogenModulesDir lbi,+                     "-include", autogenModulesDir lbi </> cppHeaderName ] ]+       ++ [ "--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+      _   -> 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+    = hcDefines (compiler lbi)+   ++ sysDefines+   ++ cppOptions bi+   ++ ["-I" ++ dir | dir <- PD.includeDirs bi]+   ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"]++sysDefines :: [String]+sysDefines = ["-D" ++ os   ++ "_" ++ loc ++ "_OS"   | loc <- locations]+          ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations]+  where+    locations = ["BUILD", "HOST"]++hcDefines :: Compiler -> [String]+hcDefines comp =+  case compilerFlavor comp of+    GHC  -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]+    JHC  -> ["-D__JHC__=" ++ versionInt version]+    NHC  -> ["-D__NHC__=" ++ versionInt version]+    Hugs -> ["-D__HUGS__"]+    _    -> []+  where version = compilerVersion 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++ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor+ppHappy _ lbi = pp { platformIndependent = True }+  where pp = standardPP lbi happyProgram (hcFlags hc)+        hc = compilerFlavor (compiler lbi)+        hcFlags GHC = ["-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 _ = []++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/cabal/Distribution/Simple/PreProcess/Unlit.hs view
@@ -0,0 +1,165 @@+-----------------------------------------------------------------------------+-- |+-- 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/cabal/Distribution/Simple/Program.hs view
@@ -0,0 +1,217 @@+-----------------------------------------------------------------------------+-- |+-- 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(..)+    , simpleProgram+    , findProgramLocation+    , findProgramVersion++    -- * Configured program and related functions+    , ConfiguredProgram(..)+    , programPath+    , ProgArg+    , ProgramLocation(..)+    , runProgram+    , getProgramOutput++    -- * Program invocations+    , ProgramInvocation(..)+    , emptyProgramInvocation+    , simpleProgramInvocation+    , programInvocation+    , runProgramInvocation+    , getProgramInvocationOutput++    -- * The collection of unconfigured and configured progams+    , builtinPrograms++    -- * The collection of configured programs we can run+    , ProgramConfiguration+    , emptyProgramConfiguration+    , defaultProgramConfiguration+    , restoreProgramConfiguration+    , addKnownProgram+    , addKnownPrograms+    , lookupKnownProgram+    , knownPrograms+    , userSpecifyPath+    , userSpecifyPaths+    , userMaybeSpecifyPath+    , userSpecifyArgs+    , userSpecifyArgss+    , userSpecifiedArgs+    , lookupProgram+    , updateProgram+    , configureProgram+    , configureAllKnownPrograms+    , reconfigurePrograms+    , requireProgram+    , requireProgramVersion+    , runDbProgram+    , getDbProgramOutput++    -- * Programs that Cabal knows about+    , ghcProgram+    , ghcPkgProgram+    , lhcProgram+    , lhcPkgProgram+    , nhcProgram+    , hmakeProgram+    , jhcProgram+    , hugsProgram+    , ffihugsProgram+    , uhcProgram+    , gccProgram+    , ranlibProgram+    , arProgram+    , stripProgram+    , happyProgram+    , alexProgram+    , hsc2hsProgram+    , c2hsProgram+    , cpphsProgram+    , hscolourProgram+    , haddockProgram+    , greencardProgram+    , ldProgram+    , tarProgram+    , cppProgram+    , pkgConfigProgram++    -- * 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/cabal/Distribution/Simple/Program/Ar.hs view
@@ -0,0 +1,70 @@+-----------------------------------------------------------------------------+-- |+-- 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 Distribution.Simple.Program.Types+         ( ConfiguredProgram(..) )+import Distribution.Simple.Program.Run+         ( programInvocation, multiStageProgramInvocation+         , runProgramInvocation )+import Distribution.System+         ( OS(..), buildOS )+import Distribution.Verbosity+         ( Verbosity, deafening, verbose )++-- | Call @ar@ to create a library archive from a bunch of object files.+--+createArLibArchive :: Verbosity -> ConfiguredProgram+                   -> FilePath -> [FilePath] -> IO ()+createArLibArchive verbosity ar target files =++  -- 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 buildOS of+             OSX -> ["-r", "-s"]+             _   -> ["-r"]++      initialArgs = ["-q"]+      finalArgs   = case buildOS of+             OSX -> ["-q", "-s"]+             _   -> ["-q"]++      extraArgs   = verbosityOpts verbosity ++ [target]++      simple  = programInvocation ar (simpleArgs  ++ extraArgs)+      initial = programInvocation ar (initialArgs ++ extraArgs)+      middle  = initial+      final   = programInvocation ar (finalArgs   ++ extraArgs)++   in sequence_+        [ runProgramInvocation verbosity inv+        | inv <- multiStageProgramInvocation+                   simple (initial, middle, final) files ]++  where+    verbosityOpts v | v >= deafening = ["-v"]+                    | v >= verbose   = []+                    | otherwise      = ["-c"]
+ cabal/cabal/Distribution/Simple/Program/Builtin.hs view
@@ -0,0 +1,259 @@+-----------------------------------------------------------------------------+-- |+-- 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 progams+    builtinPrograms,++    -- * Programs that Cabal knows about+    ghcProgram,+    ghcPkgProgram,+    lhcProgram,+    lhcPkgProgram,+    nhcProgram,+    hmakeProgram,+    jhcProgram,+    hugsProgram,+    ffihugsProgram,+    uhcProgram,+    gccProgram,+    ranlibProgram,+    arProgram,+    stripProgram,+    happyProgram,+    alexProgram,+    hsc2hsProgram,+    c2hsProgram,+    cpphsProgram,+    hscolourProgram,+    haddockProgram,+    greencardProgram,+    ldProgram,+    tarProgram,+    cppProgram,+    pkgConfigProgram,+  ) where++import Distribution.Simple.Program.Types+         ( Program(..), simpleProgram )+import Distribution.Simple.Utils+         ( findProgramLocation, findProgramVersion )++-- ------------------------------------------------------------+-- * Known programs+-- ------------------------------------------------------------++-- | The default list of programs.+-- These programs are typically used internally to Cabal.+builtinPrograms :: [Program]+builtinPrograms =+    [+    -- compilers and related progs+      ghcProgram+    , ghcPkgProgram+    , hugsProgram+    , ffihugsProgram+    , nhcProgram+    , hmakeProgram+    , jhcProgram+    , lhcProgram+    , lhcPkgProgram+    , uhcProgram+    -- preprocessors+    , hscolourProgram+    , haddockProgram+    , happyProgram+    , alexProgram+    , hsc2hsProgram+    , c2hsProgram+    , cpphsProgram+    , greencardProgram+    -- platform toolchain+    , gccProgram+    , ranlibProgram+    , arProgram+    , stripProgram+    , ldProgram+    , tarProgram+    -- configuration tools+    , pkgConfigProgram+    ]++ghcProgram :: Program+ghcProgram = (simpleProgram "ghc") {+    programFindVersion = findProgramVersion "--numeric-version" id+  }++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+        _               -> ""+  }++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+        _               -> ""+  }++nhcProgram :: Program+nhcProgram = (simpleProgram "nhc98") {+    programFindVersion = findProgramVersion "--version" $ \str ->+      -- Invoking "nhc98 --version" gives a string like+      -- "/usr/local/bin/nhc98: v1.20 (2007-11-22)"+      case words str of+        (_:('v':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+  }+++-- AArgh! Finding the version of hugs or ffihugs is almost impossible.+hugsProgram :: Program+hugsProgram = simpleProgram "hugs"++ffihugsProgram :: Program+ffihugsProgram = simpleProgram "ffihugs"++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 (`elem` ('.':['0'..'9'])) ver+        _           -> ""+  }++gccProgram :: Program+gccProgram = (simpleProgram "gcc") {+    programFindVersion = findProgramVersion "-dumpversion" id+  }++ranlibProgram :: Program+ranlibProgram = simpleProgram "ranlib"++arProgram :: Program+arProgram = simpleProgram "ar"++stripProgram :: Program+stripProgram = simpleProgram "strip"++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 -> findProgramLocation v "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"++cppProgram :: Program+cppProgram = simpleProgram "cpp"++pkgConfigProgram :: Program+pkgConfigProgram = (simpleProgram "pkg-config") {+    programFindVersion = findProgramVersion "--version" id+  }
+ cabal/cabal/Distribution/Simple/Program/Db.hs view
@@ -0,0 +1,409 @@+-----------------------------------------------------------------------------+-- |+-- 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,+    userSpecifyPath,+    userSpecifyPaths,+    userMaybeSpecifyPath,+    userSpecifyArgs,+    userSpecifyArgss,+    userSpecifiedArgs,+    lookupProgram,+    updateProgram,++    -- ** Query and manipulate the program db+    configureProgram,+    configureAllKnownPrograms,+    reconfigurePrograms,+    requireProgram,+    requireProgramVersion,++  ) where++import Distribution.Simple.Program.Types+         ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) )+import Distribution.Simple.Program.Builtin+         ( builtinPrograms )+import Distribution.Simple.Utils+         ( die, findProgramLocation )+import Distribution.Version+         ( Version, VersionRange, isAnyVersion, withinRange )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import Data.List+         ( foldl' )+import Data.Maybe+         ( catMaybes )+import qualified Data.Map as Map+import Control.Monad+         ( join, foldM )+import System.Directory+         ( doesFileExist )+++-- ------------------------------------------------------------+-- * 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,+        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 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 ]+++-- | 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) ]+++-- |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+++-- ---------------------------+-- Configuring known programs++-- | Try to configure a specific program. If the program is already included in+-- the colleciton of unconfigured programs then we use any user-supplied+-- location and arguments. If the program gets configured sucessfully 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 sucessfully 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+             >>= return . fmap FoundOnSystem+    Just path -> do+      absolute <- doesFileExist path+      if absolute+        then return (Just (UserSpecified path))+        else findProgramLocation verbosity path+         >>= maybe (die notFound) (return . Just . UserSpecified)+      where notFound = "Cannot find the program '" ++ name ++ "' at '"+                     ++ path ++ "' or on the path"+  case maybeLocation of+    Nothing -> return conf+    Just location -> do+      version <- programFindVersion prog verbosity (locationPath location)+      let configuredProg        = ConfiguredProgram {+            programId           = name,+            programVersion      = version,+            programDefaultArgs  = [],+            programOverrideArgs = userSpecifiedArgs prog conf,+            programLocation     = location+          }+      extraArgs <- programPostConf prog verbosity configuredProg+      let configuredProg'       = configuredProg {+            programDefaultArgs  = extraArgs+          }+      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 version of the program number is suitable and+-- return it. For example you could require 'AnyVersion' or+-- @'orLaterVersion' ('Version' [1,0] [])@+--+-- It raises an exception if the program could not be configured or the version+-- is unsuitable, otherwise it returns the configured program and its version+-- number.+--+requireProgramVersion :: Verbosity -> Program -> VersionRange+                      -> ProgramDb+                      -> IO (ConfiguredProgram, Version, ProgramDb)+requireProgramVersion verbosity prog range 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@ConfiguredProgram { programLocation = location } ->+      case programVersion configuredProg of+        Just version+          | withinRange version range -> return (configuredProg, version, conf')+          | otherwise                 -> die (badVersion version location)+        Nothing                       -> die (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
+ cabal/cabal/Distribution/Simple/Program/HcPkg.hs view
@@ -0,0 +1,338 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Program.HcPkg+-- 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.HcPkg (+    register,+    reregister,+    unregister,+    expose,+    hide,+    dump,++    -- * Program invocations+    registerInvocation,+    reregisterInvocation,+    unregisterInvocation,+    exposeInvocation,+    hideInvocation,+    dumpInvocation,+  ) where++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, programVersion) )+import Distribution.Simple.Program.Run+         ( ProgramInvocation(..), IOEncoding(..), programInvocation+         , runProgramInvocation, getProgramInvocationOutput )+import Distribution.Version+         ( Version(..) )+import Distribution.Text+         ( display )+import Distribution.Simple.Utils+         ( die )+import Distribution.Verbosity+         ( Verbosity, deafening, silent )+import Distribution.Compat.Exception+         ( catchExit )++import Data.Char+         ( isSpace )+import Data.Maybe+         ( fromMaybe )+import Data.List+         ( stripPrefix )+import System.FilePath as FilePath+         ( (</>), splitPath, splitDirectories, joinPath, isPathSeparator )+import qualified System.FilePath.Posix as FilePath.Posix+++-- | Call @hc-pkg@ to register a package.+--+-- > hc-pkg register {filename | -} [--user | --global | --package-conf]+--+register :: Verbosity -> ConfiguredProgram -> PackageDBStack+         -> Either FilePath+                   InstalledPackageInfo+         -> IO ()+register verbosity hcPkg packagedb pkgFile =+  runProgramInvocation verbosity+    (registerInvocation hcPkg verbosity packagedb pkgFile)+++-- | Call @hc-pkg@ to re-register a package.+--+-- > hc-pkg register {filename | -} [--user | --global | --package-conf]+--+reregister :: Verbosity -> ConfiguredProgram -> PackageDBStack+           -> Either FilePath+                     InstalledPackageInfo+           -> IO ()+reregister verbosity hcPkg packagedb pkgFile =+  runProgramInvocation verbosity+    (reregisterInvocation hcPkg verbosity packagedb pkgFile)+++-- | Call @hc-pkg@ to unregister a package+--+-- > hc-pkg unregister [pkgid] [--user | --global | --package-conf]+--+unregister :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()+unregister verbosity hcPkg packagedb pkgid =+  runProgramInvocation verbosity+    (unregisterInvocation hcPkg verbosity packagedb pkgid)+++-- | Call @hc-pkg@ to expose a package.+--+-- > hc-pkg expose [pkgid] [--user | --global | --package-conf]+--+expose :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()+expose verbosity hcPkg packagedb pkgid =+  runProgramInvocation verbosity+    (exposeInvocation hcPkg verbosity packagedb pkgid)+++-- | Call @hc-pkg@ to expose a package.+--+-- > hc-pkg expose [pkgid] [--user | --global | --package-conf]+--+hide :: Verbosity -> ConfiguredProgram -> PackageDB -> PackageId -> IO ()+hide verbosity hcPkg packagedb pkgid =+  runProgramInvocation verbosity+    (hideInvocation hcPkg verbosity packagedb pkgid)+++-- | Call @hc-pkg@ to get all the installed packages.+--+dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo]+dump verbosity hcPkg packagedb = do++  output <- getProgramInvocationOutput verbosity+              (dumpInvocation hcPkg verbosity packagedb)+    `catchExit` \_ -> die $ programId hcPkg ++ " dump failed"++  case parsePackages output of+    Left ok -> return ok+    _       -> die $ "failed to parse output of '"+                  ++ programId hcPkg ++ " dump'"++  where+    parsePackages str =+      let parsed = map parseInstalledPackageInfo' (splitPkgs str)+       in case [ msg | ParseFailed msg <- parsed ] of+            []   -> Left [   setInstalledPackageId+                           . maybe id mungePackagePaths pkgroot+                           $ pkg+                         | ParseOk _ (pkgroot, pkg) <- parsed ]+            msgs -> Right msgs++    parseInstalledPackageInfo' =+        parseFieldsFlat fields (Nothing, emptyInstalledPackageInfo)+      where+        fields =     liftFieldFst pkgrootField+               : map liftFieldSnd fieldsInstalledPackageInfo++        pkgrootField =+          simpleField "pkgroot"+            showFilePath    parseFilePathQ+            (fromMaybe "")  (\x _ -> Just x)++        liftFieldFst = liftField fst (\x (_x,y) -> (x,y))+        liftFieldSnd = liftField snd (\y (x,_y) -> (x,y))++    --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+++--------------------------+-- The program invocations+--++registerInvocation, reregisterInvocation+  :: ConfiguredProgram -> Verbosity -> PackageDBStack+  -> Either FilePath InstalledPackageInfo+  -> ProgramInvocation+registerInvocation   = registerInvocation' "register"+reregisterInvocation = registerInvocation' "update"+++registerInvocation' :: String+                    -> ConfiguredProgram -> Verbosity -> PackageDBStack+                    -> Either FilePath InstalledPackageInfo+                    -> ProgramInvocation+registerInvocation' cmdname hcPkg verbosity packagedbs (Left pkgFile) =+    programInvocation hcPkg args+  where+    args = [cmdname, pkgFile]+        ++ (if legacyVersion hcPkg+              then [packageDbOpts (last packagedbs)]+              else packageDbStackOpts packagedbs)+        ++ verbosityOpts hcPkg verbosity++registerInvocation' cmdname hcPkg verbosity packagedbs (Right pkgInfo) =+    (programInvocation hcPkg args) {+      progInvokeInput         = Just (showInstalledPackageInfo pkgInfo),+      progInvokeInputEncoding = IOEncodingUTF8+    }+  where+    args = [cmdname, "-"]+        ++ (if legacyVersion hcPkg+              then [packageDbOpts (last packagedbs)]+              else packageDbStackOpts packagedbs)+        ++ verbosityOpts hcPkg verbosity+++unregisterInvocation :: ConfiguredProgram+                     -> Verbosity -> PackageDB -> PackageId+                     -> ProgramInvocation+unregisterInvocation hcPkg verbosity packagedb pkgid =+  programInvocation hcPkg $+       ["unregister", packageDbOpts packagedb, display pkgid]+    ++ verbosityOpts hcPkg verbosity+++exposeInvocation :: ConfiguredProgram+                 -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation+exposeInvocation hcPkg verbosity packagedb pkgid =+  programInvocation hcPkg $+       ["expose", packageDbOpts packagedb, display pkgid]+    ++ verbosityOpts hcPkg verbosity+++hideInvocation :: ConfiguredProgram+               -> Verbosity -> PackageDB -> PackageId -> ProgramInvocation+hideInvocation hcPkg verbosity packagedb pkgid =+  programInvocation hcPkg $+       ["hide", packageDbOpts packagedb, display pkgid]+    ++ verbosityOpts hcPkg verbosity+++dumpInvocation :: ConfiguredProgram+               -> Verbosity -> PackageDB -> ProgramInvocation+dumpInvocation hcPkg _verbosity packagedb =+    (programInvocation hcPkg args) {+      progInvokeOutputEncoding = IOEncodingUTF8+    }+  where+    args = ["dump", packageDbOpts packagedb]+        ++ verbosityOpts hcPkg silent+           -- We use verbosity level 'silent' because it is important that we+           -- do not contaminate the output with info/debug messages.+++packageDbStackOpts :: PackageDBStack -> [String]+packageDbStackOpts dbstack = case dbstack of+  (GlobalPackageDB:UserPackageDB:dbs) -> "--global"+                                       : "--user"+                                       : map specific dbs+  (GlobalPackageDB:dbs)               -> "--global"+                                       : "--no-user-package-conf"+                                       : map specific dbs+  _                                   -> ierror+  where+    specific (SpecificPackageDB db) = "--package-conf=" ++ db+    specific _ = ierror+    ierror :: a+    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)++packageDbOpts :: PackageDB -> String+packageDbOpts GlobalPackageDB        = "--global"+packageDbOpts UserPackageDB          = "--user"+packageDbOpts (SpecificPackageDB db) = "--package-conf=" ++ db++verbosityOpts :: ConfiguredProgram -> Verbosity -> [String]+verbosityOpts hcPkg v++  -- ghc-pkg < 6.11 does not support -v+  | programId hcPkg == "ghc-pkg"+ && programVersion hcPkg < Just (Version [6,11] [])+                   = []++  | v >= deafening = ["-v2"]+  | v == silent    = ["-v0"]+  | otherwise      = []++-- Handle quirks in ghc-pkg 6.8 and older+legacyVersion :: ConfiguredProgram -> Bool+legacyVersion hcPkg = programId hcPkg == "ghc-pkg"+                   && programVersion hcPkg < Just (Version [6,9] [])
+ cabal/cabal/Distribution/Simple/Program/Ld.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- 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/cabal/Distribution/Simple/Program/Run.hs view
@@ -0,0 +1,218 @@+-----------------------------------------------------------------------------+-- |+-- 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,++  ) where++import Distribution.Simple.Program.Types+         ( ConfiguredProgram(..), programPath )+import Distribution.Simple.Utils+         ( die, rawSystemExit, rawSystemStdInOut+         , toUTF8, fromUTF8, normaliseLineEndings )+import Distribution.Verbosity+         ( Verbosity )++import Data.List+         ( foldl', unfoldr )+import Control.Monad+         ( when )+import System.Exit+         ( ExitCode(..) )++-- | 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, 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+  }+++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   = [],+    progInvokeCwd   = Nothing,+    progInvokeInput = Just inputStr,+    progInvokeInputEncoding = encoding+  } = do+    (_, errors, exitCode) <- rawSystemStdInOut verbosity+                                    path args+                                    (Just input) False+    when (exitCode /= ExitSuccess) $+      die errors+  where+    input = case encoding of+              IOEncodingText -> (inputStr, False)+              IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8++runProgramInvocation _ _ =+   die "runProgramInvocation: not yet implemented for this form of invocation"+++getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String+getProgramInvocationOutput verbosity+  ProgramInvocation {+    progInvokePath  = path,+    progInvokeArgs  = args,+    progInvokeEnv   = [],+    progInvokeCwd   = Nothing,+    progInvokeInput = Nothing,+    progInvokeOutputEncoding = encoding+  } = do+  let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False+      decode | utf8      = fromUTF8 . normaliseLineEndings+             | otherwise = id+  (output, errors, exitCode) <- rawSystemStdInOut verbosity+                                  path args+                                  Nothing utf8+  when (exitCode /= ExitSuccess) $+    die errors+  return (decode output)+++getProgramInvocationOutput _ _ =+   die "getProgramInvocationOutput: not yet implemented for this form of invocation"+++-- | 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/cabal/Distribution/Simple/Program/Script.hs view
@@ -0,0 +1,105 @@+-----------------------------------------------------------------------------+-- |+-- 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" ]+       ++ [ "export " ++ var ++ "=" ++ quote val+          | (var,val) <- envExtra ]+       ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]+       ++ [ (case minput of+              Nothing    -> ""+              Just input -> "echo " ++ quote input ++ " | ")+         ++ unwords (map quote $ path : args) ++ " \"$@\""]++  where+    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" ]+       ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- 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+    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/cabal/Distribution/Simple/Program/Types.hs view
@@ -0,0 +1,122 @@+-----------------------------------------------------------------------------+-- |+-- 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(..),+    internalProgram,+    simpleProgram,++    -- * Configured program and related functions+    ConfiguredProgram(..),+    programPath,+    ProgArg,+    ProgramLocation(..),+  ) where++import Data.List (nub) +import System.FilePath ((</>))++import Distribution.Simple.Utils+         ( findProgramLocation, findFirstFile )+import Distribution.Version+         ( Version )+import Distribution.Verbosity+         ( Verbosity )++-- | Represents a program which can be configured.+data Program = Program {+       -- | The simple name of the program, eg. ghc+       programName :: String,++       -- | A function to search for the program if it's location was not+       -- specified by the user. Usually this will just be a+       programFindLocation :: Verbosity -> 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). It is+       -- allowed to return additional flags that will be passed to the+       -- program on every invocation.+       programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+     }++type ProgArg = String++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],++       -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@+       programLocation :: ProgramLocation+     } deriving (Read, Show, Eq)++-- | Where a program was found. Also tells us whether it's specifed 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 location of the program, as located by searching PATH.+      deriving (Read, Show, Eq)++-- | The full path of a configured program.+programPath :: ConfiguredProgram -> FilePath+programPath = locationPath . programLocation++-- | 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   -> findProgramLocation v name,+    programFindVersion  = \_ _ -> return Nothing,+    programPostConf     = \_ _ -> return []+  }++-- | Make a simple 'internal' program; that is, one that was built as an+-- executable already and is expected to be found in the build directory+internalProgram :: [FilePath] -> String -> Program+internalProgram paths name = Program {+  programName         = name,+  programFindLocation = \_v ->+    findFirstFile id [ path </> name | path <- nub paths ],+    programFindVersion  = \_ _ -> return Nothing,+    programPostConf     = \_ _ -> return []+  }+
+ cabal/cabal/Distribution/Simple/Register.hs view
@@ -0,0 +1,390 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Register+-- Copyright   :  Isaac Jones 2003-2004+--+-- 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 inplace 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.++{- Copyright (c) 2003-2004, Isaac Jones+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. -}++module Distribution.Simple.Register (+    register,+    unregister,++    registerPackage,+    generateRegistrationInfo,+    inplaceInstalledPackageInfo,+    absoluteInstalledPackageInfo,+    generalInstalledPackageInfo,+  ) where++import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , InstallDirs(..), absoluteInstallDirs )+import Distribution.Simple.BuildPaths (haddockName)+import qualified Distribution.Simple.GHC  as GHC+import qualified Distribution.Simple.LHC  as LHC+import qualified Distribution.Simple.Hugs as Hugs+import qualified Distribution.Simple.UHC  as UHC+import Distribution.Simple.Compiler+         ( compilerVersion, CompilerFlavor(..), compilerFlavor+         , PackageDBStack, registrationPackageDB )+import Distribution.Simple.Program+         ( ConfiguredProgram, runProgramInvocation+         , requireProgram, lookupProgram, ghcPkgProgram, lhcPkgProgram )+import Distribution.Simple.Program.Script+         ( invocationAsSystemScript )+import qualified Distribution.Simple.Program.HcPkg as HcPkg+import Distribution.Simple.Setup+         ( RegisterFlags(..), CopyDest(..)+         , fromFlag, fromFlagOrDefault, flagToMaybe )+import Distribution.PackageDescription+         ( PackageDescription(..), Library(..), BuildInfo(..), hcOptions )+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 )+import Distribution.System+         ( OS(..), buildOS )+import Distribution.Text+         ( display )+import Distribution.Version ( Version(..) )+import Distribution.Verbosity as Verbosity+         ( Verbosity, normal )+import Distribution.Compat.Exception+         ( tryIO )++import System.FilePath ((</>), (<.>), isAbsolute)+import System.Directory+         ( getCurrentDirectory, removeDirectoryRecursive )++import Data.Maybe+         ( isJust, fromMaybe, maybeToList )+import Data.List+         ( partition, nub )+++-- -----------------------------------------------------------------------------+-- Registration++register :: PackageDescription -> LocalBuildInfo+         -> RegisterFlags -- ^Install in the user's database?; verbose+         -> IO ()+register pkg@PackageDescription { library       = Just lib  }+         lbi@LocalBuildInfo     { libraryConfig = Just clbi } regFlags+  = do++    installedPkgInfo <- generateRegistrationInfo+                           verbosity pkg lib lbi clbi inplace distPref++     -- 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)+    -- 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+        GHC  -> do (ghcPkg, _) <- requireProgram verbosity ghcPkgProgram (withPrograms lbi)+                   writeHcPkgRegisterScript verbosity installedPkgInfo ghcPkg packageDbs+        LHC  -> do (lhcPkg, _) <- requireProgram verbosity lhcPkgProgram (withPrograms lbi)+                   writeHcPkgRegisterScript verbosity installedPkgInfo lhcPkg packageDbs+        Hugs -> notice verbosity "Registration scripts not needed for hugs"+        JHC  -> notice verbosity "Registration scripts not needed for jhc"+        NHC  -> notice verbosity "Registration scripts not needed for nhc98"+        UHC  -> notice verbosity "Registration scripts not needed for uhc"+        _    -> die "Registration scripts are not implemented for this compiler"++register _ _ regFlags = notice verbosity "No package to register"+  where+    verbosity = fromFlag (regVerbosity regFlags)+++generateRegistrationInfo :: Verbosity+                         -> PackageDescription+                         -> Library+                         -> LocalBuildInfo+                         -> ComponentLocalBuildInfo+                         -> Bool+                         -> FilePath+                         -> IO InstalledPackageInfo+generateRegistrationInfo verbosity pkg lib lbi clbi inplace distPref = 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))+     _other -> do+            return (InstalledPackageId (display (packageId pkg)))++  let installedPkgInfo+        | inplace   = inplaceInstalledPackageInfo pwd distPref+                        pkg lib lbi clbi+        | otherwise = absoluteInstalledPackageInfo+                        pkg lib lbi clbi++  return installedPkgInfo{ IPI.installedPackageId = ipid }+++registerPackage :: Verbosity+                -> InstalledPackageInfo+                -> PackageDescription+                -> LocalBuildInfo+                -> Bool+                -> PackageDBStack+                -> IO ()+registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs = do+  setupMessage verbosity "Registering" (packageId pkg)+  case compilerFlavor (compiler lbi) of+    GHC  -> GHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs+    LHC  -> LHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs+    Hugs -> Hugs.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)"+    NHC  -> notice verbosity "Registering for nhc98 (nothing to do)"+    _    -> die "Registering is not implemented for this compiler"+++writeHcPkgRegisterScript :: Verbosity+                         -> InstalledPackageInfo+                         -> ConfiguredProgram+                         -> PackageDBStack+                         -> IO ()+writeHcPkgRegisterScript verbosity installedPkgInfo hcPkg packageDbs = do+  let invocation  = HcPkg.reregisterInvocation hcPkg 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+  -> Library+  -> ComponentLocalBuildInfo+  -> InstallDirs FilePath+  -> InstalledPackageInfo+generalInstalledPackageInfo adjustRelIncDirs pkg lib clbi installDirs =+  InstalledPackageInfo {+    --TODO: do not open-code this conversion from PackageId to InstalledPackageId+    IPI.installedPackageId = InstalledPackageId (display (packageId pkg)),+    IPI.sourcePackageId    = packageId   pkg,+    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     = exposedModules lib,+    IPI.hiddenModules      = otherModules bi,+    IPI.trusted            = False,+    IPI.importDirs         = [ libdir installDirs | hasModules ],+    IPI.libraryDirs        = if hasLibrary+                               then libdir installDirs : extraLibDirs bi+                               else                      extraLibDirs bi,+    IPI.hsLibraries        = [ "HS" ++ display (packageId pkg) | hasLibrary ],+    IPI.extraLibraries     = extraLibs bi,+    IPI.extraGHCiLibraries = [],+    IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,+    IPI.includes           = includes bi,+    IPI.depends            = map fst (componentPackageDeps clbi),+    IPI.hugsOptions        = hcOptions Hugs bi,+    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]+  }+  where+    bi = libBuildInfo lib+    (absinc, relinc) = partition isAbsolute (includeDirs bi)+    hasModules = not $ null (exposedModules lib)+                    && null (otherModules bi)+    hasLibrary = hasModules || not (null (cSources bi))+++-- | Construct 'InstalledPackageInfo' for a library that is inplace in the+-- build tree.+--+-- This function knows about the layout of inplace packages.+--+inplaceInstalledPackageInfo :: FilePath -- ^ top of the build tree+                            -> FilePath -- ^ location of the dist tree+                            -> PackageDescription+                            -> Library+                            -> LocalBuildInfo+                            -> ComponentLocalBuildInfo+                            -> InstalledPackageInfo+inplaceInstalledPackageInfo inplaceDir distPref pkg lib lbi clbi =+    generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib clbi installDirs+  where+    adjustReativeIncludeDirs = map (inplaceDir </>)+    installDirs =+      (absoluteInstallDirs pkg lbi NoCopyDest) {+        libdir     = inplaceDir </> buildDir lbi,+        datadir    = inplaceDir,+        datasubdir = distPref,+        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+                             -> Library+                             -> LocalBuildInfo+                             -> ComponentLocalBuildInfo+                             -> InstalledPackageInfo+absoluteInstalledPackageInfo pkg lib lbi clbi =+    generalInstalledPackageInfo adjustReativeIncludeDirs pkg lib 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++-- -----------------------------------------------------------------------------+-- 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)+      installDirs = absoluteInstallDirs pkg lbi NoCopyDest+  setupMessage verbosity "Unregistering" pkgid+  case compilerFlavor (compiler lbi) of+    GHC ->+      let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)+          invocation = HcPkg.unregisterInvocation ghcPkg Verbosity.normal+                         packageDb pkgid+      in if genScript+           then writeFileAtomic unregScriptFileName+                  (invocationAsSystemScript buildOS invocation)+            else runProgramInvocation verbosity invocation+    Hugs -> do+        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)+        return ()+    NHC -> do+        _ <- tryIO $ removeDirectoryRecursive (libdir installDirs)+        return ()+    _ ->+        die ("only unregistering with GHC and Hugs is implemented")++unregScriptFileName :: FilePath+unregScriptFileName = case buildOS of+                          Windows -> "unregister.bat"+                          _       -> "unregister.sh"
+ cabal/cabal/Distribution/Simple/Setup.hs view
@@ -0,0 +1,1584 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Setup+-- Copyright   :  Isaac Jones 2003-2004+--                Duncan Coutts 2007+--+-- 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+-- <http://www.haskell.org/pipermail/cabal-devel/2007-December/001509.html>+-- 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.++{- 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. -}++module Distribution.Simple.Setup (++  GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,+  ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,+  CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,+  InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,+  HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,+  HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,+  BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,+  buildVerbose,+  CleanFlags(..),    emptyCleanFlags,    defaultCleanFlags,    cleanCommand,+  RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,+                                                               unregisterCommand,+  SDistFlags(..),    emptySDistFlags,    defaultSDistFlags,    sdistCommand,+  TestFlags(..),     emptyTestFlags,     defaultTestFlags,     testCommand,+  TestShowDetails(..),+  CopyDest(..),+  configureArgs, configureOptions, configureCCompiler, configureLinker,+  installDirsOptions,++  defaultDistPref,++  Flag(..),+  toFlag,+  fromFlag,+  fromFlagOrDefault,+  flagToMaybe,+  flagToList,+  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) 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.Package ( Dependency(..) )+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(..)+         , OptimisationLevel(..), flagToOptimisationLevel )+import Distribution.Simple.Utils+         ( 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 Data.List   ( sort )+import Data.Char   ( isSpace, isAlpha )+import Data.Monoid ( Monoid(..) )++-- 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 (Show, Read, Eq)++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   = []++-- ------------------------------------------------------------+-- * 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 :: CommandUI GlobalFlags+globalCommand = CommandUI {+    commandName         = "",+    commandSynopsis     = "",+    commandUsage        = \_ ->+         "This Setup program uses the Haskell Cabal Infrastructure.\n"+      ++ "See http://www.haskell.org/cabal/ for more information.\n",+    commandDescription  = Just $ \pname ->+         "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"]],+    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+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 specifed programs paths+    configProgramArgs   :: [(String, [String])], -- ^user specifed programs args+    configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs.+    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+    configPackageDB :: Flag PackageDB, -- ^Which package DB to use+    configGHCiLib   :: Flag Bool,      -- ^Enable compiling library for GHCi+    configSplitObjs :: Flag Bool,      -- ^Enable -split-objs with GHC+    configStripExes :: Flag Bool,      -- ^Enable executable stripping+    configConstraints :: [Dependency], -- ^Additional constraints for+                                       -- dependencies+    configConfigurationsFlags :: FlagAssignment,+    configTests :: Flag Bool,     -- ^Enable test suite compilation+    configLibCoverage :: Flag Bool    -- ^ Enable test suite program coverage+  }+  deriving (Read,Show)++defaultConfigFlags :: ProgramConfiguration -> ConfigFlags+defaultConfigFlags progConf = emptyConfigFlags {+    configPrograms     = progConf,+    configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,+    configVanillaLib   = Flag True,+    configProfLib      = Flag False,+    configSharedLib    = Flag False,+    configDynExe       = Flag False,+    configProfExe      = Flag False,+    configOptimization = Flag NormalOptimisation,+    configProgPrefix   = Flag (toPathTemplate ""),+    configProgSuffix   = Flag (toPathTemplate ""),+    configDistPref     = Flag defaultDistPref,+    configVerbosity    = Flag normal,+    configUserInstall  = Flag False,           --TODO: reverse this+    configGHCiLib      = Flag True,+    configSplitObjs    = Flag False, -- takes longer, so turn off by default+    configStripExes    = Flag True,+    configTests  = Flag False,+    configLibCoverage = Flag False+  }++configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags+configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options+  where+    name       = "configure"+    shortDesc  = "Prepare to build the package."+    longDesc   = Just (\_ -> programFlagsDescription progConf)+    defaultFlags = defaultConfigFlags progConf+    options showOrParseArgs =+         configureOptions showOrParseArgs+      ++ programConfigurationPaths   progConf showOrParseArgs+           configProgramPaths (\v fs -> fs { configProgramPaths = 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 NHC, ([] , ["nhc98"]), "compile with NHC")+                    , (Flag JHC, ([] , ["jhc"]), "compile with JHC")+                    , (Flag LHC, ([] , ["lhc"]), "compile with LHC")+                    , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")+                    , (Flag UHC, ([] , ["uhc"]), "compile with UHC")])++      ,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 "b" ["scratchdir"]+         "directory to receive the built package (hugs-only)"+         configScratchDir (\v flags -> flags { configScratchDir = v })+         (reqArgFlag "DIR")+      --TODO: eliminate scratchdir flag++      ,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 "" ["executable-profiling"]+         "Executable profiling"+         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"+         ]++      ,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 "" ["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 specific package database (to satisfy dependencies and register in)"+         configPackageDB (\v flags -> flags { configPackageDB = v })+         (reqArg' "PATH" (Flag . SpecificPackageDB)+                        (\f -> case f of+                                 Flag (SpecificPackageDB db) -> [db]+                                 _ -> []))++      ,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 "" ["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 "" ["tests"]+         "dependency checking and compilation for test suites listed in the package description file."+         configTests (\v flags -> flags { configTests = v })+         (boolOpt [] [])+      ,option "" ["library-coverage"]+         "build library and test suites with Haskell Program Coverage enabled. (GHC only)"+         configLibCoverage (\v flags -> flags { configLibCoverage = 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)++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+  ]+  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,+    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,+    configPackageDB     = mempty,+    configGHCiLib       = mempty,+    configSplitObjs     = mempty,+    configStripExes     = mempty,+    configExtraLibDirs  = mempty,+    configConstraints   = mempty,+    configExtraIncludeDirs    = mempty,+    configConfigurationsFlags = mempty,+    configTests   = mempty,+    configLibCoverage = mempty+  }+  mappend a b =  ConfigFlags {+    configPrograms      = configPrograms b,+    configProgramPaths  = combine configProgramPaths,+    configProgramArgs   = combine configProgramArgs,+    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,+    configPackageDB     = combine configPackageDB,+    configGHCiLib       = combine configGHCiLib,+    configSplitObjs     = combine configSplitObjs,+    configStripExes     = combine configStripExes,+    configExtraLibDirs  = combine configExtraLibDirs,+    configConstraints   = combine configConstraints,+    configExtraIncludeDirs    = combine configExtraIncludeDirs,+    configConfigurationsFlags = combine configConfigurationsFlags,+    configTests = combine configTests,+    configLibCoverage = combine configLibCoverage+  }+    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 = makeCommand name shortDesc longDesc defaultCopyFlags options+  where+    name       = "copy"+    shortDesc  = "Copy the files into the install locations."+    longDesc   = Just $ \_ ->+          "Does not call register, and allows a prefix at install time\n"+       ++ "Without the --destdir flag, configure determines location.\n"+    options 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 = makeCommand name shortDesc longDesc defaultInstallFlags options+  where+    name       = "install"+    shortDesc  = "Copy the files into the install locations. Run register."+    longDesc   = Just $ \_ ->+         "Unlike the copy command, install calls the register command.\n"+      ++ "If you want to install into a location that is not what was\n"+      ++ "specified in the configure step, use the copy command.\n"+    options 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,+    sDistVerbosity :: Flag Verbosity+  }+  deriving Show++defaultSDistFlags :: SDistFlags+defaultSDistFlags = SDistFlags {+    sDistSnapshot  = Flag False,+    sDistDirectory = mempty,+    sDistDistPref  = Flag defaultDistPref,+    sDistVerbosity = Flag normal+  }++sdistCommand :: CommandUI SDistFlags+sdistCommand = makeCommand name shortDesc longDesc defaultSDistFlags options+  where+    name       = "sdist"+    shortDesc  = "Generate a source distribution file (.tar.gz)."+    longDesc   = Nothing+    options showOrParseArgs =+      [optionVerbosity sDistVerbosity (\v flags -> flags { sDistVerbosity = v })+      ,optionDistPref+         sDistDistPref (\d flags -> flags { sDistDistPref = d })+         showOrParseArgs++      ,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"+         sDistDirectory (\v flags -> flags { sDistDirectory = v })+         (reqArgFlag "DIR")+      ]++emptySDistFlags :: SDistFlags+emptySDistFlags = mempty++instance Monoid SDistFlags where+  mempty = SDistFlags {+    sDistSnapshot  = mempty,+    sDistDirectory = mempty,+    sDistDistPref  = mempty,+    sDistVerbosity = mempty+  }+  mappend a b = SDistFlags {+    sDistSnapshot  = combine sDistSnapshot,+    sDistDirectory = combine sDistDirectory,+    sDistDistPref  = combine sDistDistPref,+    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,+    regVerbosity   :: Flag Verbosity+  }+  deriving Show++defaultRegisterFlags :: RegisterFlags+defaultRegisterFlags = RegisterFlags {+    regPackageDB   = NoFlag,+    regGenScript   = Flag False,+    regGenPkgConf  = NoFlag,+    regInPlace     = Flag False,+    regDistPref    = Flag defaultDistPref,+    regVerbosity   = Flag normal+  }++registerCommand :: CommandUI RegisterFlags+registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+  where+    name       = "register"+    shortDesc  = "Register this package with the compiler."+    longDesc   = Nothing+    options 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)+      ]++unregisterCommand :: CommandUI RegisterFlags+unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+  where+    name       = "unregister"+    shortDesc  = "Unregister this package with the compiler."+    longDesc   = Nothing+    options 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,+    regDistPref    = mempty,+    regVerbosity   = mempty+  }+  mappend a b = RegisterFlags {+    regPackageDB   = combine regPackageDB,+    regGenScript   = combine regGenScript,+    regGenPkgConf  = combine regGenPkgConf,+    regInPlace     = combine regInPlace,+    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,+    hscolourDistPref    :: Flag FilePath,+    hscolourVerbosity   :: Flag Verbosity+  }+  deriving Show++emptyHscolourFlags :: HscolourFlags+emptyHscolourFlags = mempty++defaultHscolourFlags :: HscolourFlags+defaultHscolourFlags = HscolourFlags {+    hscolourCSS         = NoFlag,+    hscolourExecutables = Flag False,+    hscolourDistPref    = Flag defaultDistPref,+    hscolourVerbosity   = Flag normal+  }++instance Monoid HscolourFlags where+  mempty = HscolourFlags {+    hscolourCSS         = mempty,+    hscolourExecutables = mempty,+    hscolourDistPref    = mempty,+    hscolourVerbosity   = mempty+  }+  mappend a b = HscolourFlags {+    hscolourCSS         = combine hscolourCSS,+    hscolourExecutables = combine hscolourExecutables,+    hscolourDistPref    = combine hscolourDistPref,+    hscolourVerbosity   = combine hscolourVerbosity+  }+    where combine field = field a `mappend` field b++hscolourCommand :: CommandUI HscolourFlags+hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options+  where+    name       = "hscolour"+    shortDesc  = "Generate HsColour colourised code, in HTML format."+    longDesc   = Just (\_ -> "Requires hscolour.\n")+    options 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 "" ["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,+    haddockInternal     :: Flag Bool,+    haddockCss          :: Flag FilePath,+    haddockHscolour     :: Flag Bool,+    haddockHscolourCss  :: Flag FilePath,+    haddockDistPref     :: Flag FilePath,+    haddockVerbosity    :: Flag Verbosity+  }+  deriving Show++defaultHaddockFlags :: HaddockFlags+defaultHaddockFlags  = HaddockFlags {+    haddockProgramPaths = mempty,+    haddockProgramArgs  = [],+    haddockHoogle       = Flag False,+    haddockHtml         = Flag False,+    haddockHtmlLocation = NoFlag,+    haddockExecutables  = Flag False,+    haddockInternal     = Flag False,+    haddockCss          = NoFlag,+    haddockHscolour     = Flag False,+    haddockHscolourCss  = NoFlag,+    haddockDistPref     = Flag defaultDistPref,+    haddockVerbosity    = Flag normal+  }++haddockCommand :: CommandUI HaddockFlags+haddockCommand = makeCommand name shortDesc longDesc defaultHaddockFlags options+  where+    name       = "haddock"+    shortDesc  = "Generate Haddock HTML documentation."+    longDesc   = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n"+    options showOrParseArgs =+      [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v })+      ,optionDistPref+         haddockDistPref (\d flags -> flags { haddockDistPref = d })+         showOrParseArgs++      ,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 "" ["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")+      ]+      ++ programConfigurationPaths   progConf ParseArgs+             haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})+      ++ programConfigurationOptions progConf ParseArgs+             haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})+    progConf = addKnownProgram haddockProgram+             $ addKnownProgram ghcProgram+             $ emptyProgramConfiguration++emptyHaddockFlags :: HaddockFlags+emptyHaddockFlags = mempty++instance Monoid HaddockFlags where+  mempty = HaddockFlags {+    haddockProgramPaths = mempty,+    haddockProgramArgs  = mempty,+    haddockHoogle       = mempty,+    haddockHtml         = mempty,+    haddockHtmlLocation = mempty,+    haddockExecutables  = mempty,+    haddockInternal     = mempty,+    haddockCss          = mempty,+    haddockHscolour     = mempty,+    haddockHscolourCss  = mempty,+    haddockDistPref     = 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,+    haddockInternal     = combine haddockInternal,+    haddockCss          = combine haddockCss,+    haddockHscolour     = combine haddockHscolour,+    haddockHscolourCss  = combine haddockHscolourCss,+    haddockDistPref     = combine haddockDistPref,+    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 = makeCommand name shortDesc longDesc defaultCleanFlags options+  where+    name       = "clean"+    shortDesc  = "Clean up after a build."+    longDesc   = Just (\_ -> "Removes .hi, .o, preprocessed sources, etc.\n")+    options 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+  }+  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+  }++buildCommand :: ProgramConfiguration -> CommandUI BuildFlags+buildCommand progConf = makeCommand name shortDesc longDesc defaultBuildFlags options+  where+    name       = "build"+    shortDesc  = "Make this package ready for installation."+    longDesc   = Nothing+    options showOrParseArgs =+      optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })+      : optionDistPref+          buildDistPref (\d flags -> flags { buildDistPref = d })+          showOrParseArgs++      : programConfigurationPaths   progConf showOrParseArgs+          buildProgramPaths (\v flags -> flags { buildProgramPaths = 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+  }+  mappend a b = BuildFlags {+    buildProgramPaths = combine buildProgramPaths,+    buildProgramArgs = combine buildProgramArgs,+    buildVerbosity   = combine buildVerbosity,+    buildDistPref    = combine buildDistPref+  }+    where combine field = field a `mappend` field b++-- ------------------------------------------------------------+-- * Test flags+-- ------------------------------------------------------------++data TestShowDetails = Never | Failures | Always+    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: eliminate the test list and pass it directly as positional args to the testHook+    testList :: Flag [String],+    -- TODO: think about if/how options are passed to test exes+    testOptions :: Flag [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,+    testList = Flag [],+    testOptions = Flag []+  }++testCommand :: CommandUI TestFlags+testCommand = makeCommand name shortDesc longDesc defaultTestFlags options+  where+    name       = "test"+    shortDesc  = "Run the test suite, if any (configure with UserHooks)."+    longDesc   = Nothing+    options 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.")+            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" (toFlag . map toPathTemplate . splitArgs)+                (map fromPathTemplate . fromFlagOrDefault []))+      , 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 -> toFlag [toPathTemplate x])+                (map fromPathTemplate . fromFlagOrDefault []))+      ]++emptyTestFlags :: TestFlags+emptyTestFlags  = mempty++instance Monoid TestFlags where+  mempty = TestFlags {+    testDistPref  = mempty,+    testVerbosity = mempty,+    testHumanLog = mempty,+    testMachineLog = mempty,+    testShowDetails = mempty,+    testKeepTix = mempty,+    testList = 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,+    testList = combine testList,+    testOptions = combine testOptions+  }+    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"++programConfigurationPaths+  :: ProgramConfiguration+  -> ShowOrParseArgs+  -> (flags -> [(String, FilePath)])+  -> ([(String, FilePath)] -> (flags -> flags))+  -> [OptionField flags]+programConfigurationPaths 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 "" ["with-" ++ prog]+        ("give the path to " ++ prog)+        get set+        (reqArg' "PATH" (\path -> [(prog, path)])+          (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ]))++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", programOption   "PROG"]+    ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf)+              ++ map (programOption  . programName . fst) (knownPrograms progConf)+  where+    programOptions prog =+      option "" [prog ++ "-options"]+        ("give extra options to " ++ prog)+        get set+        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))++    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' ]))+++-- ------------------------------------------------------------+-- * 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 :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->+                     (Flag Bool -> (b -> b)) -> OptDescr b+trueArg  = noArg (Flag True)+falseArg = noArg (Flag False)++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))++-- ------------------------------------------------------------+-- * 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+ ++ 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/cabal/Distribution/Simple/SrcDist.hs view
@@ -0,0 +1,418 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.SrcDist+-- Copyright   :  Simon Marlow 2004+--+-- 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.++{- Copyright (c) 2003-2004, Simon Marlow+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. -}++-- 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,++  -- ** Snaphots+  prepareSnapshotTree,+  snapshotPackage,+  snapshotVersion,+  dateToSnapshotNumber,+  )  where++import Distribution.PackageDescription+         ( PackageDescription(..), BuildInfo(..), Executable(..), Library(..)+         , TestSuite(..), TestSuiteInterface(..) )+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+         , installOrdinaryFile, installOrdinaryFiles, setFileExecutable+         , findFile, findFileWithExtension, matchFileGlob+         , withTempDirectory, defaultPackageDesc+         , die, warn, notice, setupMessage )+import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe)+import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent)+import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI )+import Distribution.Simple.BuildPaths ( autogenModuleName )+import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,+                              rawSystemProgram, tarProgram )+import Distribution.Text+         ( display )++import Control.Monad(when, unless)+import Data.Char (toLower)+import Data.List (partition, isPrefixOf)+import Data.Maybe (isNothing, catMaybes)+import System.Time (getClockTime, toCalendarTime, CalendarTime(..))+import System.Directory+         ( doesFileExist, Permissions(executable), getPermissions )+import Distribution.Verbosity (Verbosity)+import System.FilePath+         ( (</>), (<.>), takeDirectory, 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 = do++  -- do some QA+  printPackageProblems verbosity pkg++  when (isNothing mb_lbi) $+    warn verbosity "Cannot run preprocessors. Run 'configure' command first."++  date <- toCalendarTime =<< getClockTime+  let pkg' | snapshot  = snapshotPackage date pkg+           | otherwise = pkg++  case flagToMaybe (sDistDirectory flags) of+    Just targetDir -> do+      generateSourceDir targetDir pkg'+      notice 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 distPref 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+++-- |Prepare a directory tree of source files.+prepareTree :: Verbosity          -- ^verbosity+            -> PackageDescription -- ^info from the cabal file+            -> Maybe LocalBuildInfo+            -> FilePath           -- ^dist dir+            -> FilePath           -- ^source tree to populate+            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)+            -> IO ()+prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do+  createDirectoryIfMissingVerbose verbosity True targetDir++  -- maybe move the library files into place+  withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->+    prepareDir verbosity pkg_descr distPref targetDir pps modules libBi++  -- move the executables into place+  withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do+    prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi+    srcMainFile <- do+      ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath)+      case ppFile of+        Nothing -> findFile (hsSourceDirs exeBi) mainPath+        Just pp -> return pp+    copyFileTo verbosity targetDir srcMainFile++  -- move the test suites into place+  withTest $ \t -> do+    let bi = testBuildInfo t+        prep = prepareDir verbosity pkg_descr distPref targetDir pps+    case testInterface t of+        TestSuiteExeV10 _ mainPath -> do+            prep [] bi+            srcMainFile <- do+                ppFile <- findFileWithExtension (ppSuffixes pps)+                                                (hsSourceDirs bi)+                                                (dropExtension mainPath)+                case ppFile of+                    Nothing -> findFile (hsSourceDirs bi) mainPath+                    Just pp -> return pp+            copyFileTo verbosity targetDir srcMainFile+        TestSuiteLibV09 _ m -> do+            prep [m] bi+        TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp++  flip mapM_ (dataFiles pkg_descr) $ \ filename -> do+    files <- matchFileGlob (dataDir pkg_descr </> filename)+    let dir = takeDirectory (dataDir pkg_descr </> filename)+    createDirectoryIfMissingVerbose verbosity True (targetDir </> dir)+    sequence_ [ installOrdinaryFile verbosity file (targetDir </> file)+              | file <- files ]++  when (not (null (licenseFile pkg_descr))) $+    copyFileTo verbosity targetDir (licenseFile pkg_descr)+  flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do+    files <- matchFileGlob fpath+    sequence_+      [ do copyFileTo verbosity targetDir file+           -- preserve executable bit on extra-src-files like ./configure+           perms <- getPermissions file+           when (executable perms) --only checks user x bit+                (setFileExecutable (targetDir </> file))+      | file <- files ]++  -- copy the install-include files+  withLib $ \ l -> do+    let lbi = libBuildInfo l+        relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)+    incs <- mapM (findInc relincdirs) (installIncludes lbi)+    flip mapM_ incs $ \(_,fpath) ->+       copyFileTo verbosity targetDir fpath++  -- 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 }   +      withComponentsLBI pkg_descr lbi' $ \c _ ->+        preprocessComponent pkg_descr c lbi' True verbosity pps+    _ -> return ()++  -- setup isn't listed in the description file.+  hsExists <- doesFileExist "Setup.hs"+  lhsExists <- doesFileExist "Setup.lhs"+  if hsExists then copyFileTo verbosity targetDir "Setup.hs"+    else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"+    else writeUTF8File (targetDir </> "Setup.hs") $ unlines [+                "import Distribution.Simple",+                "main = defaultMain"]+  -- the description file itself+  descFile <- defaultPackageDesc verbosity+  installOrdinaryFile verbosity descFile (targetDir </> descFile)++  where+    pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0+    filterAutogenModule bi = bi {+      otherModules = filter (/=autogenModule) (otherModules bi)+    }+    autogenModule = autogenModuleName pkg_descr0++    findInc [] f = die ("can't find include file " ++ f)+    findInc (d:ds) f = do+      let path = (d </> f)+      b <- doesFileExist path+      if b then return (f,path) else findInc ds f++    -- 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)++-- | 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           -- ^dist dir+                    -> FilePath           -- ^source tree to populate+                    -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)+                    -> IO ()+prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do+  prepareTree verbosity pkg mb_lbi distPref 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 :: CalendarTime -> 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 :: CalendarTime -> 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 :: CalendarTime -> Int+dateToSnapshotNumber date = year  * 10000+                          + month * 100+                          + day+  where+    year  = ctYear date+    month = fromEnum (ctMonth date) + 1+    day   = ctDay date++-- |Create an archive from a tree of source files, and clean up the tree.+createArchive :: 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++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)++   -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?)+   -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly,+   -- which is problematic in a Windows setting.]+  rawSystemProgram verbosity tarProg+           ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr]+  return tarBallFilePath++-- |Move the sources into place based on buildInfo+prepareDir :: Verbosity -- ^verbosity+           -> PackageDescription -- ^info from the cabal file+           -> FilePath           -- ^dist dir+           -> FilePath  -- ^TargetPrefix+           -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)+           -> [ModuleName]  -- ^Exposed modules+           -> BuildInfo+           -> IO ()+prepareDir verbosity _pkg _distPref inPref pps modules bi+    = 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 ]++         let allSources = sources ++ catMaybes bootFiles ++ cSources bi+         installOrdinaryFiles verbosity inPref (zip (repeat []) allSources)++    where suffixes = ppSuffixes pps ++ ["hs", "lhs"]+          notFound m = die $ "Error: Could not find module: " ++ display m+                          ++ " with any suffix: " ++ show suffixes++copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()+copyFileTo verbosity dir file = do+  let targetFile = dir </> file+  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)+  installOrdinaryFile verbosity file targetFile++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)+  }+  where+    mapLibBi lib = lib { libBuildInfo = f (libBuildInfo lib) }+    mapExeBi exe = exe { buildInfo    = f (buildInfo exe) }
+ cabal/cabal/Distribution/Simple/Test.hs view
@@ -0,0 +1,486 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Test+-- Copyright   :  Thomas Tuegel 2010+--+-- 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.++{- 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. -}++module Distribution.Simple.Test+    ( test+    , runTests+    , writeSimpleTestStub+    , stubFilePath+    , stubName+    , PackageLog(..)+    , TestSuiteLog(..)+    , Case(..)+    , suitePassed, suiteFailed, suiteError+    ) where++import Distribution.Compat.TempFile ( openTempFile )+import Distribution.ModuleName ( ModuleName )+import Distribution.Package+    ( PackageId )+import qualified Distribution.PackageDescription as PD+         ( PackageDescription(..), BuildInfo(buildable)+         , TestSuite(..)+         , TestSuiteInterface(..), testType, hasTests )+import Distribution.Simple.Build.PathsModule ( pkgPathEnvVar )+import Distribution.Simple.BuildPaths ( exeExtension )+import Distribution.Simple.Compiler ( Compiler(..), CompilerId )+import Distribution.Simple.Hpc ( doHpcMarkup, findTixFiles, tixDir )+import Distribution.Simple.InstallDirs+    ( fromPathTemplate, initialPathTemplateEnv, PathTemplateVariable(..)+    , substPathTemplate , toPathTemplate, PathTemplate )+import qualified Distribution.Simple.LocalBuildInfo as LBI+    ( LocalBuildInfo(..) )+import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )+import Distribution.Simple.Utils ( die, notice )+import qualified Distribution.TestSuite as TestSuite+    ( Test, Result(..), ImpureTestable(..), TestOptions(..), Options(..) )+import Distribution.Text+import Distribution.Verbosity ( normal, Verbosity )+import Distribution.System ( buildPlatform, Platform )++import Control.Exception ( bracket )+import Control.Monad ( when, liftM, unless, filterM )+import Data.Char ( toUpper )+import Data.Monoid ( mempty )+import System.Directory+    ( createDirectoryIfMissing, doesFileExist, getCurrentDirectory+    , removeFile, getDirectoryContents )+import System.Environment ( getEnvironment )+import System.Exit ( ExitCode(..), exitFailure, exitWith )+import System.FilePath ( (</>), (<.>) )+import System.IO ( hClose, IOMode(..), openFile )+import System.Process ( runProcess, waitForProcess )++-- | 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 = buildPlatform+    , testSuites = []+    }++-- | Logs test suite results, itemized by test case.+data TestSuiteLog = TestSuiteLog+    { name :: String+    , cases :: [Case]+    , logFile :: FilePath    -- path to human-readable log file+    }+    deriving (Read, Show, Eq)++data Case = Case+    { caseName :: String+    , caseOptions :: TestSuite.Options+    , caseResult :: TestSuite.Result+    }+    deriving (Read, Show, Eq)++getTestOptions :: TestSuite.Test -> TestSuiteLog -> IO TestSuite.Options+getTestOptions t l =+    case filter ((== TestSuite.name t) . caseName) (cases l) of+        (x:_) -> return $ caseOptions x+        _ -> TestSuite.defaultOptions t++-- | From a 'TestSuiteLog', determine if the test suite passed.+suitePassed :: TestSuiteLog -> Bool+suitePassed = all (== TestSuite.Pass) . map caseResult . cases++-- | From a 'TestSuiteLog', determine if the test suite failed.+suiteFailed :: TestSuiteLog -> Bool+suiteFailed = any isFail . map caseResult . cases+    where isFail (TestSuite.Fail _) = True+          isFail _ = False++-- | From a 'TestSuiteLog', determine if the test suite encountered errors.+suiteError :: TestSuiteLog -> Bool+suiteError = any isError . map caseResult . cases+    where isError (TestSuite.Error _) = True+          isError _ = False++-- | Run a test executable, logging the output and generating the appropriate+-- summary messages.+testController :: TestFlags+               -- ^ flags Cabal was invoked with+               -> PD.PackageDescription+               -- ^ description of package the test suite belongs to+               -> LBI.LocalBuildInfo+               -- ^ information from the configure step+               -> PD.TestSuite+               -- ^ TestSuite being tested+               -> (FilePath -> String)+               -- ^ prepare standard input for test executable+               -> FilePath -- ^ executable name+               -> (ExitCode -> String -> TestSuiteLog)+               -- ^ generator for the TestSuiteLog+               -> (TestSuiteLog -> FilePath)+               -- ^ generator for final human-readable log filename+               -> IO TestSuiteLog+testController flags pkg_descr lbi suite preTest cmd postTest logNamer = do+    let distPref = fromFlag $ testDistPref flags+        verbosity = fromFlag $ testVerbosity flags+        testLogDir = distPref </> "test"+        optionTemplates = fromFlag $ testOptions flags+        options = map (testOption pkg_descr lbi suite) optionTemplates++    pwd <- getCurrentDirectory+    existingEnv <- getEnvironment+    let dataDirPath = pwd </> PD.dataDir pkg_descr+        shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)+                        : ("HPCTIXDIR", pwd </> tixDir distPref suite)+                        : existingEnv++    bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->+        bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do++            -- Create directory for HPC files.+            createDirectoryIfMissing True $ tixDir distPref suite++            -- Remove old .tix files if appropriate.+            tixFiles <- findTixFiles distPref suite+            unless (fromFlag $ testKeepTix flags)+                $ mapM_ deleteIfExists tixFiles++            -- Write summary notices indicating start of test suite+            notice verbosity $ summarizeSuiteStart $ PD.testName suite+            appendFile tempLog $ summarizeSuiteStart $ PD.testName suite++            -- Prepare standard input for test executable+            appendFile tempInput $ preTest tempInput++            -- Run test executable+            exit <- do+              hLog <- openFile tempLog AppendMode+              hIn  <- openFile tempInput ReadMode+              -- these handles get closed by runProcess+              proc <- runProcess cmd options Nothing shellEnv+                        (Just hIn) (Just hLog) (Just hLog)+              waitForProcess proc++            -- Generate TestSuiteLog from executable exit code and a machine-+            -- readable test log+            suiteLog <- readFile tempInput >>= return . postTest exit++            -- Generate final log file name+            let finalLogName = testLogDir </> logNamer suiteLog+                suiteLog' = suiteLog { logFile = finalLogName }++            -- Write summary notice to log file indicating end of test suite+            appendFile tempLog $ summarizeSuiteFinish suiteLog'++            -- Append contents of temporary log file to the final human-+            -- readable log file+            readFile tempLog >>= appendFile (logFile 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 suiteLog) || details == Always)+                    && verbosity >= normal+            whenPrinting $ readFile (logFile suiteLog') >>=+                putStr . unlines . map (">>> " ++) . lines++            -- Write summary notice to terminal indicating end of test suite+            notice verbosity $ summarizeSuiteFinish suiteLog'++            doHpcMarkup verbosity distPref (display $ PD.package pkg_descr) suite++            return suiteLog'+    where+        deleteIfExists file = do+            exists <- doesFileExist file+            when exists $ removeFile file++        openCabalTemp testLogDir = do+            (f, h) <- openTempFile testLogDir $ "cabal-test-" <.> "log"+            hClose h >> return f+++-- |Perform the \"@.\/setup test@\" action.+test :: PD.PackageDescription   -- ^information from the .cabal file+     -> LBI.LocalBuildInfo      -- ^information from the configure step+     -> TestFlags               -- ^flags sent to test+     -> IO ()+test pkg_descr lbi flags = do+    let verbosity = fromFlag $ testVerbosity flags+        humanTemplate = fromFlag $ testHumanLog flags+        machineTemplate = fromFlag $ testMachineLog flags+        distPref = fromFlag $ testDistPref flags+        testLogDir = distPref </> "test"+        testNames = fromFlag $ testList flags+        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, mLog) = do+            let testLogPath = testSuiteLogPath humanTemplate pkg_descr lbi+                go pre cmd post = testController flags pkg_descr lbi suite+                                                 pre cmd post testLogPath+            case PD.testInterface suite of+              PD.TestSuiteExeV10 _ _ -> do+                    let cmd = LBI.buildDir lbi </> PD.testName suite+                            </> PD.testName suite <.> exeExtension+                        preTest _ = ""+                        postTest exit _ =+                            let r = case exit of+                                    ExitSuccess -> TestSuite.Pass+                                    ExitFailure c -> TestSuite.Fail+                                        $ "exit code: " ++ show c+                            in TestSuiteLog+                                { name = PD.testName suite+                                , cases = [Case (PD.testName suite) mempty r]+                                , logFile = ""+                                }+                    go preTest cmd postTest++              PD.TestSuiteLibV09 _ _ -> do+                    let cmd = LBI.buildDir lbi </> stubName suite+                            </> stubName suite <.> exeExtension+                        oldLog = case mLog of+                            Nothing -> TestSuiteLog+                                { name = PD.testName suite+                                , cases = []+                                , logFile = []+                                }+                            Just l -> l+                        preTest f = show $ oldLog { logFile = f }+                        postTest _ = read+                    go preTest cmd postTest++              _ -> return TestSuiteLog+                            { name = PD.testName suite+                            , cases = [Case (PD.testName suite) mempty+                                $ TestSuite.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+    unless allOk exitFailure++-- | 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 cases' = map caseResult $ concatMap cases $ testSuites packageLog+        passedCases = length $ filter (== TestSuite.Pass) cases'+        totalCases = length cases'+        passedSuites = length $ filter suitePassed $ testSuites packageLog+        totalSuites = length $ testSuites packageLog+    notice verbosity $ show passedSuites ++ " of " ++ show totalSuites+        ++ " test suites (" ++ show passedCases ++ " of "+        ++ show totalCases ++ " test cases) passed."+    return $! passedSuites == totalSuites++-- | Print a summary of a single test case's result to the console, supressing+-- output for certain verbosity or test filter levels.+summarizeCase :: Verbosity -> TestShowDetails -> Case -> IO ()+summarizeCase verbosity details t =+    when shouldPrint $ notice verbosity $ "Test case " ++ caseName t+        ++ ": " ++ show (caseResult t)+    where shouldPrint = (details > Never) && (notPassed || details == Always)+          notPassed = caseResult t /= TestSuite.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 " ++ name testLog ++ ": " ++ resStr+    , "Test suite logged to: " ++ logFile testLog+    ]+    where resStr = map toUpper (resultString testLog)++summarizeSuiteStart :: String -> String+summarizeSuiteStart n = "Test suite " ++ n ++ ": RUNNING...\n"++resultString :: TestSuiteLog -> String+resultString l | suiteError l = "error"+               | suiteFailed l = "fail"+               | otherwise = "pass"++testSuiteLogPath :: PathTemplate+                 -> PD.PackageDescription+                 -> LBI.LocalBuildInfo+                 -> TestSuiteLog+                 -> FilePath+testSuiteLogPath template pkg_descr lbi testLog =+    fromPathTemplate $ substPathTemplate env template+    where+        env = initialPathTemplateEnv+                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+                ++  [ (TestSuiteNameVar, toPathTemplate $ name testLog)+                    , (TestSuiteResultVar, result)+                    ]+        result = toPathTemplate $ resultString testLog++-- TODO: This is abusing the notion of a 'PathTemplate'.  The result+-- isn't neccesarily 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) (compilerId $ LBI.compiler lbi) +++          [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]++packageLogPath :: PathTemplate+               -> PD.PackageDescription+               -> LBI.LocalBuildInfo+               -> FilePath+packageLogPath template pkg_descr lbi =+    fromPathTemplate $ substPathTemplate env template+    where+        env = initialPathTemplateEnv+                (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)++-- | The filename of the source file for the stub executable associated with a+-- library 'TestSuite'.+stubFilePath :: PD.TestSuite -> FilePath+stubFilePath t = stubName t <.> "hs"++-- | The name of the stub executable associated with a library 'TestSuite'.+stubName :: PD.TestSuite -> FilePath+stubName t = PD.testName t ++ "Stub"++-- | 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 Control.Monad ( liftM )"+    , "import Distribution.Simple.Test ( runTests )"+    , "import " ++ show (disp m) ++ " ( tests )"+    , "main :: IO ()"+    , "main = runTests tests"+    ]++-- | 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.+runTests :: [TestSuite.Test] -> IO ()+runTests tests = do+    testLogIn <- liftM read getContents+    let go :: TestSuite.Test -> IO Case+        go t = do+            o <- getTestOptions t testLogIn+            r <- TestSuite.runM t o+            let ret = Case+                    { caseName = TestSuite.name t+                    , caseOptions = o+                    , caseResult = r+                    }+            summarizeCase normal Always ret+            return ret+    cases' <- mapM go tests+    let testLog = testLogIn { cases = cases'}+    writeFile (logFile testLog) $ show testLog+    when (suiteError testLog) $ exitWith $ ExitFailure 2+    when (suiteFailed testLog) $ exitWith $ ExitFailure 1+    exitWith ExitSuccess
+ cabal/cabal/Distribution/Simple/UHC.hs view
@@ -0,0 +1,300 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.UHC+-- Copyright   :  Andres Loeh 2009+--+-- 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.++{-+Copyright (c) 2009, Andres Loeh+Copyright (c) 2003-2005, Isaac Jones+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. -}++module Distribution.Simple.UHC (+    configure, getInstalledPackages,+    buildLib, buildExe, installLib, registerPackage+  ) where++import Control.Monad+import Data.List+import Distribution.Compat.ReadP+import Distribution.InstalledPackageInfo+import Distribution.Package+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++-- -----------------------------------------------------------------------------+-- Configuring++configure :: Verbosity -> Maybe FilePath -> Maybe FilePath+          -> ProgramConfiguration -> IO (Compiler, 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,+               compilerLanguages   =  uhcLanguages,+               compilerExtensions  =  uhcLanguageExtensions+             }+  return (comp, 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 PackageIndex+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-builtin 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]+     -- 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 hardcoded 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/cabal/Distribution/Simple/UserHooks.hs view
@@ -0,0 +1,220 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.UserHooks+-- Copyright   :  Isaac Jones 2003-2005+--+-- 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.++{- 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. -}++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, CleanFlags, CopyFlags,+          InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,+          HaddockFlags, TestFlags)+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 gbet 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 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 registration.+    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 :: PackageDescription -> LocalBuildInfo -> UserHooks -> TestFlags -> IO (),+    -- |Hook to run after test command.+    postTest :: Args -> TestFlags -> 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,+      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 = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without+                                                     -- noExtraFlags+      testHook = ru,+      postTest = ru+    }+    where rn args  _ = noExtraFlags args >> return emptyHookedBuildInfo+          ru _ _ _ _ = return ()
+ cabal/cabal/Distribution/Simple/Utils.hs view
@@ -0,0 +1,1131 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+{-# OPTIONS_NHC98 -cpp #-}+{-# OPTIONS_JHC -fcpp -fffi #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Utils+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+--                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.++{- 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. -}++module Distribution.Simple.Utils (+        cabalVersion,++        -- * logging and errors+        die,+        dieWithLocation,+        topHandler,+        warn, notice, setupMessage, info, debug,+        chattyTry,++        -- * running programs+        rawSystemExit,+        rawSystemExitWithEnv,+        rawSystemStdout,+        rawSystemStdInOut,+        maybeExit,+        xargs,+        findProgramLocation,+        findProgramVersion,++        -- * copying files+        smartCopySources,+        createDirectoryIfMissingVerbose,+        copyFileVerbose,+        copyDirectoryRecursiveVerbose,+        copyFiles,++        -- * installing files+        installOrdinaryFile,+        installExecutableFile,+        installOrdinaryFiles,+        installDirectoryContents,++        -- * File permissions+        setFileOrdinary,+        setFileExecutable,++        -- * file names+        currentDir,++        -- * finding files+        findFile,+        findFirstFile,+        findFileWithExtension,+        findFileWithExtension',+        findModuleFile,+        findModuleFiles,+        getDirectoryContentsRecursive,++        -- * simple file globbing+        matchFileGlob,+        matchDirFileGlob,+        parseFileGlob,+        FileGlob(..),++        -- * temp files and dirs+        withTempFile,+        withTempDirectory,++        -- * .cabal and .buildinfo files+        defaultPackageDesc,+        findPackageDesc,+        defaultHookedPackageDesc,+        findHookedPackageDesc,++        -- * reading and writing files safely+        withFileContents,+        writeFileAtomic,+        rewriteFile,++        -- * Unicode+        fromUTF8,+        toUTF8,+        readUTF8File,+        withUTF8FileContents,+        writeUTF8File,+        normaliseLineEndings,++        -- * generic utils+        equating,+        comparing,+        isInfixOf,+        intercalate,+        lowercase,+        wrapText,+        wrapLine,+  ) where++import Control.Monad+    ( when, unless, filterM )+#ifdef __GLASGOW_HASKELL__+import Control.Concurrent.MVar+    ( newEmptyMVar, putMVar, takeMVar )+#endif+import Data.List+    ( nub, unfoldr, isPrefixOf, tails, intersperse )+import Data.Char as Char+    ( toLower, chr, ord )+import Data.Bits+    ( Bits((.|.), (.&.), shiftL, shiftR) )++import System.Directory+    ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile+    , findExecutable )+import System.Environment+    ( getProgName )+import System.Cmd+    ( rawSystem )+import System.Exit+    ( exitWith, ExitCode(..) )+import System.FilePath+    ( normalise, (</>), (<.>), takeDirectory, splitFileName+    , splitExtension, splitExtensions, splitDirectories )+import System.Directory+    ( createDirectory, renameFile, removeDirectoryRecursive )+import System.IO+    ( Handle, openFile, openBinaryFile, IOMode(ReadMode), hSetBinaryMode+    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )+import System.IO.Error as IO.Error+    ( isDoesNotExistError, isAlreadyExistsError+    , ioeSetFileName, ioeGetFileName, ioeGetErrorString )+#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608))+import System.IO.Error+    ( ioeSetLocation, ioeGetLocation )+#endif+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.Version+    (Version(..))++import Control.Exception (evaluate)+import System.Process (runProcess)++#ifdef __GLASGOW_HASKELL__+import Control.Concurrent (forkIO)+import System.Process (runInteractiveProcess, waitForProcess)+#else+import System.Cmd (system)+import System.Directory (getTemporaryDirectory)+#endif++import Distribution.Compat.CopyFile+         ( copyFile, copyOrdinaryFile, copyExecutableFile+         , setFileOrdinary, setFileExecutable, setDirOrdinary )+import Distribution.Compat.TempFile+         ( openTempFile, openNewBinaryFile, createTempDirectory )+import Distribution.Compat.Exception+         ( IOException, throwIOIO, tryIO, catchIO, catchExit, onException )+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+#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)+    setLocation _        err = err+#else+    setLocation Nothing  err = err+    setLocation (Just n) err = ioeSetLocation err (show n)+#endif++die :: String -> IO a+die msg = ioError (userError msg)++topHandler :: IO a -> IO a+topHandler prog = catchIO prog handle+  where+    handle ioe = do+      hFlush stdout+      pname <- getProgName+      hPutStr stderr (mesage pname)+      exitWith (ExitFailure 1)+      where+        mesage pname = wrapText (pname ++ ": " ++ file ++ detail)+        file         = case ioeGetFileName ioe of+                         Nothing   -> ""+                         Just path -> path ++ location ++ ": "+#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)+        location     = ""+#else+        location     = case ioeGetLocation ioe of+                         l@(n:_) | n >= '0' && n <= '9' -> ':' : l+                         _                              -> ""+#endif+        detail       = ioeGetErrorString ioe++-- | 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++-- | 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+         . concatMap (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+ | verbosity >= deafening = print (path, args)+ | verbosity >= verbose   = putStrLn $ unwords (path : args)+ | otherwise              = return ()++printRawCommandAndArgsAndEnv :: Verbosity+                             -> FilePath+                             -> [String]+                             -> [(String, String)]+                             -> IO ()+printRawCommandAndArgsAndEnv verbosity path args env+ | verbosity >= deafening = do putStrLn ("Environment: " ++ show env)+                               print (path, args)+ | verbosity >= verbose   = putStrLn $ unwords (path : args)+ | otherwise              = return ()++-- Exit with the same exitcode 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++rawSystemExitWithEnv :: Verbosity+                     -> FilePath+                     -> [String]+                     -> [(String, String)]+                     -> IO ()+rawSystemExitWithEnv verbosity path args env = do+    printRawCommandAndArgsAndEnv verbosity path args env+    hFlush stdout+    ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing+    exitcode <- waitForProcess ph+    unless (exitcode == ExitSuccess) $ do+        debug verbosity $ path ++ " returned " ++ show exitcode+        exitWith exitcode++-- | 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 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 -> [String]+                  -> Maybe (String, Bool) -- ^ input text and binary mode+                  -> Bool                 -- ^ output in binary mode+                  -> IO (String, String, ExitCode) -- ^ output, errors, exit+rawSystemStdInOut verbosity path args input outputBinary = do+  printRawCommandAndArgs verbosity path args++#ifdef __GLASGOW_HASKELL__+  Exception.bracket+     (runInteractiveProcess path args Nothing Nothing)+     (\(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++      return (out, err, exitcode)+#else+  tmpDir <- getTemporaryDirectory+  withTempFile tmpDir ".cmd.stdout" $ \outName outHandle ->+   withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do+    hClose outHandle++    case input of+      Nothing -> return ()+      Just (inputStr, inputBinary) -> do+        hSetBinaryMode inHandle inputBinary+        hPutStr inHandle inputStr+    hClose inHandle++    let quote name = "'" ++ name ++ "'"+        cmd = unwords (map quote (path:args))+           ++ " <" ++ quote inName+           ++ " >" ++ quote outName+    exitcode <- system cmd++    unless (exitcode == ExitSuccess) $+      debug verbosity $ path ++ " returned " ++ show exitcode++    Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do+      hSetBinaryMode hnd outputBinary+      output <- hGetContents hnd+      length output `seq` return (output, "", exitcode)+#endif+++-- | 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++----------------+-- 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++----------------------------------------+-- 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 throwIOIO+    createDirs (dir:dirs) =+      createDir dir $ \_ -> do+        createDirs dirs+        createDir dir throwIOIO++    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 exeption 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 throwIOIO e+              ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())+          | otherwise              -> throwIOIO 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++-- | 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 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 copyFileVerbose verbosity src dest+            | (srcBase, srcFile) <- srcFiles ]++-- | This is like 'copyFiles' but uses 'installOrdinaryFile'.+--+installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+installOrdinaryFiles 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 installOrdinaryFile verbosity src dest+            | (srcBase, srcFile) <- srcFiles ]++-- | 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 ]++---------------------------------+-- 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++-- | 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 =+  Exception.bracket+    (openTempFile tmpDir template)+    (\(name, handle) -> hClose handle >> 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 =+  Exception.bracket+    (createTempDirectory targetDir template)+    (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 sucessfully 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 -> String -> IO ()+writeFileAtomic targetFile content = do+  (tmpFile, tmpHandle) <- openNewBinaryFile targetDir template+  do  hPutStr tmpHandle content+      hClose tmpHandle+      renameFile tmpFile targetFile+   `onException` do hClose tmpHandle+                    removeFile tmpFile+  where+    template = targetName <.> "tmp"+    targetDir | null targetDir_ = currentDir+              | otherwise       = targetDir_+    --TODO: remove this when takeDirectory/splitFileName is fixed+    --      to always return a valid dir+    (targetDir_,targetName) = splitFileName targetFile++-- | 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.+--+rewriteFile :: FilePath -> String -> IO ()+rewriteFile path newContent =+  flip catchIO mightNotExist $ do+    existingContent <- readFile path+    _ <- evaluate (length existingContent)+    unless (existingContent == newContent) $+      writeFileAtomic path newContent+  where+    mightNotExist e | isDoesNotExistError e = writeFileAtomic path 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 = "."++-- ------------------------------------------------------------+-- * Finding the description file+-- ------------------------------------------------------------++-- |Package description file (/pkgname/@.cabal@)+defaultPackageDesc :: Verbosity -> IO FilePath+defaultPackageDesc _verbosity = findPackageDesc currentDir++-- |Find a package description file in the given directory.  Looks for+-- @.cabal@ files.+findPackageDesc :: FilePath    -- ^Where to look+                -> IO FilePath -- ^<pkgname>.cabal+findPackageDesc dir+ = do files <- getDirectoryContents dir+      -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.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+        []          -> noDesc+        [cabalFile] -> return cabalFile+        multiple    -> multiDesc multiple++  where+    noDesc :: IO a+    noDesc = die $ "No cabal file found.\n"+                ++ "Please create a package description file <pkgname>.cabal"++    multiDesc :: [String] -> IO a+    multiDesc l = die $ "Multiple cabal files found.\n"+                    ++ "Please use only one of: "+                    ++ show l++-- |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 . 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 osx+normaliseLineEndings (  c :s)      =   c  : normaliseLineEndings s++-- ------------------------------------------------------------+-- * Common utils+-- ------------------------------------------------------------++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)++intercalate :: [a] -> [[a]] -> [a]+intercalate sep = concat . intersperse sep++lowercase :: String -> String+lowercase = map Char.toLower
+ cabal/cabal/Distribution/System.hs view
@@ -0,0 +1,179 @@+-----------------------------------------------------------------------------+-- |+-- 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,+  ) where++import qualified System.Info (os, arch)+import qualified Data.Char as Char (toLower, isAlphaNum)++import Distribution.Text (Text(..), display)+import qualified Distribution.Compat.ReadP as Parse+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        -- teir 1 desktop OSs+        | FreeBSD | OpenBSD | NetBSD   -- other free unix OSs+        | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs+        | HaLVM                        -- bare metal / VMs / hypervisors+        | OtherOS String+  deriving (Eq, Ord, Show, Read)++--TODO: decide how to handle Android and iOS.+-- They are like Linux and OSX but with some differences.+-- Should they be separate from linux/osx, or a subtype?+-- e.g. should we have os(linux) && os(android) true simultaneously?++knownOSs :: [OS]+knownOSs = [Linux, Windows, OSX+           ,FreeBSD, OpenBSD, NetBSD+           ,Solaris, AIX, HPUX, IRIX+           ,HaLVM]++osAliases :: ClassificationStrictness -> OS -> [String]+osAliases Permissive Windows = ["mingw32", "cygwin32"]+osAliases Compat     Windows = ["mingw32", "win32"]+osAliases _          OSX     = ["darwin"]+osAliases Permissive FreeBSD = ["kfreebsdgnu"]+osAliases Permissive 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 =+  case lookup (lowercase s) osMap of+    Just os -> os+    Nothing -> OtherOS s+  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+          | OtherArch String+  deriving (Eq, Ord, Show, Read)++knownArches :: [Arch]+knownArches = [I386, X86_64, PPC, PPC64, Sparc+              ,Arm, Mips, SH+              ,IA64, S390+              ,Alpha, Hppa, Rs6000+              ,M68k, Vax]++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 =+  case lookup (lowercase s) archMap of+    Just arch -> arch+    Nothing   -> OtherArch s+  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, Ord, Show, Read)++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)++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
+ cabal/cabal/Distribution/TestSuite.hs view
@@ -0,0 +1,310 @@+{-# LANGUAGE CPP, ExistentialQuantification #-}+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.TestSuite+-- Copyright   :  Thomas Tuegel 2010+--+-- 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.++{- 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. -}++#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))+#define NEW_EXCEPTION+#endif++module Distribution.TestSuite+    ( -- * Example+      -- $example+      -- * Options+      Options(..)+    , lookupOption+    , TestOptions(..)+      -- * Tests+    , Test+    , pure, impure+    , Result(..)+    , ImpureTestable(..)+    , PureTestable(..)+    ) where++#ifdef NEW_EXCEPTION+import Control.Exception ( evaluate, catch, throw, SomeException, fromException )+#else+import Control.Exception ( evaluate, catch, throw, Exception(IOException) )+#endif++--TODO: it is totally unreasonable that we have to import things from GHC.* here.+--      see ghc ticket #3517+#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ >= 612+import GHC.IO.Exception  ( IOErrorType(Interrupted) )+#else+import GHC.IOBase        ( IOErrorType(Interrupted) )+#endif+import System.IO.Error   ( ioeGetErrorType )+#endif++import Data.List ( unionBy )+import Data.Monoid ( Monoid(..) )+import Data.Typeable ( TypeRep )+import Prelude hiding ( catch )++-- | 'Options' are provided to pass options to test runners, making tests+-- reproducable.  Each option is a @('String', 'String')@ of the form+-- @(Name, Value)@.  Use 'mappend' to combine sets of 'Options'; if the same+-- option is given different values, the value from the left argument of+-- 'mappend' will be used.+newtype Options = Options [(String, String)]+    deriving (Read, Show, Eq)++instance Monoid Options where+    mempty = Options []+    mappend (Options a) (Options b) = Options $ unionBy (equating fst) a b+      where+        equating p x y = p x == p y+++class TestOptions t where+    -- | The name of the test.+    name :: t -> String++    -- | A list of the options a test recognizes.  The name and 'TypeRep' are+    -- provided so that test agents can ensure that user-specified options are+    -- correctly typed.+    options :: t -> [(String, TypeRep)]++    -- | The default options for a test.  Test frameworks should provide a new+    -- random seed, if appropriate.+    defaultOptions :: t -> IO Options++    -- | Try to parse the provided options.  Return the names of unparsable+    -- options.  This allows test agents to detect bad user-specified options.+    check :: t -> Options -> [String]++-- | Read an option from the specified set of 'Options'.  It is an error to+-- lookup an option that has not been specified.  For this reason, test agents+-- should 'mappend' any 'Options' against the 'defaultOptions' for a test, so+-- the default value specified by the test framework will be used for any+-- otherwise-unspecified options.+lookupOption :: Read r => String -> Options -> r+lookupOption n (Options opts) =+    case lookup n opts of+        Just str -> read str+        Nothing -> error $ "test option not specified: " ++ n++data Result+    = Pass          -- ^ indicates a successful test+    | Fail String   -- ^ indicates a test completed unsuccessfully;+                    -- the 'String' value should be a human-readable message+                    -- indicating how the test failed.+    | Error String  -- ^ indicates a test that could not be+                    -- completed due to some error; the test framework+                    -- should provide a message indicating the+                    -- nature of the error.+    deriving (Read, Show, Eq)++-- | Class abstracting impure tests.  Test frameworks should implement this+-- class only as a last resort for test types which actually require 'IO'.+-- In particular, tests that simply require pseudo-random number generation can+-- be implemented as pure tests.+class TestOptions t => ImpureTestable t where+    -- | Runs an impure test and returns the result.  Test frameworks+    -- implementing this class are responsible for converting any exceptions to+    -- the correct 'Result' value.+    runM :: t -> Options -> IO Result++-- | Class abstracting pure tests.  Test frameworks should prefer to implement+-- this class over 'ImpureTestable'.  A default instance exists so that any pure+-- test can be lifted into an impure test; when lifted, any exceptions are+-- automatically caught.  Test agents that lift pure tests themselves must+-- handle exceptions.+class TestOptions t => PureTestable t where+    -- | The result of a pure test.+    run :: t -> Options -> Result++-- | 'Test' is a wrapper for pure and impure tests so that lists containing+-- arbitrary test types can be constructed.+data Test+    = forall p. PureTestable p => PureTest p+    | forall i. ImpureTestable i => ImpureTest i++-- | A convenient function for wrapping pure tests into 'Test's.+pure :: PureTestable p => p -> Test+pure = PureTest++-- | A convenient function for wrapping impure tests into 'Test's.+impure :: ImpureTestable i => i -> Test+impure = ImpureTest++instance TestOptions Test where+    name (PureTest p) = name p+    name (ImpureTest i) = name i++    options (PureTest p) = options p+    options (ImpureTest i) = options i++    defaultOptions (PureTest p) = defaultOptions p+    defaultOptions (ImpureTest p) = defaultOptions p++    check (PureTest p) = check p+    check (ImpureTest p) = check p++instance ImpureTestable Test where+    runM (PureTest p) o = catch (evaluate $ run p o) handler++    -- Because we have to handle old and new style exceptions, GHC and non-GHC+    -- this code is totally horrible and really fragile. Has to be tested with+    -- lots of ghc versions to check it is right, and with non-ghc too. :-(+#ifdef NEW_EXCEPTION+      where+        handler :: SomeException -> IO Result+        handler e = case fromException e of+          Just ioe | isInterruptedError ioe -> throw e+          _                                 -> return (Error (show e))+#else+      where+        handler :: Exception -> IO Result+        handler e = case e of+          IOException ioe | isInterruptedError ioe -> throw e+          _                                        -> return (Error (show e))+#endif++        -- We do not want to catch control-C here, but only GHC+        -- defines the Interrupted exception type! (ticket #3517)+        isInterruptedError ioe =+#ifdef __GLASGOW_HASKELL__+          ioeGetErrorType ioe == Interrupted+#else+          False+#endif++    runM (ImpureTest i) o = runM i o++-- $example+-- The following terms are used carefully throughout this file:+--+--  [test interface]    The interface provided by this module.+--+--  [test agent]    A program used by package users to coordinates the running+--                  of tests and the reporting of their results.+--+--  [test framework]    A package used by software authors to specify tests,+--                      such as QuickCheck or HUnit.+--+-- Test frameworks are obligated to supply, at least, instances of the+-- 'TestOptions' and 'ImpureTestable' classes.  It is preferred that test+-- frameworks implement 'PureTestable' whenever possible, so that test agents+-- have an assurance that tests can be safely run in parallel.+--+-- Test agents that allow the user to specify options should avoid setting+-- options not listed by the 'options' method.  Test agents should use 'check'+-- before running tests with non-default options.  Test frameworks must+-- implement a 'check' function that attempts to parse the given options safely.+--+-- The packages cabal-test-hunit, cabal-test-quickcheck1, and+-- cabal-test-quickcheck2 provide simple interfaces to these popular test+-- frameworks.  An example from cabal-test-quickcheck2 is shown below.  A+-- better implementation would eliminate the console output from QuickCheck\'s+-- built-in runner and provide an instance of 'PureTestable' instead of+-- 'ImpureTestable'.+--+-- > import Control.Monad (liftM)+-- > import Data.Maybe (catMaybes, fromJust, maybe)+-- > import Data.Typeable (Typeable(..))+-- > import qualified Distribution.TestSuite as Cabal+-- > import System.Random (newStdGen, next, StdGen)+-- > import qualified Test.QuickCheck as QC+-- >+-- > data QCTest = forall prop. QC.Testable prop => QCTest String prop+-- >+-- > test :: QC.Testable prop => String -> prop -> Cabal.Test+-- > test n p = Cabal.impure $ QCTest n p+-- >+-- > instance Cabal.TestOptions QCTest where+-- >     name (QCTest n _) = n+-- >+-- >     options _ =+-- >         [ ("std-gen", typeOf (undefined :: String))+-- >         , ("max-success", typeOf (undefined :: Int))+-- >         , ("max-discard", typeOf (undefined :: Int))+-- >         , ("size", typeOf (undefined :: Int))+-- >         ]+-- >+-- >     defaultOptions _ = do+-- >         rng <- newStdGen+-- >         return $ Cabal.Options $+-- >             [ ("std-gen", show rng)+-- >             , ("max-success", show $ QC.maxSuccess QC.stdArgs)+-- >             , ("max-discard", show $ QC.maxDiscard QC.stdArgs)+-- >             , ("size", show $ QC.maxSize QC.stdArgs)+-- >             ]+-- >+-- >     check t (Cabal.Options opts) = catMaybes+-- >         [ maybeNothing "max-success" ([] :: [(Int, String)])+-- >         , maybeNothing "max-discard" ([] :: [(Int, String)])+-- >         , maybeNothing "size" ([] :: [(Int, String)])+-- >         ]+-- >         -- There is no need to check the parsability of "std-gen"+-- >         -- because the Read instance for StdGen always succeeds.+-- >         where+-- >             maybeNothing n x =+-- >                 maybe Nothing (\str ->+-- >                     if reads str == x then Just n else Nothing)+-- >                     $ lookup n opts+-- >+-- > instance Cabal.ImpureTestable QCTest where+-- >     runM (QCTest _ prop) o =+-- >         catch go (return . Cabal.Error . show)+-- >         where+-- >             go = do+-- >                 result <- QC.quickCheckWithResult args prop+-- >                 return $ case result of+-- >                         QC.Success {} -> Cabal.Pass+-- >                         QC.GaveUp {}->+-- >                             Cabal.Fail $ "gave up after "+-- >                                        ++ show (QC.numTests result)+-- >                                        ++ " tests"+-- >                         QC.Failure {} -> Cabal.Fail $ QC.reason result+-- >                         QC.NoExpectedFailure {} ->+-- >                             Cabal.Fail "passed (expected failure)"+-- >             args = QC.Args+-- >                 { QC.replay = Just+-- >                     ( Cabal.lookupOption "std-gen" o+-- >                     , Cabal.lookupOption "size" o+-- >                     )+-- >                 , QC.maxSuccess = Cabal.lookupOption "max-success" o+-- >                 , QC.maxDiscard = Cabal.lookupOption "max-discard" o+-- >                 , QC.maxSize = Cabal.lookupOption "size" o+-- >                 }
+ cabal/cabal/Distribution/Text.hs view
@@ -0,0 +1,68 @@+-----------------------------------------------------------------------------+-- |+-- 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/cabal/Distribution/Verbosity.hs view
@@ -0,0 +1,113 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Verbosity+-- Copyright   :  Ian Lynagh 2007+--+-- 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++{- Copyright (c) 2007, Ian Lynagh+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. -}++module Distribution.Verbosity (+  -- * Verbosity+  Verbosity,+  silent, normal, verbose, deafening,+  moreVerbose, lessVerbose,+  intToVerbosity, flagToVerbosity,+  showForCabal, showForGHC+ ) where++import Data.List (elemIndex)+import Distribution.ReadE++data Verbosity = Silent | Normal | Verbose | Deafening+    deriving (Show, Read, Eq, Ord, Enum, Bounded)++-- 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/cabal/Distribution/Version.hs view
@@ -0,0 +1,742 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Version+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+--                Duncan Coutts 2008+--+-- 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\"@.++{- Copyright (c) 2003-2004, Isaac Jones+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. -}++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',++  -- * 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 Data.Version     ( Version(..) )++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 (Show,Read,Eq)++{-# 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 anyVersion = 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"+  #-}++-- | Fold over the basic syntactic structure of a 'VersionRange'.+--+-- This provides a syntacic 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 invervals 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+                              : parseWildcardRange+                              : map parseRangeOp rangeOps+        parseAnyVersion    = Parse.string "-any" >> return AnyVersion++        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/cabal/LICENSE view
@@ -0,0 +1,33 @@+Copyright (c) 2003-2008, Isaac Jones, Simon Marlow, Martin Sjögren,+                         Bjorn Bringert, Krasimir Angelov,+                         Malcolm Wallace, Ross Patterson, Ian Lynagh,+                         Duncan Coutts, Thomas Schilling+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/cabal/Language/Haskell/Extension.hs view
@@ -0,0 +1,516 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Language.Haskell.Extension+-- Copyright   :  Isaac Jones 2003-2004+--+-- Maintainer  :  libraries@haskell.org+-- Portability :  portable+--+-- Haskell language dialects and extensions++{- 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. -}++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), (!))++-- ------------------------------------------------------------+-- * 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.+  -- <http://haskell.org/onlinereport/>+     Haskell98++  -- | The Haskell 2010 language as defined by the Haskell 2010 report.+  -- <http://www.haskell.org/onlinereport/haskell2010>+  | Haskell2010++  -- | An unknown language, identified by its name.+  | UnknownLanguage String+  deriving (Show, Read, Eq)++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, Hugs, NHC)+--+-- | 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, e.g. \"GHC &#xa7; 7.2.1\" for an extension+-- documented in section 7.2.1 of the GHC User's Guide.++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 (Show, Read, Eq)++data KnownExtension =++  -- | [GHC &#xa7; 7.6.3.4] Allow overlapping class instances,+  -- provided there is a unique most specific instance for each use.+    OverlappingInstances++  -- | [GHC &#xa7; 7.6.3.3] 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++  -- | [GHC &#xa7; 7.6.3.4] 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++  -- | [GHC &#xa7; 7.3.8] Allows recursive bindings in @do@ blocks,+  -- using the @rec@ keyword.+  | DoRec++  -- | [GHC &#xa7; 7.3.8.2] Deprecated in GHC.  Allows recursive bindings+  -- using @mdo@, a variant of @do@.  @DoRec@ provides a different,+  -- preferred syntax.+  | RecursiveDo++  -- | [GHC &#xa7; 7.3.9] Provide syntax for writing list+  -- comprehensions which iterate over several lists together, like+  -- the 'zipWith' family of functions.+  | ParallelListComp++  -- | [GHC &#xa7; 7.6.1.1] Allow multiple parameters in a type class.+  | MultiParamTypeClasses++  -- | [GHC &#xa7; 7.17] Enable the dreaded monomorphism restriction.+  | MonomorphismRestriction++  -- | [GHC &#xa7; 7.6.2] 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++  -- | [GHC &#xa7; 7.8.5] Like 'RankNTypes' but does not allow a+  -- higher-rank type to itself appear on the left of a function+  -- arrow.+  | Rank2Types++  -- | [GHC &#xa7; 7.8.5] Allow a universally-quantified type to occur on+  -- the left of a function arrow.+  | RankNTypes++  -- | [GHC &#xa7; 7.8.5] Allow data constructors to have polymorphic+  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary+  -- functions.+  | PolymorphicComponents++  -- | [GHC &#xa7; 7.4.4] Allow existentially-quantified data constructors.+  | ExistentialQuantification++  -- | [GHC &#xa7; 7.8.7] 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++  -- | [GHC &#xa7; 7.8.3] Enable implicit function parameters with dynamic+  -- scope.+  | ImplicitParams++  -- | [GHC &#xa7; 7.8.2] Relax some restrictions on the form of the context+  -- of a type signature.+  | FlexibleContexts++  -- | [GHC &#xa7; 7.6.3.2] Relax some restrictions on the form of the+  -- context of an instance declaration.+  | FlexibleInstances++  -- | [GHC &#xa7; 7.4.1] Allow data type declarations with no constructors.+  | EmptyDataDecls++  -- | [GHC &#xa7; 4.10.3] Run the C preprocessor on Haskell source code.+  | CPP++  -- | [GHC &#xa7; 7.8.4] Allow an explicit kind signature giving the kind of+  -- types over which a type variable ranges.+  | KindSignatures++  -- | [GHC &#xa7; 7.11] Enable a form of pattern which forces evaluation+  -- before an attempted match, and a form of strict @let@/@where@+  -- binding.+  | BangPatterns++  -- | [GHC &#xa7; 7.6.3.1] Allow type synonyms in instance heads.+  | TypeSynonymInstances++  -- | [GHC &#xa7; 7.9] Enable Template Haskell, a system for compile-time+  -- metaprogramming.+  | TemplateHaskell++  -- | [GHC &#xa7; 8] Enable the Foreign Function Interface.  In GHC,+  -- implements the standard Haskell 98 Foreign Function Interface+  -- Addendum, plus some GHC-specific extensions.+  | ForeignFunctionInterface++  -- | [GHC &#xa7; 7.10] Enable arrow notation.+  | Arrows++  -- | [GHC &#xa7; 7.16] Enable generic type classes, with default instances+  -- defined in terms of the algebraic structure of a type.+  | Generics++  -- | [GHC &#xa7; 7.3.11] 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++  -- | [GHC &#xa7; 7.3.15] Enable syntax for implicitly binding local names+  -- corresponding to the field names of a record.  Puns bind specific+  -- names, unlike 'RecordWildCards'.+  | NamedFieldPuns++  -- | [GHC &#xa7; 7.3.5] Enable a form of guard which matches a pattern and+  -- binds variables.+  | PatternGuards++  -- | [GHC &#xa7; 7.5.4] Allow a type declared with @newtype@ to use+  -- @deriving@ for any class with an instance for the underlying type.+  | GeneralizedNewtypeDeriving++  -- | [Hugs &#xa7; 7.1] Enable the \"Trex\" extensible records system.+  | ExtensibleRecords++  -- | [Hugs &#xa7; 7.2] Enable type synonyms which are transparent in+  -- some definitions and opaque elsewhere, as a way of implementing +  -- abstract datatypes.+  | RestrictedTypeSynonyms++  -- | [Hugs &#xa7; 7.3] Enable an alternate syntax for string literals,+  -- with string templating.+  | HereDocuments++  -- | [GHC &#xa7; 7.3.2] Allow the character @#@ as a postfix modifier on+  -- identifiers.  Also enables literal syntax for unboxed values.+  | MagicHash++  -- | [GHC &#xa7; 7.7] Allow data types and type synonyms which are+  -- indexed by types, i.e. ad-hoc polymorphism for types.+  | TypeFamilies++  -- | [GHC &#xa7; 7.5.2] Allow a standalone declaration which invokes the+  -- type class @deriving@ mechanism.+  | StandaloneDeriving++  -- | [GHC &#xa7; 7.3.1] Allow certain Unicode characters to stand for+  -- certain ASCII character sequences, e.g. keywords and punctuation.+  | UnicodeSyntax++  -- | [GHC &#xa7; 8.1.1] Allow the use of unboxed types as foreign types,+  -- e.g. in @foreign import@ and @foreign export@.+  | UnliftedFFITypes++  -- | [GHC &#xa7; 7.4.3] Defer validity checking of types until after+  -- expanding type synonyms, relaxing the constraints on how synonyms+  -- may be used.+  | LiberalTypeSynonyms++  -- | [GHC &#xa7; 7.4.2] Allow the name of a type constructor, type class,+  -- or type variable to be an infix operator.+  | TypeOperators++--PArr -- not ready yet, and will probably be renamed to ParallelArrays++  -- | [GHC &#xa7; 7.3.16] 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++  -- | [GHC &#xa7; 7.3.14] Allow a record field name to be disambiguated+  -- by the type of the record it's in.+  | DisambiguateRecordFields++  -- | [GHC &#xa7; 7.6.4] Enable overloading of string literals using a+  -- type class, much like integer literals.+  | OverloadedStrings++  -- | [GHC &#xa7; 7.4.6] 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++  -- | [GHC &#xa7; 7.17.2] Make pattern bindings monomorphic.+  | MonoPatBinds++  -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive+  -- polymorphic functions.+  | RelaxedPolyRec++  -- | [GHC &#xa7; 2.4.5] Allow default instantiation of polymorphic+  -- types in more situations.+  | ExtendedDefaultRules++  -- | [GHC &#xa7; 7.2.2] Enable unboxed tuples.+  | UnboxedTuples++  -- | [GHC &#xa7; 7.5.3] Enable @deriving@ for classes+  -- @Data.Typeable.Typeable@ and @Data.Generics.Data@.+  | DeriveDataTypeable++  -- | [GHC &#xa7; 7.6.1.3] Allow a class method's type to place+  -- additional constraints on a class type variable.+  | ConstrainedClassMethods++  -- | [GHC &#xa7; 7.3.18] Allow imports to be qualified by the package+  -- name the module is intended to be imported from, e.g.+  --+  -- > import "network" Network.Socket+  | PackageImports++  -- | [GHC &#xa7; 7.8.6] Deprecated in GHC 6.12 and will be removed in+  -- GHC 7.  Allow a type variable to be instantiated at a+  -- polymorphic type.+  | ImpredicativeTypes++  -- | [GHC &#xa7; 7.3.3] Change the syntax for qualified infix+  -- operators.+  | NewQualifiedOperators++  -- | [GHC &#xa7; 7.3.12] Relax the interpretation of left operator+  -- sections to allow unary postfix operators.+  | PostfixOperators++  -- | [GHC &#xa7; 7.9.5] Enable quasi-quotation, a mechanism for defining+  -- new concrete syntax for expressions and patterns.+  | QuasiQuotes++  -- | [GHC &#xa7; 7.3.10] Enable generalized list comprehensions,+  -- supporting operations such as sorting and grouping.+  | TransformListComp++  -- | [GHC &#xa7; 7.3.6] 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:+  -- <http://www.haskell.org/haskellwiki/HSP>. 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++  -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into+  -- @\x -> (x, True)@.+  | TupleSections++  -- | Allows 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++  -- | 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++  deriving (Show, Read, Eq, Enum, Bounded)++{-# 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 recomend 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/cabal/Makefile view
@@ -0,0 +1,130 @@++VERSION=1.11.2++#KIND=devel+KIND=rc+#KIND=cabal-latest++PREFIX=/usr/local+HC=ghc+GHCFLAGS=-Wall++all: build++# build the library itself++SOURCES=Distribution/*.hs Distribution/Simple/*.hs Distribution/PackageDescription/*.hs Distribution/Simple/GHC/*.hs Distribution/Simple/Build/*.hs Distribution/Compat/*.hs Distribution/Simple/Program/*.hs+CONFIG_STAMP=dist/setup-config+BUILD_STAMP=dist/build/libHSCabal-$(VERSION).a+HADDOCK_STAMP=dist/doc/html/Cabal/index.html+USERGUIDE_STAMP=dist/doc/users-guide/index.html+SDIST_STAMP=dist/Cabal-$(VERSION).tar.gz+DISTLOC=dist/release+DIST_STAMP=$(DISTLOC)/Cabal-$(VERSION).tar.gz++COMMA=,++setup: $(SOURCES) Setup.hs+	-mkdir -p dist/setup+	$(HC) $(GHCFLAGS) --make -i. -odir dist/setup -hidir dist/setup Setup.hs -o setup++Setup-nhc:+	hmake -nhc98 -package base -prelude Setup++$(CONFIG_STAMP): setup Cabal.cabal+	./setup configure --with-compiler=$(HC) --prefix=$(PREFIX)++build: $(BUILD_STAMP)+$(BUILD_STAMP): $(CONFIG_STAMP) $(SOURCES)+	./setup build++install: $(BUILD_STAMP)+	./setup install++hugsbootstrap:+	rm -rf dist/tmp dist/hugs+	mkdir -p dist/tmp+	mkdir dist/hugs+	cp -r Distribution dist/tmp+	hugs-package dist/tmp dist/hugs+	cp Setup.lhs Cabal.cabal dist/hugs++hugsinstall: hugsbootstrap+	cd dist/hugs && ./Setup.lhs configure --hugs+	cd dist/hugs && ./Setup.lhs build+	cd dist/hugs && ./Setup.lhs install++# documentation...++haddock: $(HADDOCK_STAMP)+$(HADDOCK_STAMP) : $(CONFIG_STAMP) $(BUILD_STAMP)+	./setup haddock++PANDOC=pandoc+PANDOC_OPTIONS= \+	--standalone \+	--smart \+	--css=$(PANDOC_HTML_CSS)+PANDOC_HTML_OUTDIR=dist/doc/users-guide+PANDOC_HTML_CSS=Cabal.css++users-guide: $(USERGUIDE_STAMP) doc/*.markdown+$(USERGUIDE_STAMP): doc/*.markdown+	mkdir -p $(PANDOC_HTML_OUTDIR)+	for file in $^; do $(PANDOC) $(PANDOC_OPTIONS) --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; done+	cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR)++docs: haddock users-guide++clean:+	rm -rf dist/+	rm -f setup++# testing...++moduleTest: tests/ModuleTest.hs tests/PackageDescriptionTests.hs+	mkdir -p dist/test+	$(HC) --make -Wall -DDEBUG -odir dist/test -hidir dist/test \+		-itests tests/ModuleTest.hs -o moduleTest++#tests: moduleTest clean+#	cd tests/A && $(MAKE) clean+#	cd tests/HUnit-1.0 && $(MAKE) clean+#	cd tests/A && $(MAKE)+#	cd tests/HUnit-1.0 && $(MAKE)++#check:+#	rm -f moduleTest+#	$(MAKE) moduleTest+#	./moduleTest++# distribution...++$(SDIST_STAMP) : $(BUILD_STAMP)+	./setup sdist++dist: $(DIST_STAMP)+$(DIST_STAMP) : $(HADDOCK_STAMP) $(USERGUIDE_STAMP) $(SDIST_STAMP)+	rm -rf $(DISTLOC)+	mkdir $(DISTLOC)+	tar -xzf $(SDIST_STAMP) -C $(DISTLOC)/+	mkdir $(DISTLOC)/Cabal-$(VERSION)/doc+	cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API+	cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/+	cp changelog $(DISTLOC)/Cabal-$(VERSION)/+	tar -C $(DISTLOC) -c Cabal-$(VERSION) -zf $(DISTLOC)/Cabal-$(VERSION).tar.gz+	mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/+	mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/+	rm -r $(DISTLOC)/Cabal-$(VERSION)/+	@echo "Cabal tarball built: $(DIST_STAMP)"+	@echo "Release fileset prepared: $(DISTLOC)/"++release: $(DIST_STAMP)+	scp -r $(DISTLOC) haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION)+	ssh haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)'++# tags...++TAGSSRCDIRS = Distribution Language+tags TAGS: $(SOURCES)+	find $(TAGSSRCDIRS) -name \*.\*hs | xargs hasktags
+ cabal/cabal/Paths_Cabal.hs view
@@ -0,0 +1,8 @@+module Paths_Cabal (+    version,+  ) where++import Data.Version (Version(..))++version :: Version+version = Version {versionBranch = [1,12,0], versionTags = []}
+ cabal/cabal/README view
@@ -0,0 +1,168 @@+The Cabal library package+=========================++[Cabal home page](http://www.haskell.org/cabal/)++If you also want the `cabal` command line program then you need+the `cabal-install` package in addition to this library.+++Installation instructions for the Cabal library+===============================================++Installing as a user (no root or administer access)+---------------------------------------------------++    ghc --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 / Administrator+----------------------------------++    ghc --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.+++Working with older versions of GHC and Cabal+============================================++It is recommended just to leave any pre-existing version of Cabal+installed. In particular it is *essential* to keep the version that+came with GHC itself since other installed packages need it (eg the+"ghc" api package).++Prior to GHC 6.4.2 however, GHC didn't 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 probably just want to remove it:++    ghc-pkg unregister Cabal++or if you had Cabal installed just for your user account then:++    ghc-pkg unregister Cabal --user+++The `filepath` dependency+=========================++Cabal now uses the `filepath` package so that must be installed first.+GHC-6.6.1 and later come with `filepath` however earlier versions do not by+default. If you do not already have `filepath` then you need to install it. You+can use any existing version of Cabal to do that. If you have neither Cabal or+filepath then 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 you are then in a position to install Cabal by the+normal method.+++More Information+================++Please see the web site for the [user guide] and API documentation.+There is some more information available on the [development wiki].++[user guide]:       http://www.haskell.org/cabal/+[development wiki]: http://hackage.haskell.org/trac/hackage/+++Bugs+=======++Please report bugs and wish-list items in our [bug tracker].++[bug tracker]: http://hackage.haskell.org/trac/hackage/+++Your Help+---------++To help us in the next round of development work it would be+enormously helpful to know from our users what their most pressing+problems are with Cabal and Hackage. You probably have a favourite+Cabal bug or limitation. Take a look at our [bug tracker]. Make sure+the problem is reported there and properly described. Comment on the+ticket to tell us how much of a problem the bug is for you. Add+yourself to the ticket's cc list so we can discuss requirements and+keep you informed on progress. For feature requests it is very+helpful if there is a description of how you would expect to+interact with the new feature.+++Code+=======++You can get the code from the web page; the version control system we+use is very open and welcoming to new developers.++You can get the main development branch:++> darcs get --partial http://darcs.haskell.org/cabal++and you can get the stable 1.6 branch:++> darcs get --partial http://darcs.haskell.org/cabal-branches/cabal-1.6+++Credits+=======++Cabal Coders (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 spec:++- Isaac Jones+- Simon Marlow+- Ross Patterson+- Simon Peyton Jones+- Malcolm Wallace
+ cabal/cabal/Setup.hs view
@@ -0,0 +1,10 @@+import 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/cabal/changelog view
@@ -0,0 +1,385 @@+-*-change-log-*-++1.11.x (current development version)++1.10.0.x (next stable release version)++1.10.2.0 Duncan Coutts <duncan@community.haskell.org> 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 <duncan@community.haskell.org> 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 <duncan@haskell.org> 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_<package> 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 <duncan@haskell.org> June 2010+	* Fix 'register --global/--user'++1.8.0.4 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> October 2008+	* Export a compat function to help alex and happy++1.6.0.0 Duncan Coutts <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan@haskell.org> 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 <duncan.coutts@worc.ox.ac.uk> 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+	* Seperate "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 <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> Oct 2006+	* fix unlit code+	* fix escaping in register.sh++1.1.6  Duncan Coutts <duncan.coutts@worc.ox.ac.uk> 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 <duncan.coutts@worc.ox.ac.uk> 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  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> March 11 2005+	* Released with GHC 6.4, Hugs March 2005, and nhc98 1.18+	* Some sanity checking++0.5  Isaac Jones  <ijones@syntaxpolice.org> 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  <ijones@syntaxpolice.org> 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 <something>.cabal.  In particular, we suggest+	that you name it <packagename>.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  <ijones@syntaxpolice.org> Sun Jan 16 2005+	* Unstable snapshot release+	* From now on, stable releases are even.++0.2  Isaac Jones  <ijones@syntaxpolice.org>++	* Adds more HUGS support and preprocessor support.
+ cabal/cabal/doc/Cabal.css view
@@ -0,0 +1,39 @@+div {+  font-family: sans-serif;+  color: black;+  background: white+}++h1, h2, h3, h4, h5, h6, p.title { color: #005A9C }++h1 { font:            170% sans-serif }+h2 { font:            140% sans-serif }+h3 { font:            120% sans-serif }+h4 { font: bold       100% sans-serif }+h5 { font: italic     100% sans-serif }+h6 { font: small-caps 100% sans-serif }++pre {+  font-family: monospace;+  border-width: 1px;+  border-style: solid;+  padding: 0.3em+}++pre.screen         { color: #006400 }+pre.programlisting { color: maroon }++div.example {+  margin: 1ex 0em;+  border: solid #412e25 1px;+  padding: 0ex 0.4em+}++div.example, div.example-contents {+  background-color: #fffcf5+}++a:link    { color:      #0000C8 }+a:hover   { background: #FFFFA8 }+a:active  { color:      #D00000 }+a:visited { color:      #680098 }
+ cabal/cabal/doc/developing-packages.markdown view
@@ -0,0 +1,1447 @@+% Cabal User Guide++# 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 dependended 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](#building-and-installing-a-package)). This module should+    import only modules that will be present in all Haskell+    implementations, including modules of the Cabal library.  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](#building-and-installing-a-package).++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+  nhc98-options:   -K4m+  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 (except nhc98, for now).++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](#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](#executable) 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`, `NHC`, `YHC`, `Hugs`, `HBC`,+    `Helium`, `JHC`, 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](#packages), 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, intoducing 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 compatability and+    behaviour. Most tools (including the Cabal libray 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+    compatability 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+    this field is given a value other than `Custom`, some tools such as+    `cabal-install` will be able to build the package without using the+    setup script. So if you are just using the default `Setup.hs` then+    set the build type as `Simple`.++`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_+:   The name of a file containing the precise license for this package.+    It will be installed with the package.++`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, eg 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`](#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`](#setup-sdist). 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`](#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.++The library section may also contain build information fields (see the+section on [build information](#build-information)).+++### 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`.++### 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-1.0`.  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-1.0`+interface.  The `exitcode-stdio-1.0` type requires the `main-is` field.++`main-is:` _filename_ (required: `exitcode-stdio-1.0`, disallowed: `detailed-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.++Test suites using the `detailed-1.0` interface are modules exporting the symbol+`tests :: [Test]`.  The `Test` type is exported by the module+`Distribution.TestSuite` provided by Cabal.  For more details, see the example below.++The `detailed-1.0` 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-1.0` interface requires the+`test-module` field.++`test-module:` _identifier_ (required: `detailed-1.0`, 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-1.0` interface ####++The example package description and test module source file below demonstrate+the use of the `detailed-1.0` 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-1.0+    test-module: Test.Bar+    build-depends: base, Cabal >= 1.9.2+~~~~~~~~~~~~~~~~++Test/Bar.hs:++~~~~~~~~~~~~~~~~+{-# LANGUAGE FlexibleInstances #-}+module Test.Bar ( tests ) where++import Distribution.TestSuite++instance TestOptions (String, Bool) where+    name = fst+    options = const []+    defaultOptions _ = return (Options [])+    check _ _ = []++instance PureTestable (String, Bool) where+    run (name, result) _ | result == True = Pass+                         | result == False = Fail (name ++ " failed!")++test :: (String, Bool) -> Test+test = pure++-- In actual usage, the instances 'TestOptions (String, Bool)' and+-- 'PureTestable (String, Bool)', as well as the function 'test', would be+-- provided by the test framework.++tests :: [Test]+tests =+    [ test ("bar-1", True)+    , test ("bar-2", False)+    ]+~~~~~~~~~~~~~~~~++### 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`.++    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.++`hugs-options:` _token list_+:   Additional options for Hugs. 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_HUGS` pragma in the source file affected.++`nhc98-options:` _token list_+:   Additional options for nhc98. 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_NHC98` pragma in the source file affected.++`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`, `ffihugs`, `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.++    If you use this field, you should also name the C files in `CFILES`+    pragmas in the Haskell source files that use them, e.g.: `{-# CFILES+    dir/file1.c dir/file2.c #-}` These are ignored by the compilers, but+    needed by Hugs.++`extra-libraries:` _token list_+:   A list of extra libraries to link with.++`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).++`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](#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](#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) || impl(hugs)+      Extensions: MultiParamTypeClasses+    ~~~~~~~~~~~~~~~~++    when compiled using Hugs or 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+repo 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 repo 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` repo kind to identify the state of a repo+    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` repo 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, ie 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.++## 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](#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.  A variant of the simple build infrastructure (the+`build-type` `Configure`) handles many such situations using a slightly+longer `Setup.hs`:++~~~~~~~~~~~~~~~~+import Distribution.Simple+main = defaultMainWithHooks autoconfUserHooks+~~~~~~~~~~~~~~~~++Most packages, however, would probably do better with+[configurations](#configurations).++This program differs from `defaultMain` 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 <X11/Xlib.h>],,[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`.++## 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 depenency+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).++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.++## More complex packages ##++For packages that don't fit the simple schemes described above, you have+a few options:++  * You can 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.  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` looks like++    ~~~~~~~~~~~~~~~~+    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` and `--libexecdir` 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)+        ~~~~~~~~~~~~~~~~++  * You can write your own setup script conforming to the interface+    described in the section on [building and installing+    packages](#building-and-installing-a-package), possibly using the+    Cabal library for part of the work.  One option is to copy the+    source of `Distribution.Simple`, and alter it for your needs.+    Good luck.++++[dist-simple]:  ../libraries/Cabal/Distribution-Simple.html+[dist-make]:    ../libraries/Cabal/Distribution-Make.html+[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License+[extension]:    ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension+[BuildType]:    ../libraries/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://www.haskell.org/cpphs/+[greencard]:  http://www.haskell.org/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://pkg-config.freedesktop.org/
+ cabal/cabal/doc/index.markdown view
@@ -0,0 +1,169 @@+% Cabal User Guide++Cabal is package system for [Haskell] software.++Cabal specifies a standard way in which Haskell libraries and+applications can be packaged so that it is easy for consumers to use+them, or re-package them, regardless of the Haskell implementation or+installation platform.++Cabal defines a common interface -- the _Cabal package_ -- between+package authors, builders and users. There is a library to help package+authors implement this interface, and a tool to enable developers,+builders and users to work with Cabal packages.++# Contents #++  * [Introduction](#introduction)+      - [What's in a package](#whats-in-a-package)+      - [A tool for working with packages](#a-tool-for-working-with-packages)+  * [Developing packages](developing-packages.html)+      - [Package descriptions](developing-packages.html#package-descriptions)+          + [Package properties](developing-packages.html#package-properties)+          + [Library](developing-packages.html#library)+          + [Executables](developing-packages.html#executables)+          + [Test suites](developing-packages.html#test-suites)+          + [Build information](developing-packages.html#build-information)+          + [Configurations](developing-packages.html#configurations)+          + [Source Repositories](developing-packages.html#source-repositories)+      - [Accessing data files from package code](developing-packages.html#accessing-data-files-from-package-code)+          + [Accessing the package version](developing-packages.html#accessing-the-package-version)+      - [System-dependent parameters](developing-packages.html#system-dependent-parameters)+      - [Conditional compilation](developing-packages.html#conditional-compilation)+      - [More complex packages](developing-packages.html#more-complex-packages)+  * [Building and installing packages](installing-packages.html)+      - [Building and installing a system package](installing-packages.html#building-and-installing-a-system-package)+      - [Building and installing a user package](installing-packages.html#building-and-installing-a-user-package)+      - [Creating a binary package](installing-packages.html#creating-a-binary-package)+      - [setup configure](installing-packages.html#setup-configure)+          + [Programs used for building](installing-packages.html#programs-used-for-building)+          + [Installation paths](installing-packages.html#installation-paths)+          + [Controlling Flag Assignments](installing-packages.html#controlling-flag-assignments)+          + [Building Test Suites](installing-packages.html#building-test-suites)+          + [Miscellaneous options](installing-packages.html#miscellaneous-options)+      - [setup build](installing-packages.html#setup-build)+      - [setup haddock](installing-packages.html#setup-haddock)+      - [setup hscolour](installing-packages.html#setup-hscolour)+      - [setup install](installing-packages.html#setup-install)+      - [setup copy](installing-packages.html#setup-copy)+      - [setup register](installing-packages.html#setup-register)+      - [setup unregister](installing-packages.html#setup-unregister)+      - [setup clean](installing-packages.html#setup-clean)+      - [setup test](installing-packages.html#setup-test)+      - [setup sdist](installing-packages.html#setup-sdist)+  * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies)+  * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces)+      - [Cabal file format](misc.html#cabal-file-format)+      - [Command-line interface](misc.html#command-line-interface)+          + [Very Stable Command-line interfaces](misc.html#very-stable-command-line-interfaces)+          + [Stable Command-line interfaces](misc.html#stable-command-line-interfaces)+          + [Unstable command-line](misc.html#unstable-command-line)+      - [Functions and Types](misc.html#functions-and-types)+          + [Very Stable API](misc.html#very-stable-api)+          + [Semi-stable API](misc.html#semi-stable-api)+          + [Unstable API](#unstable-api)+      - [Hackage](misc.html#hackage)++# Introduction #++Cabal is package system for Haskell software. The point of a packaging+system is to enable software developers and users to easily distribute,+use and reuse software. A good packaging system makes it easier for+developers to get their software into the hands of users, but 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 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, but most+Haskell implementations have some notion of package, and Cabal supports+most Haskell implementations.+++## What's in a package ##++A Cabal package consists of:++  * Haskell software, including libraries, executables and tests+  * meta-data 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. Some of this information is used for identifying and+managing the package when it comes to distribution.++For the majority of packages it is possible to supply enough information+in the `.cabal` file so that it can be built without the package author+needing to write any extra build system scripts. For complex packages it+may be necessary to add code to the `Setup.hs` file.++Here is an example `foo.cabal` for a very simple Haskell library that+exposes one Haskell module called `Data.Foo`:++~~~~~~~~~~~~~~~~+name:              foo+version:           1.0+build-type:        Simple+cabal-version:     >= 1.2++library+  exposed-modules: Data.Foo+  build-depends:   base >= 3 && < 5+~~~~~~~~~~~~~~~~++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).+++## A tool for working with packages ##++There is a command line tool, called `cabal`, that users and developers+can use to install Cabal packages. It can be used for both local+packages and for packages available remotely over the network.++Developers can use the tool with packages in local directories, e.g.++~~~~~~~~~~~~~~~~+cd foo/+cabal install+~~~~~~~~~~~~~~~~++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 centeralised Haskell community 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.++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.++[Haskell]:  http://www.haskell.org/+[Hackage]:  http://hackage.haskell.org/
+ cabal/cabal/doc/installing-packages.markdown view
@@ -0,0 +1,809 @@+% 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 using the `Setup.hs` or+`Setup.lhs` script there:++> `_runhaskell_ Setup.hs` [_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++> `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`).++## Creating a binary package ##++When creating binary packages (e.g. for RedHat 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](#system-dependent-parameters) or on+[complex packages](#complex-packages)), it is passed the+`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir` and+`--libexecdir` 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`, `--nhc`, `--jhc`, `--hugs`+:   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`.++`--`_`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 embeded+    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 embeded spaces, such as a file name+    with embeded 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`++`--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`++`--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`++`--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`++`--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`++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`++`--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`++`--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`++`--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`++`--program-prefix=`_prefix_+:   Prepend _prefix_ to installed program names.++    _prefix_ may contain the following path variables: `$pkgid`, `$pkg`,+    `$version`, `$compiler`, `$os`, `$arch`++`--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`++#### 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 instllation 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, eg `mypkg-0.2`++`$pkg`+:   The name of the package, eg `mypkg`++`$version`+:   The version of the package, eg `0.2`++`$compiler`+:   The compiler being used to build the package, eg `ghc-6.6.1`++`$os`+:   The operating system of the computer being used to build the+    package, eg `linux`, `windows`, `osx`, `freebsd` or `solaris`++`$arch`+:   The architecture of the computer being used to build the package, eg+    `i386`, `x86_64`, `ppc` or `sparc`++#### 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` (Hugs)       `hugs\packages\$pkg`                                      `hugs/packages/$pkg`+`--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`+`--htmldir`                `$docdir\html`                                            `$docdir/html`+`--program-prefix`         (empty)                                                   (empty)+`--program-suffix`         (empty)                                                   (empty)+++#### Prefix-independence ####++On Windows, and when using Hugs on any system, 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](#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](#resolution-of-conditions-and-flags)) can be controlled with the+followingcommand 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.++### 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 instllation 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-executable-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.++`--disable-executable-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 seperate compiler run to+    generate position independent code as required on most platforms.++`--disable-shared`+:   (default) Do not build shared library.++`--configure-option=`_str_+:   An extra option to an external `configure` script, if one is used+    (see the section on [system-dependent+    parameters](#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.++In the simple build infrastructure, an additional option is recognized:++`--scratchdir=`_dir_+:   Specify the directory into which the Hugs output will be placed+    (default: `dist/scratch`).++## 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`, `$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`, 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), or+    `failures` (show only the test cases of failing test suites).++`--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`, `data-files` and `extra-source-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]:  ../libraries/Cabal/Distribution-Simple.html+[dist-make]:    ../libraries/Cabal/Distribution-Make.html+[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License+[extension]:    ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension+[BuildType]:    ../libraries/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://www.haskell.org/cpphs/+[greencard]:  http://www.haskell.org/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://pkg-config.freedesktop.org/
+ cabal/cabal/doc/misc.markdown view
@@ -0,0 +1,109 @@+% 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+<libraries@haskell.org>. There is also a development mailing list+<cabal-devel@haskell.org>.++[bug tracker]: http://hackage.haskell.org/trac/hackage/++# 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 therefor 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`, `--hugs`+  * `--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://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]:  ../libraries/Cabal/Distribution-Simple.html+[dist-make]:    ../libraries/Cabal/Distribution-Make.html+[dist-license]: ../libraries/Cabal/Distribution-License.html#t:License+[extension]:    ../libraries/Cabal/Language-Haskell-Extension.html#t:Extension+[BuildType]:    ../libraries/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://www.haskell.org/cpphs/+[greencard]:  http://www.haskell.org/greencard/+[haddock]:    http://www.haskell.org/haddock/+[HsColour]:   http://www.cs.york.ac.uk/fp/darcs/hscolour/+[happy]:      http://www.haskell.org/happy/+[HackageDB]:  http://hackage.haskell.org/+[pkg-config]: http://pkg-config.freedesktop.org/
+ cabal/cabal/prologue.txt view
@@ -0,0 +1,7 @@+The Haskell Cabal is the Common Architecture for Building Applications+and Libraries.  It is a framework which defines a common interface for+authors to more easily build their applications in a portable way. The+Haskell Cabal is meant to be a part of a larger infrastructure for+distributing, organizing, and cataloging Haskell Libraries and+Tools. For more information, please see:+<http://www.haskell.org/cabal/>.
+ cabal/cabal/runTests.sh view
@@ -0,0 +1,21 @@+#!/bin/sh++HCBASE=/usr/bin/+HC=$HCBASE/ghc+GHCFLAGS='--make -Wall -fno-warn-unused-matches -cpp'+ISPOSIX=-DHAVE_UNIX_PACKAGE++rm -f moduleTest+mkdir -p dist/debug+echo Building...+$HC $GHCFLAGS $ISPOSIX -DDEBUG -odir dist/debug -hidir dist/debug -idist/debug/:.:tests/HUnit-1.0/src tests/ModuleTest.hs -o moduleTest 2> stderr+RES=$?+if [ $RES != 0 ]+then+    cat stderr >&2+    exit $RES+fi+echo Running...+./moduleTest+echo Done+
+ cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Check.hs view
@@ -0,0 +1,15 @@+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive1") []+    result <- cabal_build spec+    assertEqual "cabal build should fail - see test-log.txt" False (successful result)+    assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $+        "Failed to load interface for `Prelude'" `isInfixOf` outputText result
+ cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal view
@@ -0,0 +1,20 @@+name: 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/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Check.hs view
@@ -0,0 +1,15 @@+module PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "GlobalBuildDepsNotAdditive2") []+    result <- cabal_build spec+    assertEqual "cabal build should fail - see test-log.txt" False (successful result)+    assertBool "cabal error should be \"Failed to load interface for `Prelude'\"" $+        "Failed to load interface for `Prelude'" `isInfixOf` outputText result
+ cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal view
@@ -0,0 +1,20 @@+name: 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/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Check.hs view
@@ -0,0 +1,20 @@+module PackageTests.BuildDeps.InternalLibrary0.Check where++import Test.HUnit+import PackageTests.PackageTester+import Control.Monad+import System.FilePath+import Data.Version+import Data.List (isInfixOf, intercalate)+++suite :: Version -> Test+suite cabalVersion = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary0") []+    result <- cabal_build spec+    assertEqual "cabal build should fail" False (successful result)+    when (cabalVersion >= Version [1, 7] []) $ do+        -- In 1.7 it should tell you how to enable the desired behaviour.+        assertEqual "error should say 'library which is defined within the same package.'" True $+            "library which is defined within the same package." `isInfixOf` (intercalate " " $ lines $ outputText result)+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal view
@@ -0,0 +1,24 @@+name: 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Check.hs view
@@ -0,0 +1,12 @@+module PackageTests.BuildDeps.InternalLibrary1.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary1") []+    result <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal view
@@ -0,0 +1,23 @@+name: 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Check.hs view
@@ -0,0 +1,24 @@+module PackageTests.BuildDeps.InternalLibrary2.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import qualified Data.ByteString.Char8 as C+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary2") []+    let specTI = PackageSpec (directory spec </> "to-install") []++    unregister "InternalLibrary2"+    iResult <- cabal_install specTI                     +    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)+    bResult <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)+    unregister "InternalLibrary2"++    (_, _, output) <- run (Just $ 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal view
@@ -0,0 +1,23 @@+name: 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Check.hs view
@@ -0,0 +1,24 @@+module PackageTests.BuildDeps.InternalLibrary3.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import qualified Data.ByteString.Char8 as C+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary3") []+    let specTI = PackageSpec (directory spec </> "to-install") []++    unregister "InternalLibrary3"+    iResult <- cabal_install specTI                     +    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)+    bResult <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)+    unregister "InternalLibrary3"++    (_, _, output) <- run (Just $ 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal view
@@ -0,0 +1,23 @@+name: 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Check.hs view
@@ -0,0 +1,24 @@+module PackageTests.BuildDeps.InternalLibrary4.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import qualified Data.ByteString.Char8 as C+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "InternalLibrary4") []+    let specTI = PackageSpec (directory spec </> "to-install") []++    unregister "InternalLibrary4"+    iResult <- cabal_install specTI                     +    assertEqual "cabal install should succeed - see to-install/test-log.txt" True (successful iResult)+    bResult <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful bResult)+    unregister "InternalLibrary4"++    (_, _, output) <- run (Just $ 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal view
@@ -0,0 +1,23 @@+name: 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs view
@@ -0,0 +1,6 @@+import System.Time+import MyLibrary++main = do+    getClockTime+    myLibFunc
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal view
@@ -0,0 +1,18 @@+name: 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/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Check.hs view
@@ -0,0 +1,12 @@+module PackageTests.BuildDeps.SameDepsAllRound.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "SameDepsAllRound") []+    result <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal view
@@ -0,0 +1,31 @@+name: 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/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal/tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "pineapple"+    C.putStrLn $ C.pack text
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Check.hs view
@@ -0,0 +1,18 @@+module PackageTests.BuildDeps.TargetSpecificDeps1.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps1") []+    result <- cabal_build spec+    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\"" $+        "Could not find module `System.Time'" `isInfixOf`+                        (intercalate " " $ lines $ outputText result)
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal view
@@ -0,0 +1,22 @@+name: 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/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Check.hs view
@@ -0,0 +1,13 @@+module PackageTests.BuildDeps.TargetSpecificDeps2.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps2") []+    result <- cabal_build spec+    assertEqual "cabal build should succeed - see test-log.txt" True (successful result)
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs view
@@ -0,0 +1,5 @@+import qualified Data.ByteString.Char8 as C++main = do+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal view
@@ -0,0 +1,24 @@+name: 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/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Check.hs view
@@ -0,0 +1,17 @@+module PackageTests.BuildDeps.TargetSpecificDeps3.Check where++import Test.HUnit+import PackageTests.PackageTester+import System.FilePath+import Data.List+++suite :: Test+suite = TestCase $ do+    let spec = PackageSpec ("PackageTests" </> "BuildDeps" </> "TargetSpecificDeps3") []+    result <- cabal_build spec+    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\"" $+        "Could not find module `System.Time'" `isInfixOf` (intercalate " " $ lines $ outputText result)
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs view
@@ -0,0 +1,10 @@+module 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/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs view
@@ -0,0 +1,7 @@+import qualified Data.ByteString.Char8 as C+import System.Time++main = do+    getClockTime+    let text = "lemon"+    C.putStrLn $ C.pack text
+ cabal/cabal/tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal view
@@ -0,0 +1,22 @@+name: 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/cabal/tests/PackageTests/PackageTester.hs view
@@ -0,0 +1,192 @@+module PackageTests.PackageTester (+        PackageSpec(..),+        Success(..),+        Result(..),+        cabal_configure,+        cabal_build,+        cabal_test,+        cabal_install,+        unregister,+        run+    ) where++import qualified Control.Exception.Extensible as E+import System.Directory+import System.FilePath+import System.IO+import System.Posix.IO+import System.Process+import System.Exit+import Control.Concurrent.Chan+import Control.Concurrent.MVar+import Control.Concurrent+import Control.Monad+import Data.List+import Data.Maybe+import qualified Data.ByteString.Char8 as C+++data PackageSpec =+    PackageSpec {+        directory  :: FilePath,+        configOpts :: [String]+    }++data Success = Failure | ConfigureSuccess | BuildSuccess | InstallSuccess | TestSuccess deriving (Eq, Show)++data Result = Result {+        successful :: Bool,+        success    :: Success,+        outputText :: String+    }+    deriving Show++nullResult :: Result+nullResult = Result True Failure ""++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 -> IO Result+cabal_configure spec = do+    res <- doCabalConfigure spec+    record spec res+    return res++doCabalConfigure :: PackageSpec -> IO Result+doCabalConfigure spec = do+    cleanResult@(_, _, cleanOutput) <- cabal spec ["clean"]+    requireSuccess cleanResult+    res <- cabal spec $ ["configure", "--user"] ++ configOpts spec+    return $ recordRun res ConfigureSuccess nullResult++doCabalBuild :: PackageSpec -> IO Result+doCabalBuild spec = do+    configResult <- doCabalConfigure spec+    if successful configResult+        then do+            res <- cabal spec ["build"]+            return $ recordRun res BuildSuccess configResult+        else+            return configResult++cabal_build :: PackageSpec -> IO Result+cabal_build spec = do+    res <- doCabalBuild spec+    record spec res+    return res++unregister :: String -> IO ()+unregister libraryName = do+    res@(_, _, output) <- run Nothing "ghc-pkg" ["unregister", "--user", libraryName]+    if "cannot find package" `isInfixOf` output+        then return ()+        else requireSuccess res++-- | Install this library in the user area+cabal_install :: PackageSpec -> IO Result+cabal_install spec = do+    buildResult <- doCabalBuild spec+    res <- if successful buildResult+        then do+            res <- cabal spec ["install"]+            return $ recordRun res InstallSuccess buildResult+        else+            return buildResult+    record spec res+    return res++cabal_test :: PackageSpec -> IO Result+cabal_test spec = do+    res <- cabal spec ["test"]+    let r = recordRun res TestSuccess nullResult+    record spec r+    return r++-- | Returns the command that was issued, the return code, and hte output text+cabal :: PackageSpec -> [String] -> IO (String, ExitCode, String)+cabal spec cabalArgs = do+    wd <- getCurrentDirectory+    r <- run (Just $ directory spec) "ghc"+             [ "--make"+             , "-fhpc"+             , "-package-conf " ++ wd </> "../dist/package.conf.inplace"+             , "Setup.hs"+             ]+    requireSuccess r+    run (Just $ directory spec) (wd </> directory spec </> "Setup") cabalArgs++-- | Returns the command that was issued, the return code, and hte output text+run :: Maybe FilePath -> String -> [String] -> IO (String, ExitCode, String)+run cwd cmd args = do+    -- Posix-specific+    (outf, outf0) <- createPipe+    (errf, errf0) <- createPipe+    outh <- fdToHandle outf+    outh0 <- fdToHandle outf0+    errh <- fdToHandle errf+    errh0 <- fdToHandle errf0+    pid <- runProcess cmd args cwd Nothing Nothing (Just outh0) (Just errh0)++    {-+    -- ghc-6.10.1 specific+    (Just inh, Just outh, Just errh, pid) <-+        createProcess (proc cmd args){ std_in  = CreatePipe,+                                       std_out = CreatePipe,+                                       std_err = CreatePipe,+                                       cwd     = cwd }+    hClose inh -- done with stdin+    -}++    -- fork off a thread to start consuming the output+    outChan <- newChan+    forkIO $ suckH outChan outh+    forkIO $ suckH outChan errh++    output <- suckChan outChan++    hClose outh+    hClose errh++    -- wait on the process+    ex <- waitForProcess pid+    let fullCmd = intercalate " " $ cmd:args+    return ("\"" ++ fullCmd ++ "\" in " ++ fromMaybe "" cwd,+        ex, output)+  where+    suckH chan h = do+        eof <- hIsEOF h+        if eof+            then writeChan chan Nothing+            else do+                c <- hGetChar h+                writeChan chan $ Just c+                suckH chan h+    suckChan chan = sc' chan 2 []+      where+        sc' _ 0 acc = return $ reverse acc+        sc' chan eofs acc = do+            mC <- readChan chan+            case mC of+                Just c -> sc' chan eofs (c:acc)+                Nothing -> sc' chan (eofs-1) acc++requireSuccess :: (String, ExitCode, String) -> IO ()+requireSuccess (cmd, exitCode, output) = do+    case exitCode of+        ExitSuccess -> return ()+        ExitFailure r -> do+            ioError $ userError $ "Command " ++ cmd ++ " failed."++record :: PackageSpec -> Result -> IO ()+record spec res = do+    C.writeFile (directory spec </> "test-log.txt") (C.pack $ outputText res)+
+ cabal/cabal/tests/PackageTests/TestStanza/Check.hs view
@@ -0,0 +1,57 @@+module PackageTests.TestStanza.Check where++import Test.HUnit+import System.FilePath+import PackageTests.PackageTester+import Data.List (isInfixOf, intercalate)+import Distribution.Version+import Distribution.PackageDescription.Parse+        ( readPackageDescription )+import Distribution.PackageDescription.Configuration+        ( finalizePackageDescription )+import Distribution.Package+        ( PackageIdentifier(..), PackageName(..), Dependency(..) )+import Distribution.PackageDescription+        ( PackageDescription(..), BuildInfo(..), TestSuite(..), Library(..)+        , TestSuiteInterface(..)+        , TestType(..), emptyPackageDescription, emptyBuildInfo, emptyLibrary+        , emptyTestSuite, BuildType(..) )+import Distribution.Verbosity (silent)+import Distribution.License (License(..))+import Distribution.ModuleName (fromString)+import Distribution.System (buildPlatform)+import Distribution.Compiler+        ( CompilerId(..), CompilerFlavor(..) )+import Distribution.Text++suite :: Version -> Test+suite cabalVersion = TestCase $ do+    let directory = "PackageTests" </> "TestStanza"+        pdFile = directory </> "my" <.> "cabal"+        spec = PackageSpec directory []+    result <- cabal_configure spec+    let message = "cabal configure should recognize test section"+        test = "unknown section type"+               `isInfixOf`+               (intercalate " " $ lines $ outputText result)+    assertEqual message False test+    genPD <- readPackageDescription silent pdFile+    let compiler = CompilerId GHC $ Version [6, 12, 2] []+        anyV = intersectVersionRanges anyVersion anyVersion+        anticipatedTestSuite = emptyTestSuite+            { testName = "dummy"+            , testInterface = TestSuiteExeV10 (Version [1,0] []) "dummy.hs"+            , testBuildInfo = emptyBuildInfo+                    { targetBuildDepends =+                            [ Dependency (PackageName "base") anyVersion ]+                    , 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/cabal/tests/PackageTests/TestStanza/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/TestStanza/my.cabal view
@@ -0,0 +1,19 @@+name: 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: base
+ cabal/cabal/tests/PackageTests/TestSuiteExeV10/Check.hs view
@@ -0,0 +1,47 @@+module PackageTests.TestSuiteExeV10.Check+       ( checkTest+       , checkTestWithHpc+       ) where++import Distribution.PackageDescription ( TestSuite(..), emptyTestSuite )+import Distribution.Simple.Hpc+import Distribution.Version+import Test.HUnit+import System.Directory+import System.FilePath+import PackageTests.PackageTester++dir :: FilePath+dir = "PackageTests" </> "TestSuiteExeV10"++checkTest :: Version -> Test+checkTest cabalVersion = TestCase $ do+    let spec = PackageSpec dir ["--enable-tests"]+    buildResult <- cabal_build spec+    let buildMessage = "\'setup build\' should succeed"+    assertEqual buildMessage True $ successful buildResult+    testResult <- cabal_test spec+    let testMessage = "\'setup test\' should succeed"+    assertEqual testMessage True $ successful testResult++checkTestWithHpc :: Version -> Test+checkTestWithHpc cabalVersion = TestCase $ do+    let spec = PackageSpec dir [ "--enable-tests"+                               , "--enable-library-coverage"+                               ]+    buildResult <- cabal_build spec+    let buildMessage = "\'setup build\' should succeed"+    assertEqual buildMessage True $ successful buildResult+    testResult <- cabal_test spec+    let testMessage = "\'setup test\' should succeed"+    assertEqual testMessage True $ successful testResult+    let dummy = emptyTestSuite { testName = "test-Foo" }+        tixFile = tixFilePath (dir </> "dist") dummy+        tixFileMessage = ".tix file should exist"+        markupDir = tixDir (dir </> "dist") dummy+        markupFile = markupDir </> "hpc_index" <.> "html"+        markupFileMessage = "HPC markup file should exist"+    tixFileExists <- doesFileExist tixFile+    assertEqual tixFileMessage True tixFileExists+    markupFileExists <- doesFileExist markupFile+    assertEqual markupFileMessage True markupFileExists
+ cabal/cabal/tests/PackageTests/TestSuiteExeV10/Foo.hs view
@@ -0,0 +1,4 @@+module Foo where++fooTest :: [String] -> Bool+fooTest _ = True
+ cabal/cabal/tests/PackageTests/TestSuiteExeV10/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/PackageTests/TestSuiteExeV10/my.cabal view
@@ -0,0 +1,15 @@+name:           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/cabal/tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs view
@@ -0,0 +1,8 @@+module Main where++import Foo+import System.Exit++main :: IO ()+main | fooTest [] = exitSuccess+     | otherwise = exitFailure
+ cabal/cabal/tests/README view
@@ -0,0 +1,14 @@+Building and running the test suite+===================================++You can build and run the test suite by running:++    cabal configure && cabal build+    cd tests+    cabal configure --package-db=../dist/package.conf.inplace \+        --constraint='Cabal == 1.9.1'+    cabal build+    ./dist/build/suite/suite++Replace the Cabal constraint with whatever the current development+version of Cabal.
+ cabal/cabal/tests/Setup.hs view
@@ -0,0 +1,3 @@+import Distribution.Simple+main = defaultMain+
+ cabal/cabal/tests/Test/Distribution/Version.hs view
@@ -0,0 +1,644 @@+{-# OPTIONS_GHC -fno-warn-orphans -fno-warn-incomplete-patterns #-}+module Test.Distribution.Version (properties) where++import Distribution.Version+import Distribution.Text++import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<>), (<+>))++import Test.QuickCheck+import Test.QuickCheck.Utils+import qualified Test.Laws as Laws++import Control.Monad (liftM, liftM2)+import Data.Maybe (isJust, fromJust)+import Data.List (sort, sortBy, nub)+import Data.Ord  (comparing)++properties :: [Property]+properties =+    -- properties to validate the test framework+  [ property prop_nonNull+  , property prop_gen_intervals1+  , property prop_gen_intervals2+  , property prop_equivalentVersionRange+  , property prop_intermediateVersion++    -- the basic syntactic version range functions+  , property prop_anyVersion+  , property prop_noVersion+  , property prop_thisVersion+  , property prop_notThisVersion+  , property prop_laterVersion+  , property prop_orLaterVersion+  , property prop_earlierVersion+  , property prop_orEarlierVersion+  , property prop_unionVersionRanges+  , property prop_intersectVersionRanges+  , property prop_withinVersion+  , property prop_foldVersionRange+  , property prop_foldVersionRange'++    -- the semantic query functions+  , property prop_isAnyVersion1+  , property prop_isAnyVersion2+  , property prop_isNoVersion+  , property prop_isSpecificVersion1+  , property prop_isSpecificVersion2+  , property prop_simplifyVersionRange1+  , property prop_simplifyVersionRange1'+  , property prop_simplifyVersionRange2+  , property prop_simplifyVersionRange2'+  , property prop_simplifyVersionRange2'' --FIXME++    -- converting between version ranges and version intervals+  , property prop_to_intervals+  , property prop_to_intervals_canonical+  , property prop_to_intervals_canonical'+  , property prop_from_intervals+  , property prop_to_from_intervals+  , property prop_from_to_intervals+  , property prop_from_to_intervals'++    -- union and intersection of version intervals+  , property prop_unionVersionIntervals+  , property prop_unionVersionIntervals_idempotent+  , property prop_unionVersionIntervals_commutative+  , property prop_unionVersionIntervals_associative+  , property prop_intersectVersionIntervals+  , property prop_intersectVersionIntervals_idempotent+  , property prop_intersectVersionIntervals_commutative+  , property prop_intersectVersionIntervals_associative+  , property prop_union_intersect_distributive+  , property prop_intersect_union_distributive++   -- parsing an pretty printing+  , property prop_parse_disp1+  , property prop_parse_disp2+  , property prop_parse_disp3+  ]++instance Arbitrary Version where+  arbitrary = do+    branch <- smallListOf1 $+                frequency [(3, return 0)+                          ,(3, return 1)+                          ,(2, return 2)+                          ,(1, return 3)]+    return (Version branch []) -- deliberate []+    where+      smallListOf1 = adjustSize (\n -> min 5 (n `div` 3)) . listOf1++  shrink (Version branch []) =+    [ Version branch' [] | branch' <- shrink branch, not (null branch') ]+  shrink (Version branch _tags) =+    [ Version branch [] ]++instance Arbitrary VersionRange where+  arbitrary = sized verRangeExp+    where+      verRangeExp n = frequency $+        [ (2, return anyVersion)+        , (1, liftM thisVersion arbitrary)+        , (1, liftM laterVersion arbitrary)+        , (1, liftM orLaterVersion arbitrary)+        , (1, liftM orLaterVersion' arbitrary)+        , (1, liftM earlierVersion arbitrary)+        , (1, liftM orEarlierVersion arbitrary)+        , (1, liftM orEarlierVersion' arbitrary)+        , (1, liftM withinVersion arbitrary)+        , (2, liftM VersionRangeParens arbitrary)+        ] ++ if n == 0 then [] else+        [ (2, liftM2 unionVersionRanges     verRangeExp2 verRangeExp2)+        , (2, liftM2 intersectVersionRanges verRangeExp2 verRangeExp2)+        ]+        where+          verRangeExp2 = verRangeExp (n `div` 2)++      orLaterVersion'   v =+        UnionVersionRanges (LaterVersion v)   (ThisVersion v)+      orEarlierVersion' v =+        UnionVersionRanges (EarlierVersion v) (ThisVersion v)++---------------------------+-- VersionRange properties+--++prop_nonNull :: Version -> Bool+prop_nonNull = not . null . versionBranch++prop_anyVersion :: Version -> Bool+prop_anyVersion v' =+  withinRange v' anyVersion == True++prop_noVersion :: Version -> Bool+prop_noVersion v' =+  withinRange v' noVersion == False++prop_thisVersion :: Version -> Version -> Bool+prop_thisVersion v v' =+     withinRange v' (thisVersion v)+  == (v' == v)++prop_notThisVersion :: Version -> Version -> Bool+prop_notThisVersion v v' =+     withinRange v' (notThisVersion v)+  == (v' /= v)++prop_laterVersion :: Version -> Version -> Bool+prop_laterVersion v v' =+     withinRange v' (laterVersion v)+  == (v' > v)++prop_orLaterVersion :: Version -> Version -> Bool+prop_orLaterVersion v v' =+     withinRange v' (orLaterVersion v)+  == (v' >= v)++prop_earlierVersion :: Version -> Version -> Bool+prop_earlierVersion v v' =+     withinRange v' (earlierVersion v)+  == (v' < v)++prop_orEarlierVersion :: Version -> Version -> Bool+prop_orEarlierVersion v v' =+     withinRange v' (orEarlierVersion v)+  == (v' <= v)++prop_unionVersionRanges :: VersionRange -> VersionRange -> Version -> Bool+prop_unionVersionRanges vr1 vr2 v' =+     withinRange v' (unionVersionRanges vr1 vr2)+  == (withinRange v' vr1 || withinRange v' vr2)++prop_intersectVersionRanges :: VersionRange -> VersionRange -> Version -> Bool+prop_intersectVersionRanges vr1 vr2 v' =+     withinRange v' (intersectVersionRanges vr1 vr2)+  == (withinRange v' vr1 && withinRange v' vr2)++prop_withinVersion :: Version -> Version -> Bool+prop_withinVersion v v' =+     withinRange v' (withinVersion v)+  == (v' >= v && v' < upper v)+  where+    upper (Version lower t) = Version (init lower ++ [last lower + 1]) t++prop_foldVersionRange :: VersionRange -> Bool+prop_foldVersionRange range =+     expandWildcard range+  == foldVersionRange anyVersion thisVersion+                      laterVersion earlierVersion+                      unionVersionRanges intersectVersionRanges+                      range+  where+    expandWildcard (WildcardVersion v) =+        intersectVersionRanges (orLaterVersion v) (earlierVersion (upper v))+      where+        upper (Version lower t) = Version (init lower ++ [last lower + 1]) t++    expandWildcard (UnionVersionRanges     v1 v2) =+      UnionVersionRanges (expandWildcard v1) (expandWildcard v2)+    expandWildcard (IntersectVersionRanges v1 v2) =+      IntersectVersionRanges (expandWildcard v1) (expandWildcard v2)+    expandWildcard (VersionRangeParens v) = expandWildcard v+    expandWildcard v = v+++prop_foldVersionRange' :: VersionRange -> Bool+prop_foldVersionRange' range =+     canonicalise range+  == foldVersionRange' anyVersion thisVersion+                       laterVersion earlierVersion+                       orLaterVersion orEarlierVersion+                       (\v _ -> withinVersion v)+                       unionVersionRanges intersectVersionRanges id+                       range+  where+    canonicalise (UnionVersionRanges (LaterVersion v)+                                     (ThisVersion  v')) | v == v'+                = UnionVersionRanges (ThisVersion   v')+                                     (LaterVersion  v)+    canonicalise (UnionVersionRanges (EarlierVersion v)+                                     (ThisVersion    v')) | v == v'+                = UnionVersionRanges (ThisVersion    v')+                                     (EarlierVersion v)+    canonicalise (UnionVersionRanges v1 v2) =+      UnionVersionRanges (canonicalise v1) (canonicalise v2)+    canonicalise (IntersectVersionRanges v1 v2) =+      IntersectVersionRanges (canonicalise v1) (canonicalise v2)+    canonicalise (VersionRangeParens v) = canonicalise v+    canonicalise v = v+++prop_isAnyVersion1 :: VersionRange -> Version -> Property+prop_isAnyVersion1 range version =+  isAnyVersion range ==> withinRange version range++prop_isAnyVersion2 :: VersionRange -> Property+prop_isAnyVersion2 range =+  isAnyVersion range ==>+    foldVersionRange True (\_ -> False) (\_ -> False) (\_ -> False)+                          (\_ _ -> False) (\_ _ -> False)+      (simplifyVersionRange range)++prop_isNoVersion :: VersionRange -> Version -> Property+prop_isNoVersion range version =+  isNoVersion range ==> not (withinRange version range)++prop_isSpecificVersion1 :: VersionRange -> NonEmptyList Version -> Property+prop_isSpecificVersion1 range (NonEmpty versions) =+  isJust version && not (null versions') ==>+    allEqual (fromJust version : versions')+  where+    version     = isSpecificVersion range+    versions'   = filter (`withinRange` range) versions+    allEqual xs = and (zipWith (==) xs (tail xs))++prop_isSpecificVersion2 :: VersionRange -> Property+prop_isSpecificVersion2 range =+  isJust version ==>+    foldVersionRange Nothing Just (\_ -> Nothing) (\_ -> Nothing)+                     (\_ _ -> Nothing) (\_ _ -> Nothing)+      (simplifyVersionRange range)+    == version++  where+    version = isSpecificVersion range++-- | 'simplifyVersionRange' is a semantic identity on 'VersionRange'.+--+prop_simplifyVersionRange1 :: VersionRange -> Version -> Bool+prop_simplifyVersionRange1 range version =+  withinRange version range == withinRange version (simplifyVersionRange range)++prop_simplifyVersionRange1' :: VersionRange -> Bool+prop_simplifyVersionRange1' range =+  range `equivalentVersionRange` (simplifyVersionRange range)++-- | 'simplifyVersionRange' produces a canonical form for ranges with+-- equivalent semantics.+--+prop_simplifyVersionRange2 :: VersionRange -> VersionRange -> Version -> Property+prop_simplifyVersionRange2 r r' v =+  r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>+    withinRange v r == withinRange v r'++prop_simplifyVersionRange2' :: VersionRange -> VersionRange -> Property+prop_simplifyVersionRange2' r r' =+  r /= r' && simplifyVersionRange r == simplifyVersionRange r' ==>+    r `equivalentVersionRange` r'++--FIXME: see equivalentVersionRange for details+prop_simplifyVersionRange2'' :: VersionRange -> VersionRange -> Property+prop_simplifyVersionRange2'' r r' =+  r /= r' && r `equivalentVersionRange` r' ==>+       simplifyVersionRange r == simplifyVersionRange r'+    || isNoVersion r+    || isNoVersion r'++--------------------+-- VersionIntervals+--++-- | Generating VersionIntervals+--+-- This is a tad tricky as VersionIntervals is an abstract type, so we first+-- make a local type for generating the internal representation. Then we check+-- that this lets us construct valid 'VersionIntervals'.+--+newtype VersionIntervals' = VersionIntervals' [VersionInterval]+  deriving (Eq, Show)++instance Arbitrary VersionIntervals' where+  arbitrary = do+    ubound <- arbitrary+    bounds <- arbitrary+    let intervals = mergeTouching+                  . map fixEmpty+                  . replaceUpper ubound+                  . pairs+                  . sortBy (comparing fst)+                  $ bounds+    return (VersionIntervals' intervals)++    where+      pairs ((l, lb):(u, ub):bs) = (LowerBound l lb, UpperBound u ub)+                                 : pairs bs+      pairs _                    = []++      replaceUpper NoUpperBound [(l,_)] = [(l, NoUpperBound)]+      replaceUpper NoUpperBound (i:is)  = i : replaceUpper NoUpperBound is+      replaceUpper _               is   = is++      -- merge adjacent intervals that touch+      mergeTouching (i1@(l,u):i2@(l',u'):is)+        | doesNotTouch u l' = i1 : mergeTouching (i2:is)+        | otherwise         =      mergeTouching ((l,u'):is)+      mergeTouching is      = is++      doesNotTouch :: UpperBound -> LowerBound -> Bool+      doesNotTouch NoUpperBound _ = False+      doesNotTouch (UpperBound u ub) (LowerBound l lb) =+            u <  l+        || (u == l && ub == ExclusiveBound && lb == ExclusiveBound)++      fixEmpty (LowerBound l _, UpperBound u _)+        | l == u = (LowerBound l InclusiveBound, UpperBound u InclusiveBound)+      fixEmpty i = i++  shrink (VersionIntervals' intervals) =+    [ VersionIntervals' intervals' | intervals' <- shrink intervals ]++instance Arbitrary Bound where+  arbitrary = elements [ExclusiveBound, InclusiveBound]++instance Arbitrary LowerBound where+  arbitrary = liftM2 LowerBound arbitrary arbitrary++instance Arbitrary UpperBound where+  arbitrary = oneof [return NoUpperBound+                    ,liftM2 UpperBound arbitrary arbitrary]++-- | Check that our VersionIntervals' arbitrary instance generates intervals+-- that satisfies the invariant.+--+prop_gen_intervals1 :: VersionIntervals' -> Bool+prop_gen_intervals1 (VersionIntervals' intervals) =+  isJust (mkVersionIntervals intervals)++instance Arbitrary VersionIntervals where+  arbitrary = do+    VersionIntervals' intervals <- arbitrary+    case mkVersionIntervals intervals of+      Just xs -> return xs++-- | Check that constructing our intervals type and converting it to a+-- 'VersionRange' and then into the true intervals type gives us back+-- the exact same sequence of intervals. This tells us that our arbitrary+-- instance for 'VersionIntervals'' is ok.+--+prop_gen_intervals2 :: VersionIntervals' -> Bool+prop_gen_intervals2 (VersionIntervals' intervals') =+    asVersionIntervals (fromVersionIntervals intervals) == intervals'+  where+    Just intervals = mkVersionIntervals intervals'++-- | Check that 'VersionIntervals' models 'VersionRange' via+-- 'toVersionIntervals'.+--+prop_to_intervals :: VersionRange -> Version -> Bool+prop_to_intervals range version =+  withinRange version range == withinIntervals version intervals+  where+    intervals = toVersionIntervals range++-- | Check that semantic equality on 'VersionRange's is the same as converting+-- to 'VersionIntervals' and doing syntactic equality.+--+prop_to_intervals_canonical :: VersionRange -> VersionRange -> Property+prop_to_intervals_canonical r r' =+  r /= r' && r `equivalentVersionRange` r' ==>+    toVersionIntervals r == toVersionIntervals r'++prop_to_intervals_canonical' :: VersionRange -> VersionRange -> Property+prop_to_intervals_canonical' r r' =+  r /= r' && toVersionIntervals r == toVersionIntervals r' ==>+    r `equivalentVersionRange` r'++-- | Check that 'VersionIntervals' models 'VersionRange' via+-- 'fromVersionIntervals'.+--+prop_from_intervals :: VersionIntervals -> Version -> Bool+prop_from_intervals intervals version =+  withinRange version range == withinIntervals version intervals+  where+    range = fromVersionIntervals intervals++-- | @'toVersionIntervals' . 'fromVersionIntervals'@ is an exact identity on+-- 'VersionIntervals'.+--+prop_to_from_intervals :: VersionIntervals -> Bool+prop_to_from_intervals intervals =+  toVersionIntervals (fromVersionIntervals intervals) == intervals++-- | @'fromVersionIntervals' . 'toVersionIntervals'@ is a semantic identity on+-- 'VersionRange', though not necessarily a syntactic identity.+--+prop_from_to_intervals :: VersionRange -> Bool+prop_from_to_intervals range =+  range' `equivalentVersionRange` range+  where+    range' = fromVersionIntervals (toVersionIntervals range)++-- | Equivalent of 'prop_from_to_intervals'+--+prop_from_to_intervals' :: VersionRange -> Version -> Bool+prop_from_to_intervals' range version =+  withinRange version range' == withinRange version range+  where+    range' = fromVersionIntervals (toVersionIntervals range)++-- | The semantics of 'unionVersionIntervals' is (||).+--+prop_unionVersionIntervals :: VersionIntervals -> VersionIntervals+                           -> Version -> Bool+prop_unionVersionIntervals is1 is2 v =+     withinIntervals v (unionVersionIntervals is1 is2)+  == (withinIntervals v is1 || withinIntervals v is2)++-- | 'unionVersionIntervals' is idempotent+--+prop_unionVersionIntervals_idempotent :: VersionIntervals -> Bool+prop_unionVersionIntervals_idempotent =+  Laws.idempotent_binary unionVersionIntervals++-- | 'unionVersionIntervals' is commutative+--+prop_unionVersionIntervals_commutative :: VersionIntervals+                                       -> VersionIntervals -> Bool+prop_unionVersionIntervals_commutative =+  Laws.commutative unionVersionIntervals++-- | 'unionVersionIntervals' is associative+--+prop_unionVersionIntervals_associative :: VersionIntervals+                                       -> VersionIntervals+                                       -> VersionIntervals -> Bool+prop_unionVersionIntervals_associative =+  Laws.associative unionVersionIntervals++-- | The semantics of 'intersectVersionIntervals' is (&&).+--+prop_intersectVersionIntervals :: VersionIntervals -> VersionIntervals+                               -> Version -> Bool+prop_intersectVersionIntervals is1 is2 v =+     withinIntervals v (intersectVersionIntervals is1 is2)+  == (withinIntervals v is1 && withinIntervals v is2)++-- | 'intersectVersionIntervals' is idempotent+--+prop_intersectVersionIntervals_idempotent :: VersionIntervals -> Bool+prop_intersectVersionIntervals_idempotent =+  Laws.idempotent_binary intersectVersionIntervals++-- | 'intersectVersionIntervals' is commutative+--+prop_intersectVersionIntervals_commutative :: VersionIntervals+                                           -> VersionIntervals -> Bool+prop_intersectVersionIntervals_commutative =+  Laws.commutative intersectVersionIntervals++-- | 'intersectVersionIntervals' is associative+--+prop_intersectVersionIntervals_associative :: VersionIntervals+                                           -> VersionIntervals+                                           -> VersionIntervals -> Bool+prop_intersectVersionIntervals_associative =+  Laws.associative intersectVersionIntervals++-- | 'unionVersionIntervals' distributes over 'intersectVersionIntervals'+--+prop_union_intersect_distributive :: Property+prop_union_intersect_distributive =+      Laws.distributive_left  unionVersionIntervals intersectVersionIntervals+  .&. Laws.distributive_right unionVersionIntervals intersectVersionIntervals++-- | 'intersectVersionIntervals' distributes over 'unionVersionIntervals'+--+prop_intersect_union_distributive :: Property+prop_intersect_union_distributive =+      Laws.distributive_left  intersectVersionIntervals unionVersionIntervals+  .&. Laws.distributive_right intersectVersionIntervals unionVersionIntervals++--------------------------------+-- equivalentVersionRange helper++prop_equivalentVersionRange :: VersionRange  -> VersionRange+                            -> Version -> Property+prop_equivalentVersionRange range range' version =+  equivalentVersionRange range range' && range /= range' ==>+    withinRange version range == withinRange version range'++--FIXME: this is wrong. consider version ranges "<=1" and "<1.0"+--       this algorithm cannot distinguish them because there is no version+--       that is included by one that is excluded by the other.+--       Alternatively we must reconsider the semantics of '<' and '<='+--       in version ranges / version intervals. Perhaps the canonical+--       representation should use just < v and interpret "<= v" as "< v.0".+equivalentVersionRange :: VersionRange -> VersionRange -> Bool+equivalentVersionRange vr1 vr2 =+  let allVersionsUsed = nub (sort (versionsUsed vr1 ++ versionsUsed vr2))+      minPoint = Version [0] []+      maxPoint | null allVersionsUsed = minPoint+               | otherwise = case maximum allVersionsUsed of+                   Version vs _ -> Version (vs ++ [1]) []+      probeVersions = minPoint : maxPoint+                    : intermediateVersions allVersionsUsed++  in all (\v -> withinRange v vr1 == withinRange v vr2) probeVersions++  where+    versionsUsed = foldVersionRange [] (\x->[x]) (\x->[x]) (\x->[x]) (++) (++)+    intermediateVersions (v1:v2:vs) = v1 : intermediateVersion v1 v2+                                         : intermediateVersions (v2:vs)+    intermediateVersions vs = vs++intermediateVersion :: Version -> Version -> Version+intermediateVersion v1 v2 | v1 >= v2 = error "intermediateVersion: v1 >= v2"+intermediateVersion (Version v1 _) (Version v2 _) =+  Version (intermediateList v1 v2) []+  where+    intermediateList :: [Int] -> [Int] -> [Int]+    intermediateList []     (_:_) = [0]+    intermediateList (x:xs) (y:ys)+        | x <  y    = x : xs ++ [0]+        | otherwise = x : intermediateList xs ys++prop_intermediateVersion :: Version -> Version -> Property+prop_intermediateVersion v1 v2 =+  (v1 /= v2) && not (adjacentVersions v1 v2) ==>+  if v1 < v2+    then let v = intermediateVersion v1 v2+          in (v1 < v && v < v2)+    else let v = intermediateVersion v2 v1+          in v1 > v && v > v2++adjacentVersions :: Version -> Version -> Bool+adjacentVersions (Version v1 _) (Version v2 _) = v1 ++ [0] == v2+                                              || v2 ++ [0] == v1++--------------------------------+-- Parsing and pretty printing+--++prop_parse_disp1 :: VersionRange -> Bool+prop_parse_disp1 vr =+  fmap stripParens (simpleParse (display vr)) == Just (canonicalise vr)++  where+    canonicalise = swizzle . swap++    swizzle     (UnionVersionRanges (UnionVersionRanges v1 v2) v3)+      | not (isOrLaterVersion v1 v2) && not (isOrEarlierVersion v1 v2)+      = swizzle (UnionVersionRanges v1 (UnionVersionRanges v2  v3))++    swizzle     (IntersectVersionRanges (IntersectVersionRanges v1 v2) v3)+      = swizzle (IntersectVersionRanges v1 (IntersectVersionRanges v2  v3))++    swizzle (UnionVersionRanges v1 v2) =+      UnionVersionRanges (swizzle v1) (swizzle v2)+    swizzle (IntersectVersionRanges v1 v2) =+      IntersectVersionRanges (swizzle v1) (swizzle v2)+    swizzle (VersionRangeParens v) = swizzle v+    swizzle v = v++    isOrLaterVersion (ThisVersion  v) (LaterVersion v') = v == v'+    isOrLaterVersion _                _                 = False++    isOrEarlierVersion (ThisVersion v)    (EarlierVersion v') = v == v'+    isOrEarlierVersion _                  _                   = False++    swap =+      foldVersionRange' anyVersion thisVersion+                        laterVersion earlierVersion+                        orLaterVersion orEarlierVersion+                        (\v _ -> withinVersion v)+                        unionVersionRanges intersectVersionRanges id++    stripParens :: VersionRange -> VersionRange+    stripParens (VersionRangeParens v) = stripParens v+    stripParens (UnionVersionRanges v1 v2) =+      UnionVersionRanges (stripParens v1) (stripParens v2)+    stripParens (IntersectVersionRanges v1 v2) =+      IntersectVersionRanges (stripParens v1) (stripParens v2)+    stripParens v = v++prop_parse_disp2 :: VersionRange -> Bool+prop_parse_disp2 vr =+     fmap (display :: VersionRange -> String) (simpleParse (display vr))+  == Just (display vr)++prop_parse_disp3 :: VersionRange -> Bool+prop_parse_disp3 vr =+  fmap displayRaw (simpleParse (display vr)) == Just (display vr)++displayRaw :: VersionRange -> String+displayRaw =+   Disp.render+ . foldVersionRange'                         -- precedence:+     -- All the same as the usual pretty printer, except for the parens+     (          Disp.text "-any")+     (\v     -> Disp.text "==" <> disp v)+     (\v     -> Disp.char '>'  <> disp v)+     (\v     -> Disp.char '<'  <> disp v)+     (\v     -> Disp.text ">=" <> disp v)+     (\v     -> Disp.text "<=" <> disp v)+     (\v _   -> Disp.text "==" <> dispWild v)+     (\r1 r2 -> r1 <+> Disp.text "||" <+> r2)+     (\r1 r2 -> r1 <+> Disp.text "&&" <+> r2)+     (\r     -> Disp.parens r) -- parens++  where+    dispWild (Version b _) =+           Disp.hcat (Disp.punctuate (Disp.char '.') (map Disp.int b))+        <> Disp.text ".*"
+ cabal/cabal/tests/Test/Laws.hs view
@@ -0,0 +1,79 @@+{-# OPTIONS_GHC -fno-warn-missing-signatures #-}+module Test.Laws where++import Prelude hiding (Num((+), (*)))+import Data.Monoid (Monoid(..), Endo(..))+import qualified Data.Foldable as Foldable++idempotent_unary  f x = f fx == fx where fx = f x++-- Basic laws on binary operators++idempotent_binary (+) x = x + x == x++commutative (+) x y = x + y == y + x++associative (+) x y z = (x + y) + z ==  x + (y + z)++distributive_left  (*) (+) x y z = x * (y + z) == (x * y) + (x * z)++distributive_right (*) (+) x y z = (y + z) * x == (y * x) + (z * x)+++-- | The first 'fmap' law+--+-- > fmap id  ==  id+--+fmap_1 :: (Eq (f a), Functor f) => f a -> Bool+fmap_1 x = fmap id x == x++-- | The second 'fmap' law+--+-- > fmap (f . g)  ==  fmap f . fmap g+--+fmap_2 :: (Eq (f c), Functor f) => (b -> c) -> (a -> b) -> f a -> Bool+fmap_2 f g x = fmap (f . g) x == (fmap f . fmap g) x+++-- | The monoid identity law, 'mempty' is a left and right identity of+-- 'mappend':+--+-- > mempty `mappend` x = x+-- > x `mappend` mempty = x+--+monoid_1 :: (Eq a, Data.Monoid.Monoid a) => a -> Bool+monoid_1 x = mempty `mappend` x == x+          && x `mappend` mempty == x++-- | The monoid associativity law, 'mappend' must be associative.+--+-- > (x `mappend` y) `mappend` z = x `mappend` (y `mappend` z)+--+monoid_2 :: (Eq a, Data.Monoid.Monoid a) => a -> a -> a -> Bool+monoid_2 x y z = (x `mappend`  y) `mappend` z+              ==  x `mappend` (y  `mappend` z)++-- | The 'mconcat' definition. It can be overidden for the sake of effeciency+-- but it must still satisfy the property given by the default definition:+--+-- > mconcat = foldr mappend mempty+--+monoid_3 :: (Eq a, Data.Monoid.Monoid a) => [a] -> Bool+monoid_3 xs = mconcat xs == foldr mappend mempty xs+++-- | First 'Foldable' law+--+-- > Foldable.fold = Foldable.foldr mappend mempty+--+foldable_1 :: (Foldable.Foldable t, Monoid m, Eq m) => t m -> Bool+foldable_1 x = Foldable.fold x == Foldable.foldr mappend mempty x++-- | Second 'Foldable' law+--+-- > foldr f z t = appEndo (foldMap (Endo . f) t) z+--+foldable_2 :: (Foldable.Foldable t, Eq b)+               => (a -> b -> b) -> b -> t a -> Bool+foldable_2 f z t = Foldable.foldr f z t+                    == appEndo (Foldable.foldMap (Endo . f) t) z
+ cabal/cabal/tests/Test/QuickCheck/Utils.hs view
@@ -0,0 +1,29 @@+module Test.QuickCheck.Utils where++import Test.QuickCheck.Gen+++-- | Adjust the size of the generated value.+--+-- In general the size gets bigger and bigger linearly. For some types+-- it is not appropriate to generate ever bigger values but instead+-- to generate lots of intermediate sized values. You could do that using:+--+-- > adjustSize (\n -> min n 5)+--+-- Similarly, for some types the linear size growth may mean getting too big+-- too quickly relative to other values. So you may want to adjust how+-- quickly the size grows. For example dividing by a constant, or even+-- something like the integer square root or log.+--+-- > adjustSize (\n -> n `div` 2)+--+-- Putting this together we can make for example a relatively short list:+--+-- > adjustSize (\n -> min 5 (n `div` 3)) (listOf1 arbitrary)+--+-- Not only do we put a limit on the length but we also scale the growth to+-- prevent it from hitting the maximum size quite so early.+--+adjustSize :: (Int -> Int) -> Gen a -> Gen a+adjustSize adjust gen = sized (\n -> resize (adjust n) gen)
+ cabal/cabal/tests/UnitTest.hs view
@@ -0,0 +1,474 @@+-----------------------------------------------------------------------------++-- |+-- Module      :  UnitTest+-- Copyright   :  Isaac Jones 2003-2004+--+-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>+-- Stability   :  alpha+-- Portability :  GHC+--+-- Explanation: Test this module and sub modules.++{- 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. -}++module Main where+-- Import everything, since we want to test the compilation of them:++import qualified UnitTest.Distribution.Version as D.V (hunitTests)+import qualified UnitTest.Distribution.PackageDescription as D.PD (hunitTests)++import Distribution.Simple.Compiler (CompilerFlavor(..), compilerVersion)+import Distribution.Simple.Program (defaultProgramConfiguration)+import Distribution.Version (Version(..))++import System.FilePath( (</>) )++import Distribution.Simple.Configure (configCompiler)+import Distribution.Verbosity ( silent )+-- base+import Data.List (intersperse)+import Control.Monad (when)+import System.Directory (setCurrentDirectory, doesFileExist,+                         doesDirectoryExist, getCurrentDirectory,+                         getPermissions, Permissions(..),+                         removeDirectoryRecursive)+import System.Cmd (system)+import System.Exit(ExitCode(..))+import System.Environment (getArgs)++import Test.HUnit(runTestTT, Test(..), Counts(..), assertBool,+             assertEqual, Assertion, showCounts)+++-- ------------------------------------------------------------+-- * Helpers+-- ------------------------------------------------------------++combineCounts :: Counts -> Counts -> Counts+combineCounts (Counts a b c d) (Counts a' b' c' d')+    = Counts (a + a') (b + b') (c + c') (d + d')++label :: String -> String+label t = "-= " ++ t ++ " =-"++runTestTT' :: Test -> IO Counts+runTestTT' t@(TestList _) = runTestTT t+runTestTT'  (TestLabel l t)+    = putStrLn (label l) >> runTestTT t+runTestTT' t = runTestTT t++checkTargetDir :: FilePath+               -> [String] -- ^suffixes+               -> IO ()+checkTargetDir targetDir suffixes+    = do doesDirectoryExist targetDir >>=+           assertBool "target dir exists"+         let mods = ["A", "B/A"]+         allFilesE <- mapM anyExists [[(targetDir ++ t ++ y)+                                           | y <- suffixes]+                                            | t <- mods]++         sequence [assertBool ("target file missing: " ++ targetDir ++ f) e+                   | (e, f) <- zip allFilesE mods]+         return ()++  where anyExists :: [FilePath] -> IO Bool+        anyExists l = do l' <- mapM doesFileExist l+                         return $ any (== True) l'++-- |Run this command, and assert it returns a successful error code.+assertCmd :: String -- ^Command+          -> String -- ^Comment+          -> Assertion+assertCmd command comment+    = system command >>= assertEqual (command ++ ":" ++ comment) ExitSuccess++-- |like assertCmd, but separates command and args+assertCmd' :: String -- ^Command+           -> String -- ^args+           -> String -- ^Comment+           -> Assertion+assertCmd' command args comment+    = system (command ++ " "++ args ++ ">>out.build")+        >>= assertEqual (command ++ ":" ++ comment) ExitSuccess++-- |Run this command, and assert it returns an unsuccessful error code.+assertCmdFail :: String -- ^Command+              -> String -- ^Comment+              -> Assertion+assertCmdFail command comment+    = do code <- system command+         assertBool (command ++ ":" ++ comment) (code /= ExitSuccess)+++-- ------------------------------------------------------------+-- * Integration Tests+-- ------------------------------------------------------------++tests :: FilePath       -- ^Currdir+      -> CompilerFlavor -- ^build setup with compiler+      -> CompilerFlavor -- ^configure with which compiler+      -> Version        -- ^version of the compiler to use+      -> [Test]+tests currDir comp compConf compVersion = [+-- executableWithC+         TestLabel ("package exeWithC: " ++ compIdent) $ TestCase $+         do let targetDir = ",tmp"+            setCurrentDirectory (testdir </> "exeWithC")+            testPrelude+            assertConfigure targetDir+            assertClean+            assertConfigure targetDir+            assertBuild+            assertCopy+            assertCmd (targetDir </> "bin/tt" ++ " > "+                    ++ targetDir </> "out")+                      "exeWithC failed"+-- A+        ,TestLabel ("package A: " ++ compIdent) $ TestCase $+         do let targetDir = ",tmp"+            setCurrentDirectory (testdir </> "A")+            testPrelude+            assertConfigure targetDir+            assertHaddock+            assertBuild+            when (comp == GHC) -- are these tests silly?+              (do doesDirectoryExist "dist/build" >>=+                    assertBool "dist/build doesn't exist"+                  doesFileExist "dist/build/testA/testA" >>=+                    assertBool "build did not create the executable: testA"+                  doesFileExist "dist/build/testB/testB" >>=+                    assertBool "build did not create the executable: testB"+                  doesFileExist "dist/build/testA/testA-tmp/c_src/hello.o" >>=+                    assertBool "build did not build c source for testA"+                  doesFileExist "dist/build/hello.o" >>=+                    assertBool "build did not build c source for A library"+              )+            assertCopy+            libForA targetDir+            doesFileExist ",tmp/bin/testA" >>=+              assertBool "testA not produced"+            doesFileExist ",tmp/bin/testB" >>=+              assertBool "testB not produced"+            assertCmd' compCmd "sdist -v0" "setup sdist returned error code"+            doesFileExist "dist/test-1.0.tar.gz" >>=+              assertBool "sdist did not put the expected file in place"+            doesFileExist "dist/src" >>=+              assertEqual "dist/src exists" False+            assertCmd' compCmd "register -v0 --user" "pkg A, register failed"+            assertCmd' compCmd "unregister -v0 --user" "pkg A, unregister failed"+            -- tricky, script-based register+            registerAndExecute "pkg A: register with script failed"+            unregisterAndExecute "pkg A: unregister with script failed"+            -- non-trick non-script based register+            assertCmd' compCmd "register -v0 --user" "regular register returned error"+            assertCmd' compCmd "unregister -v0 --user" "regular unregister returned error"++        ,TestLabel ("package A copy-prefix: " ++ compIdent) $ TestCase $ -- (uses above config)+         do let targetDir = ",tmp2"+            assertCmd' compCmd ("copy --copy-prefix=" ++ targetDir) "copy --copy-prefix failed"+            doesFileExist ",tmp2/bin/testA" >>=+              assertBool "testA not produced"+            doesFileExist ",tmp2/bin/testB" >>=+              assertBool "testB not produced"+            libForA ",tmp2"+        ,TestLabel ("package A and install w/ no prefix: " ++ compIdent) $ TestCase $+         do let targetDir = ",tmp"+            removeDirectoryRecursive targetDir+            when (comp == GHC) -- FIX: hugs can't do --user yet+              (do assertCmd "make -s unregister-test" "unregister test"+                  assertCmd' compCmd "install -v0 --user" "install --user failed"+                  libForA targetDir+                  assertCmd' compCmd "unregister -v0 --user" "unregister failed")+-- HUnit+        ,TestLabel ("testing the HUnit package" ++ compIdent) $ TestCase $+         do setCurrentDirectory $ (testdir </> "HUnit-1.0")+            system "make -s clean"+            system "make -s"+            assertCmd' compCmd "configure -v0" "configure failed"+            assertCmd' compCmd "unregister -v0 --user" "unregister failed"++            system $ "touch dist/setup-config"+            system $ "touch dist/installed-pkg-config"+            doesFileExist "dist/setup-config" >>=+              assertBool ("touch dist/setup-config failed")++            -- Test clean:+            assertBuild+            doesDirectoryExist "dist/build" >>=+              assertBool "HUnit build did not create build directory"+            assertCmd' compCmd "clean -v0" "hunit clean"+            doesDirectoryExist "dist/build" >>=+              assertEqual "HUnit clean did not get rid of build directory" False++            doesFileExist "dist/setup-config" >>=+              assertEqual ("clean dist/setup-config failed") False+            doesFileExist "dist/installed-pkg-config" >>=+              assertEqual ("clean dist/installed-pkg-config failed") False++            assertConfigure ",tmp"+            assertHaddock+            doesDirectoryExist "dist/doc" >>= assertEqual "create of dist/doc" True+            assertBuild+            when (comp == GHC) -- tests building w/ an installed -package+                 (do assertCmd' compCmd "install -v0 --user" "hunit install"+                     assertCmd ("ghc -package HUnitTest HUnitTester.hs -o ./hunitTest")+                                "compile w/ hunit"+                     assertCmd "./hunitTest" "hunit test"+                     assertCmd' compCmd "unregister --user" "unregister failed")+            assertClean+            doesDirectoryExist "dist/doc" >>= assertEqual "clean dist/doc" False+            assertCmd "make -s clean" "make clean failed"++-- twoMains+        ,TestLabel ("package twoMains: building " ++ compIdent) $ TestCase $+         do setCurrentDirectory (testdir </> "twoMains")+            testPrelude+            assertConfigure ",tmp"+            assertCmd' compCmd "haddock" "setup haddock returned error code."+            assertBuild+            assertCopy+            doesFileExist ",tmp/bin/testA" >>=+              assertBool "install did not create the executable: testA"+            doesFileExist ",tmp/bin/testB" >>=+              assertBool "install did not create the executable: testB"+            assertCmd "./,tmp/bin/testA isA >  out" "A is not A"+            assertCmd "./,tmp/bin/testB isB >> out" "B is not B"+            -- no register, since there's no library+-- buildinfo+        ,TestLabel ("buildinfo with multiple executables " ++ compIdent) $ TestCase $+         do setCurrentDirectory (testdir </> "buildInfo")+            testPrelude+            assertConfigure ",tmp"+            assertHaddock+            assertBuild+            assertCopy+            doesFileExist ",tmp/bin/exe1" >>=+              assertBool "install did not create the executable: exe1"+            doesFileExist ",tmp/bin/exe2" >>=+              assertBool "install did not create the executable: exe2"+            -- no register, since there's no library+-- mutually recursive modules+        ,TestLabel ("package recursive: building " ++ compIdent) $ TestCase $+           when (comp == GHC) (do+            setCurrentDirectory (testdir </> "recursive")+            testPrelude+            assertConfigure ",tmp"+            assertBuild+            assertCopy+            doesFileExist "dist/build/A.hi-boot" >>=+              assertBool "build did not move A.hi-boot file into place lib"+            doesFileExist (",tmp/lib/recursive-1.0/ghc-" ++ compVerStr+                       ++ "/libHSrecursive-1.0.a") >>=+              assertBool "recursive build didn't create library"+            doesFileExist "dist/build/testExe/testExe-tmp/A.hi" >>=+              assertBool "build did not move A.hi-boot file into place exe"+            doesFileExist "dist/build/testExe/testExe" >>=+              assertBool "recursive build didn't create binary")+-- linking in ffi stubs+        ,TestLabel ("package ffi: " ++ compIdent) $ TestCase $+         do setCurrentDirectory (testdir </> "ffi-package")+            testPrelude+            assertConfigure "/tmp"+            assertBuild+            -- install it so we can test building with it.+            assertCmd' compCmd "install -v0 --user" "ffi-package install"+            assertClean+            doesFileExist "src/TestFFI_stub.c" >>=+                assertEqual "FFI-generated stub not cleaned." False+            -- now build something that depends on it+            setCurrentDirectory (".." </> "ffi-bin")+            testPrelude+            assertConfigure ",tmp"+            assertBuild+            assertCopy+-- depOnLib+        ,TestLabel ("package depOnLib: (executable depending on its lib)" ++ compIdent) $ TestCase $+         do setCurrentDirectory (testdir </> "depOnLib")+            testPrelude+            assertConfigure ",tmp"+            assertHaddock+            assertBuild+            assertCopy+            registerAndExecute "pkg depOnLib: register with script failed"+            unregisterAndExecute "pkg DepOnLib: unregister with script failed"+            when (comp == GHC) (do+                                doesFileExist "dist/build/mainForA/mainForA" >>=+                                  assertBool "build did not create the executable: mainForA"+                                doesFileExist ("dist/build/" </> "libHStest-1.0.a")+                                  >>= assertBool "library doesn't exist"+                                doesFileExist (",tmp/bin/mainForA")+                                  >>= assertBool "installed bin doesn't exist"+                                doesFileExist (",tmp/lib/test-1.0/ghc-" ++ compVerStr ++ "/libHStest-1.0.a")+                                  >>= assertBool "installed lib doesn't exist")+-- wash2hs+        ,TestLabel ("testing the wash2hs package" ++ compIdent) $ TestCase $+         do setCurrentDirectory (testdir </> "wash2hs")+            testPrelude+            assertCmdFail (compCmd ++ " configure -v0 --someUnknownFlag 2> err")+                          "wash2hs configure with unknown flag"+            assertConfigure ",tmp"+            assertHaddock+            assertBuild+            assertCopy+            -- no library to register+            doesFileExist ",tmp/bin/wash2hs"+              >>= assertBool "wash2hs didn't put executable into place."+            perms <- getPermissions ",tmp/bin/wash2hs"+            assertBool "wash2hs isn't +x" (executable perms)+            assertClean+            -- no unregister, because it has no libs!+-- withHooks+        ,TestLabel ("package withHooks: " ++ compIdent) $ TestCase $+         do setCurrentDirectory (testdir </> "withHooks")+            testPrelude+            assertCmd' compCmd ("configure -v0 --prefix=,tmp --woohoo " ++ compFlag)+              "configure returned error code"+            assertCmdFail (compCmd ++ " test -v0 --asdf > out") "test was supposed to fail"+            assertCmd' compCmd ("test -v0 --pass >> out") "test should not have failed"++            assertHaddock+            assertBuild+            assertCmd' compCmd "copy -v0 --copy-prefix=,tmp" "copy w/ prefix"+            doesFileExist ",tmp/withHooks" >>=  -- this file is added w/ the hook.+              assertBool "hooked copy, redirecting prefix didn't work."+            assertCmd' compCmd "register -v0 --user" "regular register returned error"+            assertCmd' compCmd "unregister -v0 --user" "regular unregister returned error"+            when (comp == GHC) -- FIX: come up with good test for Hugs+                 (do doesFileExist "dist/build/C.o" >>=+                       assertBool "C.testSuffix did not get compiled to C.o."+                     doesFileExist "dist/build/D.o" >>=+                       assertBool "D.gc did not get compiled to D.o this is an overriding test"+                     doesFileExist (",tmp/lib/withHooks-1.0/ghc-" ++ compVerStr+                                 ++ "/" </> "libHSwithHooks-1.0.a")+                       >>= assertBool "library doesn't exist")++            doesFileExist ",tmp/bin/withHooks" >>=+              assertBool "copy did not create the executable: withHooks"+            assertClean+            doesFileExist "C.hs" >>=+               assertEqual "C.hs (a generated file) not cleaned." False+-- HSQL+{-         ,TestLabel ("package HSQL (make-based): " ++ show compIdent) $+         TestCase $ unless (compFlag == "--hugs") $ -- FIX: won't compile w/ hugs+         do setCurrentDirectory $ (testdir </> "HSQL")+            system "make distclean"+            system "rm -rf /tmp/lib/HSQL"+            when (comp == GHC)+                 (system "ghc -cpp --make -i../.. Setup.lhs -o setup 2>out.build" >> return())+            assertConfigure "/tmp"+            doesFileExist "config.mk" >>=+              assertBool "config.mk not generated after configure"+            assertBuild+            assertCopy+            when (comp == GHC) -- FIX: do something for hugs+                 (doesFileExist "/tmp/lib/HSQL/GHC/libHSsql.a" >>=+                   assertBool "libHSsql.a doesn't exist. copy failed.")-}+      ]+    where testdir = currDir </> "systemTests"+          compStr = show comp+          compVerStr = concat . intersperse "." . map show . versionBranch $ compVersion+          compCmd = command comp+          compFlag = case compConf of+                      GHC -> "--ghc"+                      Hugs -> "--hugs"+                      _ -> error ("Unhandled compiler: " ++ show compConf)+          compIdent = compStr ++ "/" ++ compFlag+          testPrelude = system "make clean >> out.build" >> system "make >> out.build"+          assertConfigure pref+              = assertCmd' compCmd ("configure -v0 --user --prefix=" ++ pref ++ " " ++ compFlag)+                           "configure returned error code"+          -- XXX redirecting stderr is a hack. ar says+          -- /usr/bin/ar: creating dist/build/libHStest-1.0.a+          -- in the A test+          assertBuild = assertCmd' compCmd "build -v0 2> err" "build returned error code"+          assertCopy  = assertCmd' compCmd "copy -v0"  "copy returned error code"+          assertClean  = assertCmd' compCmd "clean -v0"  "clean returned error code"+          -- XXX Redirecting stderr is a hack - haddock needs to allow+          -- us to tell it to be quiet+          assertHaddock = assertCmd' compCmd "haddock -v0 2> err" "setup haddock returned error code."+          command GHC = "./setup"+          command Hugs = "runhugs -98 Setup.lhs"+          command c = error ("Unhandled compiler: " ++ show c)+          libForA pref  -- checks to see if the lib exists, for tests/A+              = let ghcTargetDir = pref ++ "/lib/test-1.0/ghc-" ++ compVerStr ++ "/" in+                 case compConf of+                  Hugs -> checkTargetDir (pref ++ "/lib/hugs/packages/test/") [".hs", ".lhs"]+                  GHC  -> do checkTargetDir ghcTargetDir [".hi"]+                             doesFileExist (ghcTargetDir </> "libHStest-1.0.a")+                               >>= assertBool "library doesn't exist"+                  _ -> error ("Unhandled compiler: " ++ show compConf)+          dumpScriptFlag = "--gen-script"+          registerAndExecute comment = do+            assertCmd' compCmd ("register -v0 --user "++dumpScriptFlag) comment+            if comp == GHC+               then assertCmd' "./register.sh" "" "reg script failed"+               else do ex <- doesFileExist "register.sh"+                       assertBool "hugs should not produce register.sh" (not ex)+          unregisterAndExecute comment = do+            assertCmd' compCmd ("unregister -v0 --user "++dumpScriptFlag) comment+            if comp == GHC+               then assertCmd' "./unregister.sh" "" "reg script failed"+               else do ex <- doesFileExist "unregister.sh"+                       assertBool "hugs should not produce unregister.sh" (not ex)++main :: IO ()+main = do putStrLn "compile successful"+          putStrLn "-= Setup Tests =-"+          setupCount <- runTestTT' $ TestList (D.V.hunitTests ++ D.PD.hunitTests)+          dir <- getCurrentDirectory+--          count' <- runTestTT' $ TestList (tests dir Hugs GHC)+          args <- getArgs+          let testList :: CompilerFlavor -> Version -> [Test]+              testList compiler version+                | null args = tests dir compiler compiler version+                | otherwise =+                    case reads (head args) of+                      [(n,_)] -> [ tests dir compiler compiler version !! n ]+                      _ -> error "usage: moduleTest [test_num]"+              compilers = [GHC] --, Hugs]+          globalTests <-+            flip mapM compilers $ \compilerFlavour -> do+              (compiler, _) <- configCompiler (Just compilerFlavour)+	                         Nothing Nothing+	                         defaultProgramConfiguration silent+              let version = compilerVersion compiler+              runTestTT' $ TestList (testList compilerFlavour version)+          putStrLn "-------------"+          putStrLn "Test Summary:"+          putStrLn $ showCounts $+                      foldl1 combineCounts (setupCount:globalTests)+          return ()++-- Local Variables:+-- compile-command: "ghc -i../:/usr/local/src/HUnit-1.0 -Wall --make ModuleTest.hs -o moduleTest"+-- End:
+ cabal/cabal/tests/UnitTest/Distribution/PackageDescription.hs view
@@ -0,0 +1,416 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  PackageDescriptionTests+-- Copyright   :  Isaac Jones 2003-2005+-- +-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>+-- Stability   :  alpha+-- Portability :  portable+--+-- Package description and parsing.++{- 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. -}++module UnitTest.Distribution.PackageDescription (+        -- * Debugging+        hunitTests,++  ) where+++import Distribution.ParseUtils+import Distribution.Package   (PackageIdentifier(..), Dependency(..))+import Distribution.Version   (Version(..), VersionRange(..))+import Distribution.Compiler  (CompilerFlavor(..), CompilerId(..))+import Distribution.System    (OS(..), buildOS, Arch(..), buildArch)++import Distribution.PackageDescription+import Distribution.PackageDescription.Configuration+import Distribution.PackageDescription.Parse+import Distribution.PackageDescription.Check+import qualified Distribution.Simple.PackageIndex as PackageIndex++import Data.Maybe (catMaybes)+import Data.List  (sortBy)+import Control.Monad (liftM)+import Test.HUnit (Test(..), assertBool, Assertion, assertEqual)+import Distribution.License+import Language.Haskell.Extension+++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------++compatTestPkgDesc :: String+compatTestPkgDesc = unlines [+        "-- Required",+        "Name: Cabal",+        "Version: 0.1.1.1.1-rain",+        "License: LGPL",+        "License-File: foo",+        "Copyright: Free Text String",+        "Cabal-version: >1.1.1",+        "-- Optional - may be in source?",+        "Author: Happy Haskell Hacker",+        "Homepage: http://www.haskell.org/foo",+        "Package-url: http://www.haskell.org/foo",+        "Synopsis: a nice package!",+        "Description: a really nice package!",+        "Category: tools",+        "buildable: True",+        "CC-OPTIONS: -g -o",+        "LD-OPTIONS: -BStatic -dn",+        "Frameworks: foo",+        "Tested-with: GHC",+        "Stability: Free Text String",+        "Build-Depends: haskell-src, HUnit>=1.0.0-rain",+        "Other-Modules: Distribution.Package, Distribution.Version,",+        "                Distribution.Simple.GHCPackageConfig",+        "Other-files: file1, file2",+        "Extra-Tmp-Files:    file1, file2",+        "C-Sources: not/even/rain.c, such/small/hands",+        "HS-Source-Dirs: src, src2",+        "Exposed-Modules: Distribution.Void, Foo.Bar",+        "Extensions: OverlappingInstances, TypeSynonymInstances",+        "Extra-Libraries: libfoo, bar, bang",+        "Extra-Lib-Dirs: \"/usr/local/libs\"",+        "Include-Dirs: your/slightest, look/will",+        "Includes: /easily/unclose, /me, \"funky, path\\\\name\"",+        "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"",+        "GHC-Options: -fTH -fglasgow-exts",+        "Hugs-Options: +TH",+        "Nhc-Options: ",+        "Jhc-Options: ",+        "",+        "-- Next is an executable",+        "Executable: somescript",+        "Main-is: SomeFile.hs",+        "Other-Modules: Foo1, Util, Main",+        "HS-Source-Dir: scripts",+        "Extensions: OverlappingInstances",+        "GHC-Options: ",+        "Hugs-Options: ",+        "Nhc-Options: ",+        "Jhc-Options: "+        ]++compatTestPkgDescAnswer :: PackageDescription+compatTestPkgDescAnswer = +    emptyPackageDescription +    { package = PackageIdentifier +                { pkgName = "Cabal",+                  pkgVersion = Version {versionBranch = [0,1,1,1,1],+                                        versionTags = ["rain"]}},+      license = LGPL,+      licenseFile = "foo",+      copyright = "Free Text String",+      author  = "Happy Haskell Hacker",+      homepage = "http://www.haskell.org/foo",+      pkgUrl   = "http://www.haskell.org/foo",+      synopsis = "a nice package!",+      description = "a really nice package!",+      category = "tools",+      descCabalVersion = LaterVersion (Version [1,1,1] []),+      buildType = Just Custom,+      buildDepends = [Dependency "haskell-src" AnyVersion,+                      Dependency "HUnit"+                        (UnionVersionRanges +                         (ThisVersion (Version [1,0,0] ["rain"]))+                         (LaterVersion (Version [1,0,0] ["rain"])))],+      testedWith = [(GHC, AnyVersion)],+      maintainer = "",+      stability = "Free Text String",+      extraTmpFiles = ["file1", "file2"],+      extraSrcFiles = ["file1", "file2"],+      dataFiles = [],++      library = Just $ Library {+          exposedModules = ["Distribution.Void", "Foo.Bar"],+          libBuildInfo = emptyBuildInfo {+              buildable = True,+              ccOptions = ["-g", "-o"],+              ldOptions = ["-BStatic", "-dn"],+              frameworks = ["foo"],+              cSources = ["not/even/rain.c", "such/small/hands"],+              hsSourceDirs = ["src", "src2"],+              otherModules = ["Distribution.Package",+                              "Distribution.Version",+                              "Distribution.Simple.GHCPackageConfig"],+              extensions = [OverlappingInstances, TypeSynonymInstances],+              extraLibs = ["libfoo", "bar", "bang"],+              extraLibDirs = ["/usr/local/libs"],+              includeDirs = ["your/slightest", "look/will"],+              includes = ["/easily/unclose", "/me", "funky, path\\name"],+              installIncludes = ["/easily/unclose", "/me", "funky, path\\name"],+              ghcProfOptions = [],+              options = [(GHC,["-fTH","-fglasgow-exts"])+                        ,(Hugs,["+TH"]),(NHC,[]),(JHC,[])]+         }},++      executables = [Executable "somescript" +                     "SomeFile.hs" (emptyBuildInfo {+                         otherModules=["Foo1","Util","Main"],+                         hsSourceDirs = ["scripts"],+                         extensions = [OverlappingInstances],+                         options = [(GHC,[]),(Hugs,[]),(NHC,[]),(JHC,[])]+                      })]+  }++-- Parse an old style package description.  Assumes no flags etc. being used.+compatParseDescription :: String -> ParseResult PackageDescription+compatParseDescription descr = do+    gpd <- parsePackageDescription descr+    case finalizePackageDescription [] (Nothing :: Maybe (PackageIndex.PackageIndex PackageIdentifier))+           buildOS buildArch (CompilerId GHC (Version [] [])) [] gpd of+      Left _ -> syntaxError (-1) "finalize failed"+      Right (pd,_) -> return pd++hunitTests :: [Test]+hunitTests = +    [ TestLabel "license parsers" $ TestCase $+      sequence_ [ assertParseOk ("license " ++ show lVal) lVal+                    (runP 1 "license" parseLicenseQ (show lVal))+                | lVal <- [GPL,LGPL,BSD3,BSD4] ]++    , TestLabel "Required fields" $ TestCase $+      do assertParseOk "some fields"+           emptyPackageDescription {+             package = (PackageIdentifier "foo"+                        (Version [0,0] ["asdf"])) }+           (compatParseDescription "Name: foo\nVersion: 0.0-asdf")++         assertParseOk "more fields foo"+           emptyPackageDescription {+             package = (PackageIdentifier "foo"+                        (Version [0,0] ["asdf"])),+             license = GPL }+           (compatParseDescription "Name: foo\nVersion:0.0-asdf\nLicense: GPL")++         assertParseOk "required fields for foo"+           emptyPackageDescription { +             package = (PackageIdentifier "foo"+                        (Version [0,0] ["asdf"])),+             license = GPL, copyright="2004 isaac jones" }+           (compatParseDescription $ "Name: foo\nVersion:0.0-asdf\n" +               ++ "Copyright: 2004 isaac jones\nLicense: GPL")+                                          +    , TestCase $ assertParseOk "no library" Nothing+        (library `liftM` (compatParseDescription $ +           "Name: foo\nVersion: 1\nLicense: GPL\n" +++           "Maintainer: someone\n\nExecutable: script\n" ++ +           "Main-is: SomeFile.hs\n"))++    , TestCase $ assertParseOk "translate deprecated fields"+        emptyPackageDescription {+             extraSrcFiles = ["foo.c", "bar.ml"],+             library = Just $ emptyLibrary {+               libBuildInfo = emptyBuildInfo { hsSourceDirs = ["foo","bar"] }}}+        (compatParseDescription $ +           "hs-source-dir: foo bar\nother-files: foo.c bar.ml")++    , TestLabel "Package description" $ TestCase $ +        assertParseOk "entire package description" +                      compatTestPkgDescAnswer+                      (compatParseDescription compatTestPkgDesc)+    , TestLabel "Package description pretty" $ TestCase $ +      case compatParseDescription compatTestPkgDesc of+        ParseFailed _ -> assertBool "can't parse description" False+        ParseOk _ d -> +            case compatParseDescription $ showPackageDescription d of+              ParseFailed _ ->+                assertBool "can't parse description after pretty print!" False+              ParseOk _ d' -> +                assertBool ("parse . show . parse not identity."+                            ++"   Incorrect fields:\n"+                            ++ (unlines $ comparePackageDescriptions d d'))+                (d == d')+    , TestLabel "Sanity checker" $ TestCase $ do+        let checks = checkConfiguredPackage emptyPackageDescription+            ers   = [ s | PackageBuildImpossible s <- checks ]+            warns = [ s | PackageBuildWarning    s <- checks ]+        assertEqual "Wrong number of errors"   2 (length ers)+        assertEqual "Wrong number of warnings" 3 (length warns)+    ]++-- |Compare two package descriptions and see which fields aren't the same.+comparePackageDescriptions :: PackageDescription+                           -> PackageDescription+                           -> [String]      -- ^Errors+comparePackageDescriptions p1 p2+    = catMaybes $ myCmp package          "package" +                : myCmp license          "license"+                : myCmp licenseFile      "licenseFile"+                : myCmp copyright        "copyright"+                : myCmp maintainer       "maintainer"+                : myCmp author           "author"+                : myCmp stability        "stability"+                : myCmp testedWith       "testedWith"+                : myCmp homepage         "homepage"+                : myCmp pkgUrl           "pkgUrl"+                : myCmp synopsis         "synopsis"+                : myCmp description      "description"+                : myCmp category         "category"+                : myCmp buildDepends     "buildDepends"+                : myCmp library          "library"+                : myCmp executables      "executables"+                : myCmp descCabalVersion "cabal-version" +                : myCmp buildType        "build-type" : []+      where canon_p1 = canonOptions p1+            canon_p2 = canonOptions p2+        +            myCmp :: (Eq a, Show a) => (PackageDescription -> a)+                  -> String       -- Error message+                  -> Maybe String -- +            myCmp f er = let e1 = f canon_p1+                             e2 = f canon_p2+                          in if e1 /= e2+                               then Just $ er ++ " Expected: " ++ show e1+                                              ++ " Got: " ++ show e2+                               else Nothing++canonOptions :: PackageDescription -> PackageDescription+canonOptions pd =+   pd{ library = fmap canonLib (library pd),+       executables = map canonExe (executables pd) }+  where+        canonLib l = l { libBuildInfo = canonBI (libBuildInfo l) }+        canonExe e = e { buildInfo = canonBI (buildInfo e) }++        canonBI bi = bi { options = canonOptions (options bi) }++        canonOptions opts = sortBy (comparing fst) opts++        comparing f a b = f a `compare` f b++-- |Assert that the 2nd value parses correctly and matches the first value+assertParseOk :: (Eq val) => String -> val -> ParseResult val -> Assertion+assertParseOk mes expected actual+    =  assertBool mes+           (case actual of+             ParseOk _ v -> v == expected+             _         -> False)++------------------------------------------------------------------------------++test_stanzas' = parsePackageDescription testFile+--                    ParseOk _ x -> putStrLn $ show x+--                    _ -> return ()++testFile = unlines $+          [ "Name: dwim"+          , "Cabal-version: >= 1.7"+          , ""+          , "Description: This is a test file   "+          , "  with a description longer than two lines.  "+          , ""+          , "flag Debug {"+          , "  Description: Enable debug information"+          , "  Default: False" +          , "}"+          , "flag build_wibble {"+          , "}"+          , ""+          , "library {"+          , "  build-depends: blub"+          , "  exposed-modules: DWIM.Main, DWIM"+          , "  if os(win32) && flag(debug) {"+          , "    build-depends: hunit"+          , "    ghc-options: -DDEBUG"+          , "    exposed-modules: DWIM.Internal"+          , "    if !flag(debug) {"+          , "      build-depends: impossible"+          , "    }"+          , "  }"+          , "}" +          , ""+          , "executable foo-bar {"+          , "  Main-is: Foo.hs"+          , "  Build-depends: blab"+          , "}"+          , "executable wobble {"+          , "  Main-is: Wobble.hs"+          , "  if flag(debug) {"+          , "    Build-depends: hunit"+          , "  }"+          , "}"+          , "executable wibble {"+          , "  Main-is: Wibble.hs"+          , "  hs-source-dirs: wib-stuff"+          , "  if flag(build_wibble) {"+          , "    Build-depends: wiblib >= 0.42"+          , "  } else {"+          , "    buildable: False"+          , "  }"+          , "}"+          ]++{-+test_compatParsing = +    let ParseOk ws (p, pold) = do +          fs <- readFields testPkgDesc +          ppd <- parsePackageDescription' fs+          let Right (pd,_) = finalizePackageDescription [] (Just pkgs) os arch ppd+          pdold <- parsePackageDescription testPkgDesc+          return (pd, pdold)+    in do putStrLn $ unlines $ map show ws+          putStrLn "==========="+          putStrLn $ showPackageDescription p+          putStrLn "==========="+          putStrLn $ showPackageDescription testPkgDescAnswer+          putStrLn "==========="+          putStrLn $ showPackageDescription pold+          putStrLn $ show (p == pold)+  where+    pkgs = [ PackageIdentifier "haskell-src" (Version [1,0] []) +           , PackageIdentifier "HUnit" (Version [1,1] ["rain"]) +           ]+    os = (MkOSName "win32")+    arch = (MkArchName "amd64")+-}+test_finalizePD =+    case parsePackageDescription testFile of+      ParseFailed err -> print err+      ParseOk _ ppd -> do+       case finalizePackageDescription [(FlagName "debug",True)] (Just pkgs) os arch impl [] ppd of+         Right (pd,fs) -> do putStrLn $ showPackageDescription pd+                             print fs+         Left missing -> putStrLn $ "missing: " ++ show missing+       putStrLn $ showPackageDescription $ +                flattenPackageDescription ppd+  where+    pkgs = PackageIndex.fromList[ PackageIdentifier "blub" (Version [1,0] []) +           --, PackageIdentifier "hunit" (Version [1,1] []) +           , PackageIdentifier "blab" (Version [0,1] []) +           ]+    os = Windows+    arch = X86_64+    impl = CompilerId GHC (Version [6,6] [])
+ cabal/cabal/tests/UnitTest/Distribution/PackageDescription/Configuration.hs view
@@ -0,0 +1,135 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Configuration+-- Copyright   :  Thomas Schilling, 2007+-- +-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>+-- Stability   :  alpha+-- Portability :  portable+--+-- Configurations++{- 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. -}++module UnitTest.Distribution.PackageDescription.Configuration where++import Distribution.PackageDescription.Configuration++import Distribution.Package (Package)+import Distribution.PackageDescription+         ( GenericPackageDescription(..), PackageDescription(..)+         , Library(..), Executable(..), BuildInfo(..)+         , Flag(..), CondTree(..), ConfVar(..), ConfFlag(..), Condition(..) )+import Distribution.Simple.PackageIndex (PackageIndex)+import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Version+    ( Version(..), Dependency(..), VersionRange(..)+    , withinRange, parseVersionRange )+import Distribution.Compiler (CompilerFlavor, parseCompilerFlavor)+import Distribution.System+         ( OS, readOS, Arch, readArch )+import Distribution.Simple.Utils (currentDir)++import Distribution.Compat.ReadP as ReadP hiding ( char )+import qualified Distribution.Compat.ReadP as ReadP ( char )++import Data.Char ( isAlphaNum, toLower )+import Data.Maybe ( catMaybes, maybeToList )+import Data.List  ( nub )+import Data.Monoid++import Data.List ( (\\) )+import Distribution.ParseUtils++------------------------------------------------------------------------------+-- Testing++tstTree :: CondTree ConfVar [Int] String+tstTree = CondNode "A" [0] +              [ (CNot (Var (Flag (ConfFlag "a"))), +                 CondNode "B" [1] [],+                 Nothing)+              , (CAnd (Var (Flag (ConfFlag "b"))) (Var (Flag (ConfFlag "c"))),+                CondNode "C" [2] [],+                Just $ CondNode "D" [3] +                         [ (Lit True,+                           CondNode "E" [4] [],+                           Just $ CondNode "F" [5] []) ])+                ]+++test_simplify = simplifyWithSysParams i386 darwin ("ghc",Version [6,6] []) tstCond +  where +    tstCond = COr (CAnd (Var (Arch ppc)) (Var (OS darwin)))+                  (CAnd (Var (Flag (ConfFlag "debug"))) (Var (OS darwin)))+    [ppc,i386] = ["ppc","i386"]+    [darwin,windows] = ["darwin","windows"]++++test_parseCondition = map (runP 1 "test" parseCondition) testConditions+  where+    testConditions = [ "os(darwin)"+                     , "arch(i386)"+                     , "!os(linux)"+                     , "! arch(ppc)"+                     , "os(windows) && arch(i386)"+                     , "os(windows) && arch(i386) && flag(debug)"+                     , "true && false || false && true"  -- should be same +                     , "(true && false) || (false && true)"  -- as this+                     , "(os(darwin))"+                     , " ( os ( darwin ) ) "+                     , "true && !(false || os(plan9))"+                     , "flag( foo_bar )"+                     , "flag( foo_O_-_O_bar )"+                     , "impl ( ghc )"+                     , "impl( ghc >= 6.6.1 )"+                     ]++test_ppCondTree = render $ ppCondTree tstTree (text . show)+  ++test_simpCondTree = simplifyCondTree env tstTree+  where+    env x = maybe (Left x) Right (lookup x flags)+    flags = [(mkFlag "a",False), (mkFlag "b",False), (mkFlag "c", True)] +    mkFlag = Flag . ConfFlag++test_resolveWithFlags = resolveWithFlags dom "os" "arch" ("ghc",Version [6,6] []) [tstTree] check+  where+    dom = [("a", [False,True]), ("b", [True,False]), ("c", [True,False])]+    check ds = let missing = ds \\ avail in+               case missing of+                 [] -> DepOk+                 _ -> MissingDeps missing+    avail = [0,1,3,4]++test_ignoreConditions = ignoreConditions tstTree
+ cabal/cabal/tests/UnitTest/Distribution/ParseUtils.hs view
@@ -0,0 +1,215 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.ParseUtils+-- Copyright   :  (c) The University of Glasgow 2004+-- +-- Maintainer  :  libraries@haskell.org+-- Stability   :  alpha+-- Portability :  portable+--+-- Utilities for parsing PackageDescription and InstalledPackageInfo.+++{- 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 the University 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 UnitTest.Distribution.ParseUtils where++import Distribution.ParseUtils+import Distribution.Compiler (CompilerFlavor, parseCompilerFlavorCompat)+import Distribution.License (License)+import Distribution.Version+import Distribution.Package	( parsePackageName )+import Distribution.Compat.ReadP as ReadP hiding (get)+import Distribution.Simple.Utils (intercalate)+import Language.Haskell.Extension (Extension)++import Text.PrettyPrint.HughesPJ hiding (braces)+import Data.Char (isSpace, isUpper, toLower, isAlphaNum, isSymbol, isDigit)+import Data.Maybe	(fromMaybe)+import Data.Tree as Tree (Tree(..), flatten)++import Test.HUnit (Test(..), assertBool, Assertion, runTestTT, Counts, assertEqual)+import IO+import System.Environment ( getArgs )+import Control.Monad ( zipWithM_ )++------------------------------------------------------------------------------+-- TESTING++test_readFields = case +                    readFields testFile +                  of+                    ParseOk _ x -> x == expectedResult+                    _ -> False+  where +    testFile = unlines $+          [ "Cabal-version: 3"+          , ""+          , "Description: This is a test file   "+          , "  with a description longer than two lines.  "+          , "if os(windows) {"+          , "  License:  You may not use this software"+          , "    ."+          , "    If you do use this software you will be seeked and destroyed."+          , "}"+          , "if os(linux) {"+          , "  Main-is:  foo1  "+          , "}"+          , ""+          , "if os(vista) {"+          , "  executable RootKit {"+          , "    Main-is: DRMManager.hs"+          , "  }"+          , "} else {"+          , "  executable VistaRemoteAccess {"+          , "    Main-is: VCtrl"+          , "}}"+          , ""+          , "executable Foo-bar {"+          , "  Main-is: Foo.hs"+          , "}"+          ]+    expectedResult = +          [ F 1 "cabal-version" "3"+          , F 3 "description" +                  "This is a test file\nwith a description longer than two lines."+          , IfBlock 5 "os(windows) " +              [ F 6 "license" +                      "You may not use this software\n\nIf you do use this software you will be seeked and destroyed."+              ]+              []+          , IfBlock 10 "os(linux) " +              [ F 11 "main-is" "foo1" ] +              [ ]+          , IfBlock 14 "os(vista) " +              [ Section 15 "executable" "RootKit " +                [ F 16 "main-is" "DRMManager.hs"]+              ] +              [ Section 19 "executable" "VistaRemoteAccess "+                 [F 20 "main-is" "VCtrl"]+              ]+          , Section 23 "executable" "Foo-bar " +              [F 24 "main-is" "Foo.hs"]+          ]++test_readFieldsCompat' = case test_readFieldsCompat of+                           ParseOk _ fs -> mapM_ (putStrLn . show) fs+                           x -> putStrLn $ "Failed: " ++ show x+test_readFieldsCompat = readFields testPkgDesc+  where +    testPkgDesc = unlines [+        "-- Required",+        "Name: Cabal",+        "Version: 0.1.1.1.1-rain",+        "License: LGPL",+        "License-File: foo",+        "Copyright: Free Text String",+        "Cabal-version: >1.1.1",+        "-- Optional - may be in source?",+        "Author: Happy Haskell Hacker",+        "Homepage: http://www.haskell.org/foo",+        "Package-url: http://www.haskell.org/foo",+        "Synopsis: a nice package!",+        "Description: a really nice package!",+        "Category: tools",+        "buildable: True",+        "CC-OPTIONS: -g -o",+        "LD-OPTIONS: -BStatic -dn",+        "Frameworks: foo",+        "Tested-with: GHC",+        "Stability: Free Text String",+        "Build-Depends: haskell-src, HUnit>=1.0.0-rain",+        "Other-Modules: Distribution.Package, Distribution.Version,",+        "                Distribution.Simple.GHCPackageConfig",+        "Other-files: file1, file2",+        "Extra-Tmp-Files:    file1, file2",+        "C-Sources: not/even/rain.c, such/small/hands",+        "HS-Source-Dirs: src, src2",+        "Exposed-Modules: Distribution.Void, Foo.Bar",+        "Extensions: OverlappingInstances, TypeSynonymInstances",+        "Extra-Libraries: libfoo, bar, bang",+        "Extra-Lib-Dirs: \"/usr/local/libs\"",+        "Include-Dirs: your/slightest, look/will",+        "Includes: /easily/unclose, /me, \"funky, path\\\\name\"",+        "Install-Includes: /easily/unclose, /me, \"funky, path\\\\name\"",+        "GHC-Options: -fTH -fglasgow-exts",+        "Hugs-Options: +TH",+        "Nhc-Options: ",+        "Jhc-Options: ",+        "",+        "-- Next is an executable",+        "Executable: somescript",+        "Main-is: SomeFile.hs",+        "Other-Modules: Foo1, Util, Main",+        "HS-Source-Dir: scripts",+        "Extensions: OverlappingInstances",+        "GHC-Options: ",+        "Hugs-Options: ",+        "Nhc-Options: ",+        "Jhc-Options: "+        ]+{-+test' = do h <- openFile "../Cabal.cabal" ReadMode+           s <- hGetContents h+           let r = readFields s+           case r of+             ParseOk _ fs -> mapM_ (putStrLn . show) fs+             x -> putStrLn $ "Failed: " ++ show x+           putStrLn "==================="+           mapM_ (putStrLn . show) $+                 merge . zip [1..] . lines $ s+           hClose h+-}++-- ghc -DDEBUG --make Distribution/ParseUtils.hs -o test++main :: IO ()+main = do+  inputFiles <- getArgs+  ok <- mapM checkResult inputFiles++  zipWithM_ summary inputFiles ok+  putStrLn $ show (length (filter not ok)) ++ " out of " ++ show (length ok) ++ " failed"++  where summary f True  = return ()+        summary f False = putStrLn $ f  ++ " failed :-("++checkResult :: FilePath -> IO Bool+checkResult inputFile = do+  file <- readTextFile inputFile+  case readFields file of+    ParseOk _ result -> do+       hPutStrLn stderr $ inputFile ++ " parses ok :-)"+       return True+    ParseFailed err -> do+       hPutStrLn stderr $ inputFile ++ " parse failed:"+       hPutStrLn stderr $ show err+       return False
+ cabal/cabal/tests/UnitTest/Distribution/Simple/PreProcess/UnlitTest.hs view
@@ -0,0 +1,60 @@++module UnitTest.Distribution.Simple.PreProcess.Unlit where++import Distribution.Simple.PreProcess.Unlit+import Control.Exception++cases =+  ( "", "" ) :+  -- latex state+  ( "\\begin{code}\n\\end{code}\na\n", "\n\n-- a\n") :  -- latex -> comment+  ( "\\begin{code}\nx=x\n\\end{code}\n", "\nx=x\n\n") :  -- latex -> latex (code)+  ( "\\begin{code}\n\\begin{code}\n", "\\begin{code} in code section") :  -- latex -> error+  -- blank state+  ( "\\end{code}\n", "\\end{code} without \\begin{code}") :  -- blank -> error+  ( "\\begin{code}\n\\end{code}\n", "\n\n") :  -- blank -> latex+  ( " \n#pre\n \n", " \n#pre\n \n" ) :  -- blank -> blank (CPP)+  ( "\n \n#pre\n \n", "\n \n#pre\n \n" ) :  -- blank -> blank (CPP)+  ( "\n> x=x\n", "\n  x=x\n" ) :  -- blank -> bird (> )+  ( "\n>x=x\n", "\n x=x\n" ) :  -- blank -> bird (>)+  ( "\n", "\n" ) :  -- blank -> blank+  ( " \n", " \n" ) :  -- blank -> blank+  ( " \na\n", " \n-- a\n" ) :  -- blank -> comment+  -- bird state+  ( "> x=x\n\\end{code}\n", "\\end{code} without \\begin{code}") :  -- bird -> error+  ( "> x=x\n\\begin{code}\ny=y\n", "  x=x\n\ny=y\n" ) :  -- bird -> latex+  ( "> x=x\n#abc\n> y=y\n", "  x=x\n#abc\n  y=y\n" ) :  -- bird -> bird (CPP)+  ( "> x=x\n> y=y\n", "  x=x\n  y=y\n" ) :  -- bird -> bird (> )+  ( ">x=x\n>y=y\n", " x=x\n y=y\n" ) :  -- bird -> bird (>)+  ( "> x=x\n  \n", "  x=x\n  \n" ) :  -- bird -> empty+  ( "> x=x\na\n", "program line before comment line" ) :  -- bird -> error+  -- comment state+    -- comment -> error+  ( "a\n\\end{code}\n", "\\end{code} without \\begin{code}") :+    -- comment -> latex+  ( "a\n\\begin{code}\nx=x\n\\end{code}\nb\n", "-- a\n\nx=x\n\n-- b\n" ) :+  ( "a\n#pre\nb\n", "-- a\n#pre\n-- b\n" ) :  -- comment -> comment (CPP)+  ( "a\n> x=x\n", "comment line before program line" ) :  -- comment -> error+  ( "abc\n", "-- abc\n" ) :+  ( "a\nb\n", "-- a\n-- b\n") :+  ( "a\n\n", "-- a\n\n") :  -- comment -> blank+  ( "a\n\nb\n", "-- a\n--\n-- b\n" ) : -- comment -> blank+  ( "a\n \n\n", "-- a\n \n\n" ) :  -- comment -> comment+  ( "a\n \n> x=x\n", "-- a\n \n  x=x\n" ) :  -- comment -> blank (> )+  ( "a\n \n>x=x\n", "-- a\n \n x=x\n" ) :  -- comment -> blank (>)+  ( "a\n \nb\n", "-- a\n--  \n-- b\n" ) :  -- comment -> comment+  []+++assertEq :: Int -> String -> String -> IO ()+assertEq n actual expect =+  if actual /= expect+    then putStrLn ("Test "++show n++" failed:\n  expect: "++expect++"\n  actual: "++(take 200 actual)++"\n")+    else putStrLn ("Test "++show n++" passed.")++runTest (n, (input, expect)) = do+  let actual = either id stripErr $ unlit ("test"++show n) input+  assertEq n actual (expect ++ "\n")+  where stripErr = (++"\n") . drop 2 . dropWhile (/= ':') . tail . dropWhile (/= ':')++runTests = mapM_ runTest (zip [1..] cases)
+ cabal/cabal/tests/UnitTest/Distribution/Version.hs view
@@ -0,0 +1,118 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Version+-- Copyright   :  Isaac Jones, Simon Marlow 2003-2004+-- +-- Maintainer  :  Isaac Jones <ijones@syntaxpolice.org>+-- Stability   :  alpha+-- Portability :  portable+--+-- Versions for packages, based on the 'Version' datatype.++{- Copyright (c) 2003-2004, Isaac Jones+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. -}++module UnitTest.Distribution.Version (hunitTests) where++import Distribution.Version+import Distribution.Text ( simpleParse )++import Data.Version	( Version(..), showVersion )++import Control.Monad    ( liftM )+import Data.Char	( isSpace, isDigit, isAlphaNum )+import Data.Maybe	( listToMaybe )++import Distribution.Compat.ReadP++import Test.HUnit++-- ------------------------------------------------------------+-- * Testing+-- ------------------------------------------------------------++branch1 :: [Int]+branch1 = [1]++branch2 :: [Int]+branch2 = [1,2]++branch3 :: [Int]+branch3 = [1,2,3]++release1 :: Version+release1 = Version{versionBranch=branch1, versionTags=[]}++release2 :: Version+release2 = Version{versionBranch=branch2, versionTags=[]}++release3 :: Version+release3 = Version{versionBranch=branch3, versionTags=[]}++hunitTests :: [Test]+hunitTests+    = [+       "released version 1" ~: "failed"+            ~: (Just release1) ~=? simpleParse "1",+       "released version 3" ~: "failed"+            ~: (Just release3) ~=? simpleParse "1.2.3",++       "range comparison LaterVersion 1" ~: "failed"+            ~: True+            ~=? release3 `withinRange` (LaterVersion release2),+       "range comparison LaterVersion 2" ~: "failed"+            ~: False+            ~=? release2 `withinRange` (LaterVersion release3),+       "range comparison EarlierVersion 1" ~: "failed"+            ~: True+            ~=? release3 `withinRange` (LaterVersion release2),+       "range comparison EarlierVersion 2" ~: "failed"+            ~: False+            ~=? release2 `withinRange` (LaterVersion release3),+       "range comparison orLaterVersion 1" ~: "failed"+            ~: True+            ~=? release3 `withinRange` (orLaterVersion release3),+       "range comparison orLaterVersion 2" ~: "failed"+            ~: True+            ~=? release3 `withinRange` (orLaterVersion release2),+       "range comparison orLaterVersion 3" ~: "failed"+            ~: False+            ~=? release2 `withinRange` (orLaterVersion release3),+       "range comparison orEarlierVersion 1" ~: "failed"+            ~: True+            ~=? release2 `withinRange` (orEarlierVersion release2),+       "range comparison orEarlierVersion 2" ~: "failed"+            ~: True+            ~=? release2 `withinRange` (orEarlierVersion release3),+       "range comparison orEarlierVersion 3" ~: "failed"+            ~: False+            ~=? release3 `withinRange` (orEarlierVersion release2)+      ]
+ cabal/cabal/tests/hackage/check.sh view
@@ -0,0 +1,25 @@+#!/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/cabal/tests/hackage/download.sh view
@@ -0,0 +1,19 @@+#!/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/cabal/tests/hackage/unpack.sh view
@@ -0,0 +1,16 @@+#!/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/cabal/tests/misc/ghc-supported-languages.hs view
@@ -0,0 +1,99 @@+-- | 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+  [ "PArr"   -- still classed as experimental, will be renamed and registered+  ]++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/cabal/tests/suite.cabal view
@@ -0,0 +1,30 @@+name: suite+version: 0.1+license: BSD3+author: Stephen Blackheath <http://blacksapphire.com/antispam>+stability: stable+synopsis: test suite for cabal+category: Distribution+build-type: Simple+cabal-version: >= 1.6+description:+    A test suite for cabal. Run it often, maintain it, add tests to it,+    and it will work for you.++Executable suite+    main-is: suite.hs+    build-depends:+        base,+        test-framework,+        test-framework-quickcheck2,+        test-framework-hunit,+        HUnit,+        QuickCheck >= 2.1.0.1,+        Cabal,+        filepath,+        process,+        directory,+        extensible-exceptions,+        bytestring,+        unix+
+ cabal/cabal/tests/suite.hs view
@@ -0,0 +1,66 @@+-- 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 Test.Framework+import Test.Framework.Providers.HUnit+import Test.Framework.Providers.QuickCheck2+import qualified Test.HUnit as HUnit+import PackageTests.BuildDeps.SameDepsAllRound.Check+import PackageTests.BuildDeps.TargetSpecificDeps1.Check+import PackageTests.BuildDeps.TargetSpecificDeps1.Check+import PackageTests.BuildDeps.TargetSpecificDeps2.Check+import PackageTests.BuildDeps.TargetSpecificDeps3.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.TestStanza.Check+import PackageTests.TestSuiteExeV10.Check+import Distribution.Text (display)+import Distribution.Simple.Utils (cabalVersion)+import Data.Version+import System.Directory++hunit :: TestName -> HUnit.Test -> Test+hunit name test = testGroup name $ hUnitTestToTests test++tests :: Version -> [Test]+tests cabalVersion = [+        hunit "PackageTests/BuildDeps/SameDepsAllRound/" PackageTests.BuildDeps.SameDepsAllRound.Check.suite,+        hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check.suite,+        hunit "PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/" PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check.suite,+        hunit "PackageTests/BuildDeps/InternalLibrary0/" (PackageTests.BuildDeps.InternalLibrary0.Check.suite cabalVersion),+        hunit "PackageTests/TestStanza/" (PackageTests.TestStanza.Check.suite cabalVersion),+        -- ^ The Test stanza test will eventually be required+        -- only for higher versions.+        hunit "PackageTests/TestSuiteExeV10/Test"+        (PackageTests.TestSuiteExeV10.Check.checkTest cabalVersion),+        hunit "PackageTests/TestSuiteExeV10/TestWithHpc"+        (PackageTests.TestSuiteExeV10.Check.checkTestWithHpc cabalVersion)+    ] +++    -- These tests are only required to pass on cabal version >= 1.7+    (if cabalVersion >= Version [1, 7] []+        then [+            hunit "PackageTests/BuildDeps/TargetSpecificDeps1/" PackageTests.BuildDeps.TargetSpecificDeps1.Check.suite,+            hunit "PackageTests/BuildDeps/TargetSpecificDeps2/" PackageTests.BuildDeps.TargetSpecificDeps2.Check.suite,+            hunit "PackageTests/BuildDeps/TargetSpecificDeps3/" PackageTests.BuildDeps.TargetSpecificDeps3.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary1/" PackageTests.BuildDeps.InternalLibrary1.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary2/" PackageTests.BuildDeps.InternalLibrary2.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary3/" PackageTests.BuildDeps.InternalLibrary3.Check.suite,+            hunit "PackageTests/BuildDeps/InternalLibrary4/" PackageTests.BuildDeps.InternalLibrary4.Check.suite+        ]+        else [])++main = do+    putStrLn $ "Cabal test suite - testing cabal version "++display cabalVersion+    setCurrentDirectory "tests"+    defaultMain (tests cabalVersion)+
+ cabal/cabal/tests/systemTests/A/A.cabal view
@@ -0,0 +1,23 @@+Name: test+cabal-version: > 1.1+Version: 1.0+copyright: filler for test suite+maintainer: Isaac Jones+synopsis: this package is really awesome.+Build-Depends: base+Other-Modules: B.A+Exposed-Modules: A+C-Sources: hello.c, c_src/hello.c+Extensions: ForeignFunctionInterface+x-darcs-repo: http://darcs.haskell.org/tmp+unknown-field: Filler.++Executable: testA+Other-Modules: A+Main-is: MainA.hs+C-Sources: c_src/hello.c+Extensions: OverlappingInstances++Executable: testB+Other-Modules: B.A+Main-is: B/MainB.hs
+ cabal/cabal/tests/systemTests/A/A.hs view
@@ -0,0 +1,4 @@+module A where+a = 42 :: Int++main2 = print a
+ cabal/cabal/tests/systemTests/A/B/A.lhs view
@@ -0,0 +1,4 @@+> module B.A where+> a = 42 :: Int++> main = print a
+ cabal/cabal/tests/systemTests/A/B/MainB.hs view
@@ -0,0 +1,5 @@+module Main where++import A++main = print a
+ cabal/cabal/tests/systemTests/A/MainA.hs view
@@ -0,0 +1,5 @@+module Main where++import A++main = print a
+ cabal/cabal/tests/systemTests/A/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/A/Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ cabal/cabal/tests/systemTests/A/c_src/hello.c view
@@ -0,0 +1,1 @@+int foo () {return 9;}
+ cabal/cabal/tests/systemTests/A/hello.c view
@@ -0,0 +1,1 @@+int main () {return 9;}
+ cabal/cabal/tests/systemTests/buildInfo/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/buildInfo/Setup.lhs view
@@ -0,0 +1,5 @@+#!/usr/bin/runhaskell++> import Distribution.Simple+> main = defaultMainWithHooks defaultUserHooks+
+ cabal/cabal/tests/systemTests/buildInfo/buildinfo2.buildinfo view
@@ -0,0 +1,5 @@+Executable: exe1+Buildable: True++Executable: exe2+Buildable: True
+ cabal/cabal/tests/systemTests/buildInfo/buildinfo2.cabal view
@@ -0,0 +1,19 @@+Name: buildinfo2+Version: 0.0+License: GPL+License-file: COPYING+Build-Depends: base+Author: Evgeny Chukreev+Copyright: Evgeny Chukreev (C) 2005+Maintainer: Evgeny Chukreev <public@toril.ru>+Synopsis: Buildinfo testcase+Description:+ Buildinfo testcase++Executable: exe1+Main-is: exe1.hs+HS-source-dirs: src++Executable: exe2+Main-is: exe2.hs+HS-source-dirs: src
+ cabal/cabal/tests/systemTests/buildInfo/src/exe1.hs view
@@ -0,0 +1,4 @@+module Main () where++main :: IO ()+main = return ()
+ cabal/cabal/tests/systemTests/buildInfo/src/exe2.hs view
@@ -0,0 +1,4 @@+module Main () where++main :: IO ()+main = return ()
+ cabal/cabal/tests/systemTests/dataDir/Exe.hs view
@@ -0,0 +1,17 @@+module Main where++import Control.Monad (unless)+import Paths_test (getDataFileName)+import System.Directory (doesFileExist)+import System.Exit (exitFailure)+import System.IO (putStrLn)++main :: IO ()+main = do+  fname <- getDataFileName "data-file"+  exists <- doesFileExist fname+  if exists+     then return ()+     else do putStrLn "Failure."+             print fname+             exitFailure
+ cabal/cabal/tests/systemTests/dataDir/data-file view
+ cabal/cabal/tests/systemTests/dataDir/dataDir.cabal view
@@ -0,0 +1,13 @@+name: test+version: 0.1+build-type: Simple+cabal-version: >= 1.2+data-files: data-file++-- This test passes if running the below executeable doesn't return an+-- 'exitFailure' status code.++executable exe+  main-is: Exe.hs+--  other-modules: Paths_test+  build-depends: base, directory
+ cabal/cabal/tests/systemTests/depOnLib/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/depOnLib/Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/runhugs++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ cabal/cabal/tests/systemTests/depOnLib/libs/A.hs view
@@ -0,0 +1,4 @@+module A where++a :: Char+a = 'a'
+ cabal/cabal/tests/systemTests/depOnLib/mains/Main.hs view
@@ -0,0 +1,4 @@+module Main where+import A++main = putStrLn "Hello, cabal."
+ cabal/cabal/tests/systemTests/depOnLib/test.cabal view
@@ -0,0 +1,13 @@+Name: test+Version: 1.0+hs-source-dir: libs+copyright: filler for test suite+maintainer: filler for test suite+synopsis: filler for test suite+build-depends: base+exposed-modules: A++Executable: mainForA+Other-Modules: Main, A+hs-source-dirs: mains, libs+Main-is: Main.hs
+ cabal/cabal/tests/systemTests/exeWithC/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/exeWithC/Setup.lhs view
@@ -0,0 +1,2 @@+> import Distribution.Simple+> main = defaultMainWithHooks defaultUserHooks
+ cabal/cabal/tests/systemTests/exeWithC/a.c view
@@ -0,0 +1,1 @@+int foo(int v) { return 2*v; }
+ cabal/cabal/tests/systemTests/exeWithC/test.hs view
@@ -0,0 +1,4 @@+{-# CFILES a.c #-}+foreign import ccall unsafe "foo" foo :: Int -> Int++main = print $ foo 6
+ cabal/cabal/tests/systemTests/exeWithC/tt.cabal view
@@ -0,0 +1,13 @@+Name:           tt+Version:        0.0+Copyright:      Einar Karttunen+Maintainer:     Isaac Jones+Synopsis:       Provided as a test.+License:        BSD3+Author:         This Test Case Contributed by: Einar Karttunen  Thanks!+Build-Depends:  base++Executable:     tt+Main-Is:        test.hs+C-Sources:      a.c+Extensions:     ForeignFunctionInterface
+ cabal/cabal/tests/systemTests/ffi-bin/Main.hs view
@@ -0,0 +1,7 @@+module Main where++import TestFFI++main :: IO ()+main = putStrLn "test"+
+ cabal/cabal/tests/systemTests/ffi-bin/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/ffi-bin/Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhaskell++> import Distribution.Simple+> main = defaultMain
+ cabal/cabal/tests/systemTests/ffi-bin/main.cabal view
@@ -0,0 +1,6 @@+Name:           test-bin+Build-Depends:  base, testffi+Version:        0.0++Executable:     test+Main-Is:        Main.hs
+ cabal/cabal/tests/systemTests/ffi-package/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/ffi-package/Setup.lhs view
@@ -0,0 +1,4 @@+#! /usr/bin/env runhugs++> import Distribution.Simple+> main = defaultMain
+ cabal/cabal/tests/systemTests/ffi-package/TestFFIExe.hs view
@@ -0,0 +1,11 @@+module Main where++import Foreign++type Action = IO ()++foreign import ccall "wrapper"+    mkAction :: Action -> IO (FunPtr Action)++main :: IO ()+main = return ()
+ cabal/cabal/tests/systemTests/ffi-package/src/TestFFI.hs view
@@ -0,0 +1,8 @@+module TestFFI where++import Foreign++type Action = IO ()++foreign import ccall "wrapper"+    mkAction :: Action -> IO (FunPtr Action)
+ cabal/cabal/tests/systemTests/ffi-package/testffi.cabal view
@@ -0,0 +1,10 @@+Name:            testffi+Version:         0.0+Build-Depends:   base+hs-source-dir:  src+Exposed-modules: TestFFI+Extensions:      ForeignFunctionInterface++executable: foo+main-is:    TestFFIExe.hs+Extensions:      ForeignFunctionInterface
+ cabal/cabal/tests/systemTests/preprocess/preprocess.cabal view
@@ -0,0 +1,9 @@+-- The point of this test is to check that the c2hs pre-processed .hs sources+-- end up in dist/build and that the happy one stays in the src dir.+-- Also, the happy one should be included into the sdist tarball.++name:            preprocess+version:         0.0+build-depends:   base+hs-source-dirs:  src+exposed-modules: C2HsExample, HappyExample
+ cabal/cabal/tests/systemTests/preprocess/src/C2HsExample.chs view
@@ -0,0 +1,3 @@+module C2HsExample where++-- we don't actually need anything
+ cabal/cabal/tests/systemTests/preprocess/src/HappyExample.y view
@@ -0,0 +1,92 @@+{+module HappyExample where+import Data.Char+}++%name calc+%tokentype { Token }+%expect 0+++%token +	let		{ TokenLet }+	in		{ TokenIn }+	int		{ TokenInt $$ }+	var		{ TokenVar $$ }+	'='		{ TokenEq }+	'+'		{ TokenPlus }+	'-'		{ TokenMinus }+	'*'		{ TokenTimes }+	'/'		{ TokenDiv }+	'('		{ TokenOB }+	')'		{ TokenCB }+++%%++Exp :: { Exp }+Exp : let var '=' Exp in Exp	{ Let $2 $4 $6 }+    | Exp1			{ Exp1 $1 }++Exp1 : Exp1 '+' Term		{ Plus $1 $3 }+     | Exp1 '-' Term		{ Minus $1 $3 }+     | Term			{ Term $1 }++Term : Term '*' Factor	{ Times $1 $3 }+     | Term '/' Factor	{ Div $1 $3 }+     | Factor			{ Factor $1 }++Factor : int			{ Int $1 }+	 | var			{ Var $1 }+	 | '(' Exp ')'		{ Brack $2 }+++{++happyError :: [Token] -> a+happyError _ = error ("Parse error\n")+++data Exp  = Let String Exp Exp | Exp1 Exp1 +data Exp1 = Plus Exp1 Term | Minus Exp1 Term | Term Term +data Term = Times Term Factor | Div Term Factor | Factor Factor +data Factor = Int Int | Var String | Brack Exp +++data Token+	= TokenLet+	| TokenIn+	| TokenInt Int+	| TokenVar String+	| TokenEq+	| TokenPlus+	| TokenMinus+	| TokenTimes+	| TokenDiv+	| TokenOB+	| TokenCB++lexer :: String -> [Token]+lexer [] = []+lexer (c:cs) +	| isSpace c = lexer cs+	| isAlpha c = lexVar (c:cs)+	| isDigit c = lexNum (c:cs)+lexer ('=':cs) = TokenEq : lexer cs+lexer ('+':cs) = TokenPlus : lexer cs+lexer ('-':cs) = TokenMinus : lexer cs+lexer ('*':cs) = TokenTimes : lexer cs+lexer ('/':cs) = TokenDiv : lexer cs+lexer ('(':cs) = TokenOB : lexer cs+lexer (')':cs) = TokenCB : lexer cs++lexNum cs = TokenInt (read num) : lexer rest+	where (num,rest) = span isDigit cs++lexVar cs =+   case span isAlpha cs of+	("let",rest) -> TokenLet : lexer rest+	("in",rest)  -> TokenIn : lexer rest+	(var,rest)   -> TokenVar var : lexer rest++}
+ cabal/cabal/tests/systemTests/recursive/A.hi-boot view
@@ -0,0 +1,2 @@+module A where+newtype TA = MkTA GHC.Base.Int
+ cabal/cabal/tests/systemTests/recursive/A.hs view
@@ -0,0 +1,8 @@+module A where++import B( TB(..) )++newtype TA = MkTA Int+    +f :: TB -> TA+f (MkTB x) = MkTA x
+ cabal/cabal/tests/systemTests/recursive/A.hs-boot view
@@ -0,0 +1,2 @@+module A where+newtype TA = MkTA Int
+ cabal/cabal/tests/systemTests/recursive/B.hs view
@@ -0,0 +1,8 @@+module B where+import {-# SOURCE #-} A( TA(..) )+    +data TB = MkTB !Int++g :: TA -> TB+g (MkTA x) = MkTB x+
+ cabal/cabal/tests/systemTests/recursive/C.hs view
@@ -0,0 +1,6 @@+module Main where+import B+import A -- FIX: GHC doesn't seem to figure out this dependency?!++main :: IO ()+main = let f = g in putStrLn "C"
+ cabal/cabal/tests/systemTests/recursive/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/recursive/Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/env runhaskell++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ cabal/cabal/tests/systemTests/recursive/recursive.cabal view
@@ -0,0 +1,11 @@+name: recursive+build-depends: base+version: 1.0+copyright: filler for test suite+maintainer: Isaac Jones+synopsis: this package is really awesome.+Exposed-Modules: A, B++Executable: testExe+Main-is: C.hs+other-modules: A, B
+ cabal/cabal/tests/systemTests/sdist/Exe1.hs view
@@ -0,0 +1,1 @@+main = print "exe1"
+ cabal/cabal/tests/systemTests/sdist/Exe2.hs view
@@ -0,0 +1,1 @@+main = print "exe2"
+ cabal/cabal/tests/systemTests/sdist/sdist.cabal view
@@ -0,0 +1,19 @@+Name: test+Version: 0.1+Build-Type: Simple+Cabal-Version: >=1.2++-- http://hackage.haskell.org/trac/hackage/ticket/257+-- This is a test to make sure we're including all sections into the sdist+-- irrespective of the buildable status.+-- So the test passes if the tarball includes both Exe1.hs and Exe2.hs++Executable exe1+    Main-Is: Exe1.hs+    Build-Depends: base++Executable exe2+    Main-Is: Exe2.hs+    Build-Depends: base+    if !os(linux)+      Buildable: False
+ cabal/cabal/tests/systemTests/twoMains/MainA.hs view
@@ -0,0 +1,9 @@+module Main where++import System.Environment (getArgs)+import Control.Monad (when)++main = do print 'a'+          args <- getArgs+          let isB = head args+          when (isB /= "isA") (error "A is not A!")
+ cabal/cabal/tests/systemTests/twoMains/MainB.hs view
@@ -0,0 +1,9 @@+module Main where++import System.Environment (getArgs)+import Control.Monad (when)++main = do print 'b'+          args <- getArgs+          let isB = head args+          when (isB /= "isB") (error "B is not B!")
+ cabal/cabal/tests/systemTests/twoMains/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/twoMains/Setup.lhs view
@@ -0,0 +1,8 @@+#!/usr/bin/runhugs++> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain
+ cabal/cabal/tests/systemTests/twoMains/test.cabal view
@@ -0,0 +1,14 @@+Name: test+Version: 1.0+copyright: filler for test suite+maintainer: filler for test suite+build-depends: base+synopsis: filler for test suite++Executable: testA+Other-Modules: MainA+Main-is: MainA.hs++Executable: testB+Other-Modules: MainB+Main-is: MainB.hs
+ cabal/cabal/tests/systemTests/wash2hs/CHANGES view
@@ -0,0 +1,5 @@+* 20031112+  added JSP-style string escape:+   <%= my nice haskell code %>+  is mapped to+   text (my nice haskell code)
+ cabal/cabal/tests/systemTests/wash2hs/LICENSE view
@@ -0,0 +1,27 @@+Copyright (C) 2000-2003 Erik Meijer, Danny van Velzen, and Peter Thiemann++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met: ++1. Redistributions of source code must retain the above copyright+   notice, this list of conditions and the following disclaimer.  +2. 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.  +3. The names of the authors may not be used to endorse or promote+   products derived from this software without specific prior written+   permission. ++THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``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 AUTHOR 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/cabal/tests/systemTests/wash2hs/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/wash2hs/Setup.lhs view
@@ -0,0 +1,9 @@+> module Main where++> import Distribution.Simple++> main :: IO ()+> main = defaultMain++to compile: +ghc -package Cabal -package parsec Setup.lhs -o setup
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHClean.hs view
@@ -0,0 +1,58 @@+module WASHClean where++import Data.Char++import WASHData++data CM a = CM ([String] -> a)+instance Monad CM where -- Reader monad+  return x = CM (const x)+  m >>= f  = CM (\strs ->+		 case m of+		   CM mfun -> +		     case f (mfun strs) of+		       CM ffun ->+			 ffun strs)++class Clean n where+  clean :: n -> CM n++cleanCodeFragList :: [CodeFrag] -> [CodeFrag]+cleanCodeFragList = map g+  where g (EFrag el) = EFrag (cleanElement el)+	g (CFrag cs) = CFrag (cleanContentList cs)+	g cf         = cf++cleanElement :: Element -> Element+cleanElement e@Element{elemName = en, elemContent = ec} =+  if en == "pre"+  then e+  else let ec' = cleanContentList ec in+       e{elemContent = ec'}++cleanContentList :: [Content] -> [Content]+cleanContentList = remove . map g . combine+  where g c = case c of CElement{celem = el} -> CElement{celem = cleanElement el}+			CText{ctext = et}    -> CText{ctext = et { textString = cleanText (textString et) }}+			CCode{ccode = ec}    -> CCode{ccode = cleanCodeFragList ec}+			_ -> c+	combine (CText {ctext = t1} : CText {ctext = t2} : rest ) = +		combine (CText {ctext = Text {textString = textString t1++ textString t2, textMode = textMode t1}} : rest)+	combine (x : xs) = x : combine xs+	combine [] = []+	remove  (CText{ctext = tt} : rest) | textString tt == " " = remove rest+	-- remove  (CText{ctext = tt} : rest@(CElement{} : _)) = CText{ctext = dropRight tt} : remove rest+	-- remove  (e@CElement{} : (CText{ctext = tt} : rest)) = e : remove (CText{ctext = dropLeft tt} : rest)+	remove  (x : rest) = x : remove rest+	remove  [] = []++cleanText "" = ""+cleanText xs@[x] | isSpace x = " "+		 | otherwise = xs+cleanText (x : ys@(y : _)) | isSpace x = if isSpace y +					 then cleanText ys+					 else ' ' : cleanText ys+			   | otherwise = x : cleanText ys++dropRight tt = tt { textString = reverse (dropWhile isSpace (reverse (textString tt))) }+dropLeft  tt = tt { textString = dropWhile isSpace (textString tt) }
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHData.hs view
@@ -0,0 +1,74 @@+module WASHData						    -- derived from HSPData+    ( File (..)+    , Mode (..)+    , Element (..)+    , Text (..)+    , Content (..)+    , CodeFrag (..)+    , Attribute (..)+    , AttrValue (..)+    )+where {+++-- Data type.++data File = File { +    fcode :: [CodeFrag],+    topElem :: Element+    } deriving Show;++data Mode = V | S | F +  deriving (Eq,Show);++data Element = Element +    { elemMode :: Mode+    , elemName :: String+    , elemAttrs :: [Attribute]+    , elemContent :: [Content]+    , elemEmptyTag :: Bool }+    deriving Show;++data Text = Text +    { textMode :: Mode+    , textString :: String+    }+    deriving Show;++data Content +    = CElement { celem :: Element }+    | CText { ctext :: Text }+    | CReference { creference :: Text }+    | CPI { cpi :: String }+    | CComment { ccomment :: String }+    | CCode { ccode :: [CodeFrag] }+    deriving Show;+    +data CodeFrag +    = HFrag String+    | EFrag Element+    | HSFrag String+    | CFrag [Content]+    | AFrag [Attribute]+    | VFrag String+    deriving Show;++data Attribute+  = Attribute+    { attrMode :: Mode+    , attrName :: String+    , attrValue :: AttrValue }+  | AttrPattern+    { attrPattern :: String }+    deriving Show;++data AttrValue+    = AText String+    | ACode String+    deriving Show;++data Reference = Reference String deriving Show;+    +++}
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHExpression.hs view
@@ -0,0 +1,158 @@+module WASHExpression where++import Control.Monad++import WASHFlags+import qualified WASHUtil+import WASHData+import WASHOut++code :: FLAGS -> [CodeFrag] -> ShowS+code flags [] = id+code flags (x:xs) = code' flags x . code flags xs++code' :: FLAGS -> CodeFrag -> ShowS+code' flags (HFrag h) = +  showString h+code' flags (EFrag e) =+  runOut $ element flags e+code' flags (CFrag cnts) =+  showChar '(' .+  runOut (contents flags [] cnts) .+  showChar ')'+code' flags (AFrag attrs) =+  showChar '(' .+  WASHUtil.itemList (attribute flags) "CGI.empty" " >> " attrs .+  showChar ')'+code' flags (VFrag var) = +  id+code' flags _ = error "Unknown type: code"++outMode :: Mode -> Out ()+outMode = outShowS . showMode++showMode :: Mode -> ShowS+showMode V = id+showMode S = showString "_T"+showMode F = showString "_S"++element :: FLAGS -> Element -> Out [String]+element flags (Element mode nm ats cnt et) =+  do outChar '('+     outString "CGI."+     outString nm+     when (generateBT flags) $ outMode mode+     outChar '('+     outShowS $ attributes flags ats+     rvs <- contents flags [] cnt+     outString "))"+     return rvs++outRVS :: [String] -> Out ()+outRVS [] = outString "()"+outRVS (x:xs) =+  do outChar '('+     outString x+     mapM_ g xs+     outChar ')'+  where g x = do { outChar ','; outString x; }++outRVSpat :: [String] -> Out ()+outRVSpat [] = outString "(_)"+outRVSpat xs = outRVS xs++contents :: FLAGS -> [String] -> [Content] -> Out [String]+contents flags inRVS cts =+  case cts of+    [] ->+      do outString "return"+	 outRVS inRVS+	 return inRVS+    ct:cts ->+      do rvs <- content flags ct+	 case rvs of+	   [] ->+             case (cts, inRVS) of+	       ([],[]) ->+	         return []+	       _ ->+		 do outString " >> "+		    contents flags inRVS cts+	   _ ->+	     case (cts, inRVS) of+	       ([],[]) ->+	         return rvs+	       _ ->+		 do outString " >>= \\ "+		    outRVSpat rvs+		    outString " -> "+		    contents flags (rvs ++ inRVS) cts++content :: FLAGS -> Content -> Out [String]+content flags (CElement elem)  = +  element flags elem+content flags (CText txt) =+  do text flags txt+     return []+content flags (CCode (VFrag var:c)) =+  do outShowS $ (showChar '(' . code flags c . showChar ')')+     return [var]+content flags (CCode c) =+  do outShowS $ (showChar '(' . code flags c . showChar ')')+     return []+content flags (CComment cc) =+  do outShowS $ (showString "return (const () " . shows cc . showChar ')')+     return []+content flags (CReference txt) =+  do text flags txt+     return []+content flags c = +  error $ "Unknown type: content -- " ++ (show c)++text :: FLAGS -> Text -> Out [String]+text flags txt =+  do outString "CGI.rawtext"+     when (generateBT flags) $ outMode (textMode txt)+     outChar ' '+     outs (textString txt)+     return []++attributes :: FLAGS -> [Attribute] -> ShowS+attributes flags atts = +  f atts+    where+      f [] = id+      f (att:atts) = +	attribute flags att .+	showString " >> " .+	f atts++attribute :: FLAGS -> Attribute -> ShowS+attribute flags (Attribute m n v) = +  showString "(CGI.attr" .+  (if generateBT flags then (attrvalueBT m v) else id) .+  showChar ' ' .+  shows n . +  showString " " .+  attrvalue v .+  showString ")"+attribute flags (AttrPattern pat) =+  showString "( " .+  showString pat .+  showString " )"+attribute flags a = error $ "Unknown type: attribute -- " ++ (show a)++attrvalue :: AttrValue -> ShowS+attrvalue (AText t) = +  shows t+attrvalue (ACode c) =+  showString "( " .+  showString c .+  showString " )"+attrvalue a = error $ "Unknown type: attrvalue -- " ++ (show a)++attrvalueBT :: Mode -> AttrValue -> ShowS+attrvalueBT V _ = id+attrvalueBT m (AText _) = showMode m . showChar 'S'+attrvalueBT m (ACode _) = showMode m . showChar 'D'+attrvalueBT m a = error $ "Unknown type: attrvalueBT -- " ++ (show a)
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHFlags.hs view
@@ -0,0 +1,7 @@+module WASHFlags where+-- +flags0 = FLAGS { generateBT = False }++data FLAGS = FLAGS { generateBT :: Bool }++
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHGenerator.hs view
@@ -0,0 +1,57 @@+module WASHGenerator (preprocess, preprocessPIPE) where {++import Data.List;+import System.IO;++import WASHData ;+import Parsec hiding (try) ;+import qualified WASHParser ;+import qualified WASHExpression ;+import qualified WASHClean ;+import WASHFlags ;++-- import Trace;++preprocess :: FLAGS -> String -> String -> String -> IO ();+preprocess flags srcName dstName globalDefs =+  bracket (openFile srcName ReadMode)+    (\ srcHandle -> hClose srcHandle)+    (\ srcHandle -> +       bracket (openFile dstName WriteMode)+	 (\ dstHandle -> hClose dstHandle)+	 (\ dstHandle -> +	  preprocessPIPE flags srcName srcHandle dstHandle globalDefs));+++preprocessPIPE :: FLAGS -> String -> Handle -> Handle -> String -> IO ();+preprocessPIPE flags srcName srcHandle dstHandle globalDefs = do {+    input <- hGetContents srcHandle;+    let { parsing = parse WASHParser.washfile srcName input };+    case parsing of {+        Left error -> ioError $ userError $ show error;+        Right washfile ->+        hPutStrLn dstHandle (postprocess $ file flags globalDefs washfile "");+    };+};++file :: FLAGS -> String -> [CodeFrag] -> ShowS ;+file flags globalDefs fcode = +  WASHExpression.code flags (WASHClean.cleanCodeFragList fcode) .+  showString globalDefs .+  showString "\n"+  ;++imports ::  [String] -> String ;+imports is = concat $ map (\m -> "import " ++ m ++ ";\n") is ;++postprocess :: String -> String ;+postprocess = unlines . postprocess' . lines ;++postprocess' :: [String] -> [String] ;+postprocess' [] = [] ;+postprocess' xs'@(x:xs) = +  if "import" `isPrefixOf` x+  then "import qualified CGI" : xs'+  else x : postprocess' xs ;++}
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHMain.hs view
@@ -0,0 +1,36 @@+module Main where++-- ghc --make WASHMain -package text -o WASHMain++import System.IO+import Data.List+import System+import WASHGenerator+import WASHFlags++main =+  do args <- getArgs+     runPreprocessor flags0 args++runPreprocessor flags [washfile] =+  if ".wash" `isSuffixOf` washfile +  then+     preprocess flags washfile (take (length washfile - 5) washfile ++ ".hs") ""+  else+  preprocess flags+             (washfile ++ ".wash")+	     (washfile ++ ".hs")+	     ""+runPreprocessor flags [washfile, hsfile] =+  preprocess flags (washfile) (hsfile) ""+runPreprocessor flags [originalFile, washfile, hsfile] =+  preprocess flags (washfile) (hsfile) ""+runPreprocessor flags [] =+  preprocessPIPE flags "<stdin>" stdin stdout ""+runPreprocessor flags args =+  do progName <- getProgName+     hPutStrLn stderr ("Usage: " ++ progName ++ " washfile [hsfile]")+     hPutStrLn stderr ("   or: " ++ progName ++ " originalFile infile outfile")+     hPutStrLn stderr ("   or: " ++ progName)+     hPutStrLn stderr ("       to run as pipe processor")+     hPutStrLn stderr ("Actual arguments: " ++ show args)
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHOut.hs view
@@ -0,0 +1,30 @@+module WASHOut where++-- output monad++data Out a = Out a ShowS++instance Monad Out where+  return a = Out a id+  m >>= f  = case m of+	       Out x shw1 ->+		 case f x of+                   Out y shw2 ->+		     Out y (shw1 . shw2)++runOut :: Out a -> ShowS+runOut (Out a shw) = shw++wrapper = (Out () .)++outString :: String -> Out ()+outString = wrapper showString++outChar :: Char -> Out ()+outChar = wrapper showChar++outs :: Show a => a -> Out ()+outs = wrapper shows++outShowS :: ShowS -> Out ()+outShowS = Out ()
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHParser.hs view
@@ -0,0 +1,541 @@+module WASHParser ( xmlfile, washfile ) where {++import Data.Char ;+import Parsec hiding (letter) ;+import WASHData;+import WASHUtil;+++notImplemented = char '\xff' >> return undefined +    <?> "something that isn't implemented yet";++f <$> p = do { x <- p; return $ f x; };++testParser p s = +    case parse (do { x <- p; eof; return x; }) "bla" s of {+        Left x -> print x;+        Right y -> print y;+    };++washfile :: Parser [CodeFrag] ;+washfile = +  do code <- hBody+     eof+     return $ code+  ;++setMode :: Bool -> Mode ;+setMode toplevel = if toplevel then S else F ;++-- The numbers given for each parser identify the section and+-- grammar production within the XML 1.0 definition (W3C +-- REC-xml-19980210).+++-- 2.1 / 1+xmlfile :: Parser File;+xmlfile = do { +    prolog;+    code <- option [] (do {+        hs <- haskell;+        s0;+        return hs+    });+    elem <- element True;+    many misc;+    eof;+    return $ File { fcode = code, topElem = elem };+};+++-- 2.2 / 2+char' = (char '\t' <|> char '\n' <|> char '\r' <|> +    satisfy (>= ' ')) <?> "character";+++-- 2.3 / 3+s = (try $ many1 (char ' ' <|> char '\t' <|> +    char '\r' <|> char '\n')) <?> "whitespace";+s0 = option "" s;+{-+s0 = (try $ many (char ' ' <|> char '\t' <|> +    char '\r' <|> char '\n')) <?> "optional whitespace";+-}++-- 2.3 / 4+nameChar = letter <|> digit <|> char '.' <|> char '-' <|> +    char '_' <|> char ':' <|> combiningChar <|> extender;+++-- 2.3 / 5+name :: Parser String;+name = do {+    c <- letter <|> char '_' <|> char ':';+    cs <- many nameChar;+    return $ c:cs;+} <?> "name";+++-- 2.3 / 6+names :: Parser [String];+names = sepBy1 name s;+++-- 2.3 / 7+nmtoken :: Parser String;+nmtoken = many1 nameChar <?> "nmtoken";+++-- 2.3 / 8+nmtokens :: Parser [String];+nmtokens = sepBy1 name s;+++-- 2.3 / 10+attValue :: Parser AttrValue;+attValue = (((AText . concat) <$> (+        between (char '\"') (char '\"') (many (p '\"')) +    <|> between (char '\'') (char '\'') (many (p '\'')) ))+    <|> ACode <$> haskellAttr) <?> "attvalue"+where {+    p end = (\x -> [x]) <$> satisfy (f end) <|> reference;+    f end = \c -> c /= '<' && c /= '&' && c /= end;+};++-- 2.3 / 11+systemLiteral = do{+  char '\'';+  sl <- many (satisfy (\c -> c /= '\''));+  char '\'';+  return sl;+} <|> do{+  char '\"';+  sl <- many (satisfy (\c -> c /= '\"'));+  char '\"';+  return sl;+};++-- 2.3 / 12+pubidLiteral = do {+  char '\'';+  sl <- many (pubidChar False);+  char '\'';+  return sl;+} <|> do{+  char '\"';+  sl <- many (pubidChar True);+  char '\"';+  return sl;+};++-- 2.3 / 13+pubidChar w = satisfy (\c -> c >= 'A' && c <= 'Z' +		          || c >= 'a' && c <= 'z'+			  || c >= '0' && c <= '9'+			  || c `elem` " \n\r-()+,./:=?;!*#@$_%"+			  || w && c == '\'');++-- 2.4 / 14+charData :: Bool -> Parser Text;+charData toplevel =+  do { s <- many1 charData'; return $ Text (setMode toplevel) $ concat s; }+  <?> "#PCDATA";++charData' :: Parser String;+charData' = do {+    c <- satisfy f;+    return [c];+} <|> do {+    string "]]";+    c <- satisfy (\c -> f c && c /= '>');+    return $ ']':']':[c];+}+where { +    f c = c /= '<' && c /= '&' && c /= ']';+};+++-- 2.5 / 15+comment :: Parser String;+comment = do {+    try $ string "<!--";+    comment';+} <?> "comment";++comment' = +    (do {+        c <- charInComment;+        cs <- comment';+        return $ c:cs; +    }) <|>+    (do { +        char '-';+        (do {+            try $ string "->";+            return "";+        }) <|>+        (do {+            c <- charInComment;+            cs <- comment';+            return $ c:cs;+        });+    });++charInComment = +   (char '\t' <|> char '\n' <|> char '\r' <|> +   satisfy (\c -> c >= ' ' && c /= '-')) <?> "character";+++-- 2.6 / 16+pI = notImplemented >> return "";+++-- 2.7 / 18+cdSect = notImplemented >> return "";+++-- 2.8 / 22+prolog = do {+    option ("UTF-8", False) xmlDecl;+    many misc;+    option [[]] (docTypeDecl >> many misc);+    return ();+};+++-- 2.8 / 23+xmlDecl = do {+  try $ string "<?xml" ;+  versionInfo ;+  enc <- option [] encodingDecl ;+  sdd <- option False sDDecl ;+  s0;+  string "?>" ;+  return (enc, sdd)+};++-- 2.7 / 24+versionInfo = do {+  s ;+  string "version";+  eq ;+  ( do {char '\"'; versionNum; char '\"' } <|>+    do {char '\''; versionNum; char '\'' } );+};++-- 2.8 / 25+eq = do { s0; char '='; s0; };++-- 2.8 / 26+versionNum = string "1.0" ;++-- 2.8 / 27+misc = comment <|> pI <|> s;+++-- 2.8 / 28+-- [28] doctypedecl ::=+--        '<!DOCTYPE' S Name (S ExternalID)? S? ('[' intSubset ']' S?)? '>'+docTypeDecl = do{+  try $ string "<!DOCTYPE";+  s;+  name;+  option [] (do {s; externalID;});+  s0;+  option [] (do {char '[';intSubset; char ']'; s0; });+  char '>';+};++-- 2.8 / 28b+-- [28b]    intSubset    ::=    (markupdecl | DeclSep)*+intSubset = notImplemented;++-- 2.9 / 32+sDDecl = do {+  s;+  string "standalone";+  eq;+  ( do {char '\"'; x <- yesNo; char '\"'; return x; } <|>+    do {char '\''; x <- yesNo; char '\''; return x; } ) ;+};++yesNo = do {string "yes"; return True;} <|> do {string "no" ; return False;};++-- 3 / 39, 3.1 / 40, 3.1 / 42, 3.1 / 44+element :: Bool -> Parser Element;+element toplevel = do {+    name <- try $ do { char '<'; name };+    attrs <- attributes False;+    (do {+        char '>';+        content <- content False;+        try $ do { string "</"; string name; s0; char '>'; };+        return $ Element (setMode toplevel) name attrs content False;+    }) <|>+    (do {+        try $ string "/>";+        return $ Element (setMode toplevel) name attrs [] True;+    })+} <|> do {+    try $ do { string "<%@" };+    s;+    string "include";+    s;+    AText filename <- attValue;+    s;+    subs <- substitutions;+    string "%>";+    let { str = openFile filename; } ;+    return $ +      case parse xmlfile filename str of {+	Left err ->+	  Element (setMode toplevel) "include-failed" +		  [Attribute (setMode toplevel) "file" (AText filename)]+		  [CText (Text (setMode toplevel) (show err))]+		  True;+	Right file ->+	  topElem file;+	}+} <?> "element";++attributes :: Bool -> Parser [Attribute];+attributes toplevel = do { s; attributes' toplevel; } <|> return [];++attributes' :: Bool -> Parser [Attribute];+attributes' toplevel = do { a <- attribute toplevel;+			    as <- attributes toplevel;+			    return (a:as);+			  }+		       <|> return [];++-- 3.1 / 41+attribute :: Bool -> Parser Attribute;+attribute toplevel = try (+  do { string "<%" ;+       pat <- hCode ;+       string "%>" ;+       return $ AttrPattern pat ;+    }+<|> +  do {+    name <- name;+    eq;+    value <- attValue;+    return $ Attribute (setMode toplevel) name value;+  }+) <?> "attribute";+++-- 3.1 / 43+content :: Bool -> Parser [Content];+content toplevel = many (+        (element toplevel  >>= (return . CElement))+    <|> (charData toplevel  >>= (return . CText))+    <|> (haskellText>>= (return . CCode))+    <|> (haskell   >>= (return . CCode))+    <|> (reference >>= (return . CReference . Text (setMode toplevel)))+    <|> (cdSect    >>  (return undefined))+    <|> (pI        >>= (return . CPI))+    <|> (comment   >>= (return . CComment))+);+++-- 4.1 / 66, 4.1 / 68+reference = do {+    char '&';+    r <- (do { +        char '#';+        r <- many1 digit <|> +            do { char 'x'; r <- many1 hexDigit; return $ 'x':r; };+        return $ '#':r;+    }) <|> name;+    char ';';+    return $ "&" ++ r ++ ";";+} <?> "reference";++-- 4.2.2 / 75+-- [75]    ExternalID    ::=    'SYSTEM' S SystemLiteral+--                            | 'PUBLIC' S PubidLiteral S SystemLiteral+externalID = do{+  string "SYSTEM";+  s;+  systemLiteral;+} <|>+do {+  string "PUBLIC";+  s;+  pubidLiteral;+  s;+  systemLiteral;+};++-- 4.3 / 80+encodingDecl = do {+  s;+  string "encoding";+  eq;+  ( do {char '\"'; x <- encName; char '\"'; return x;} <|>+    do {char '\''; x <- encName; char '\''; return x;});+};++-- 4.3 / 81+-- [81]    EncName    ::=    [A-Za-z] ([A-Za-z0-9._] | '-')*+encName = do {+  c <- satisfy (\c -> c >= 'A' && c <= 'Z' || c >= 'a' && c <= 'z') ;+  cs <- many (satisfy (\c -> c >= 'A' && c <= 'Z' +		          || c >= 'a' && c <= 'z'+			  || c >= '0' && c <= '9'+			  || c `elem` "._-"));+  return (c:cs)+};++-- B / 84+letter = baseChar <|> ideographic;++-- B / 85+baseChar = +    satisfy (\c -> +        (c >= '\x41' && c <= '\x5a') || +        (c >= '\x61' && c <= '\x7a') || +        (c >= '\xc0' && c <= '\xd6') || +        (c >= '\xd8' && c <= '\xf6') || +        (c >= '\xf8' && c <= '\xff')); -- and some Unicode characters++-- B / 86+ideographic = notImplemented;++-- B / 87+combiningChar = notImplemented;++-- B / 88+--digit = digit; -- and some Unicode characters++-- B / 89+extender = char '\xb7'; -- and some Unicode characters+++haskell :: Parser [CodeFrag];+haskell = do {+    try $ string "<%";+    frags <- hStmt <|> hBody;+    try $ string "%>";+    return frags;+};++hIdentChar = letter <|> digit <|> char '\'' <|> char '_';++hStmt :: Parser [CodeFrag];+hStmt = do {+    var <- try $ do { s0 ;+		      v0 <- letter ;+		      vr <- many hIdentChar ;+		      s0 ;+		      string "<-" ;+		      return (v0:vr)+		    };+    body <- hBody ;+    return (VFrag var : body)+};++hBody :: Parser [CodeFrag];+hBody = many (+            (hCode >>= (return . HFrag))+        <|> (element True >>= (return . EFrag))+        <|> (nakedAttributes >>= (return . AFrag))+        <|> (nakedContent >>= (return . CFrag))+    );++nakedAttributes = do {+    s0 ;+    try $ string "<[" ;+    s0 ;+    attrs <- attributes' True ;+    try $ string "]>" ;+    return attrs;+};++nakedContent = do {+    try $ string "<#>" ;+    cnts <- content True ;+    try $ string "</#>";+    return cnts;+};++haskellAttr :: Parser String;+haskellAttr = haskellUnnested "<%";++haskellText :: Parser [CodeFrag];+haskellText = do {+  str <- haskellUnnested "<%=";+  return [HFrag "text(", HFrag str, HFrag ")"]+};++haskellUnnested :: String -> Parser String;+haskellUnnested start = do {+    try $ string start;+    code <- hCode;+    try $ string "%>";+    return code;+} <?> "haskell code";++hCode = try $ do { sp <- getPosition;+		   str <- hcode' '%' (not . (`elem` "#[%"));+		   return (reindent (sourceColumn sp - 1) str);+		 };+hPatt = try $ hcode' '#' (const True);++reindent :: Int -> String -> String;+reindent 0 str = '\n':str;+reindent n str = reindent (n-1) (' ':str);++hSinglePatt = try $ do {+    s0 ;+    char '[' ;+    id <- name ;+    char ']' ;+    s0 ;+    return id ;+} ;+    ++hcode' escChar patC = +  let stopChars = escChar : "<\"" in+  do { +    t <- many1 $ (  hcNorm stopChars+                <|> hcString+                <|> hcIsTag patC+                <|> hcIsEnd escChar ) ;+    return $ concat t+};++hcNorm stopChars = try . many1 $ noneOf stopChars;++hcString = try $ do {+    char '\"' ;+    strs <- many ((many1 $ noneOf "\"\\")+              <|> (char '\\' >> (+		   (do x <- satisfy (not . isSpace)+		       return ['\\',x])+ 	       <|> (do xs <- many1 $ satisfy isSpace+		       char '\\'+		       return ('\\' : xs ++ "\\"))))) ;+    char '\"' ;+    return ('\"' : concat strs ++ "\"")+};++hcIsTag patC = try $ do { +    char '<' ;+    t <- satisfy (\c -> (not.isAlpha $ c) && patC c) ;+    return ('<':t:[]) ;+};++hcIsEnd escChar = try $ do { +    char escChar ;+    t <- satisfy (/='>') ;+    return (escChar:t:[]) ;+};++-- experimental+substitutions = return [];++}
+ cabal/cabal/tests/systemTests/wash2hs/hs/WASHUtil.hs view
@@ -0,0 +1,82 @@+module WASHUtil 
+    ( normalize
+    , outList
+    , itemList
+    , openFile
+    ) where {
+
+import System.IOExts ;
+import WASHData ;
+
+itemList :: (item -> ShowS) -> String -> String -> [item] -> ShowS ;
+itemList showsItem empty glue items =
+  f items 
+  where { f []     = showString empty ;
+	  f [item] = showsItem item ;
+	  f (item:items) = showsItem item . showString glue . f items ;
+	};
+
+
+normalize :: [Content] -> [Content] ;
+normalize xs = shortContent.dropEmpty $ xs ;
+
+dropEmpty :: [Content] -> [Content] ;
+dropEmpty [] = [] ;
+dropEmpty (c:cs) = if isWhite c 
+                   then dropEmpty cs 
+                   else c:(dropEmpty cs);
+
+isWhite :: Content -> Bool ;
+isWhite (CText txt) = and $ map isWhite' (textString txt)
+    where { isWhite' c =  c == ' '
+                       || c == '\n'
+                       || c == '\t'
+                       || c == '\r' ;
+    } ;
+isWhite _ = False;
+
+hasText :: Content -> Bool;
+hasText (CText {}) = True ;
+hasText (CReference {}) = True ;
+hasText _ = False ;
+
+textOf :: Content -> Text;
+textOf (CText t) = t;
+textOf (CReference t) = t;
+textOf c = error ("textOf " ++ show c);
+
+joinable :: Text -> Text -> Bool;
+joinable t1 t2 = g (textMode t1) (textMode t2)
+  where { g S F = True;
+	  g S S = False;
+	  g F F = True;
+	  g V V = True;
+	  g _ _ = False;
+	};
+
+joinText :: Text -> Text -> Text;
+joinText t1 t2 = Text (textMode t1) (textString t1 ++ textString t2);
+
+shortContent :: [Content] -> [Content] ;
+shortContent [] = [] ;
+shortContent (CPI pi:cs) = shortContent cs ;
+shortContent (CComment c:cs) = shortContent cs ;
+shortContent (c1:c2:cs) | hasText c1 && hasText c2 =
+	     let { t1 = textOf c1 ; t2 = textOf c2 } in
+	     if joinable t1 t2 then shortContent (CText (joinText t1 t2):cs)
+			       else c1:shortContent (c2:cs);
+shortContent (c:cs) = c:shortContent cs ;
+
+outList :: [String] -> String ;
+outList xs = "[" ++ (outList' $ filter (/= []) xs) ++ "]" ;
+
+outList' ([])     = "" ;
+outList' (x:y:[]) = x ++ ", " ++ y ;
+outList' (x:y:xs) = x ++ ", " ++ outList' (y:xs) ;
+outList' (x:[])   = x ;
+outList' _        = error "ERROR: in processing showList" ;
+
+openFile :: String -> String ;
+openFile fname = unsafePerformIO (readFile fname) ;
+
+}

+ cabal/cabal/tests/systemTests/wash2hs/test/Counter.wash view
@@ -0,0 +1,19 @@+-- © 2001, 2002 Peter Thiemann+module Main where++import Prelude hiding (map, span, head, div)+import CGI++main = +  run $ counter 0++dialog = "dialog"++counter n =+  standardQuery "Counter" $+  <p class=<% dialog %> >Current counter value <% text (show n) %>+     <br />+     <% submit0 (counter (n + 1)) <[value="Increment"]> %>+     <% submit0 (counter (n - 1)) <[value="Decrement"]> %>+  </p>+
+ cabal/cabal/tests/systemTests/wash2hs/test/ManuelsTable.wash view
@@ -0,0 +1,45 @@+module Main where++import Prelude hiding (map, span, head, div)+import CGI++{-- +    ms> -----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----+    ms> (define (fact n)+    ms>    (if (= n 0)+    ms>        1+    ms>        (* n (fact (- n 1)))))++    ms> (define (make-fact-row n)+    ms>    (tr (td :align 'center (bold n))+    ms>        (td :align 'right (it (fact n)))))++    ms> (define (make-fact-table n)+    ms>    (apply table :border 1+    ms> 	  (tr (th "n=") (th "fact"))+    ms> 	  (map make-fact-row (upto 3 n))))++    ms> (font :size -1 (make-fact-table 11))+    ms> -----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----|-----+-}++fact n =+  if n == 0+     then 1+     else n * fact (n - 1)++makeFactRow n =+  <tr>+    <td align="center"><b> <%= show n %> </b></td>+    <td align="right"><i> <%= show (fact n) %> </i></td>+  </tr>++makeFactTable n =+  <table border="1">+    <tr><th>n=</th> <th>fact</th></tr>+    <% mapM makeFactRow [3..n] %>+  </table>++main = +  run $ standardQuery "FactTable" $+  <font size="-1"><% makeFactTable 11 %></font>
+ cabal/cabal/tests/systemTests/wash2hs/test/Tutorial.wash view
@@ -0,0 +1,241 @@+-- © 2002 Peter Thiemann+module Main where++import CGI hiding (head, div, span, map)+import qualified CGI+import Random+import qualified Persistent2 as P+import qualified Cookie as C+import Types -- for nhc98 ++main = +  run helo0+++-- +helo0 =+  standardQuery "Select an Example" $+  activate exAction (selectSingle exName Nothing examples) <#> </#>+--  do exampleF <- selectSingle exName Nothing examples <#> </#>+--     submit exampleF dispatch (attr "value" "GO")++data Example = Example {exName :: String, exAction :: CGI ()}+instance Eq Example where+  e1 == e2 = exName e1 == exName e2+examples = +	[Example "Simple Hello World" helo1+	,Example "Hello World with a little HTML" helo2+	,Example "Hello World with a little Color" helo4+	,Example "Hello World Personalized" helo5+	,Example "Multiplication Table" helo6+	,Example "Multiplication Drill" helo7+	,Example "Multiplication Drill with Selection Box" helo8+	,Example "Multiplication Drill with Radio Buttons" helo9+	,Example "Multiplication Drill with Email Address" helo10+	,Example "Multiplication Drill with Cookies" helo11+	]++-- ++helo1 = ask $+	standardPage "Hello" $+	<#>This is my first CGI program!</#>++-- +helo2 = ask $+	standardPage "Hello" $+	do <p>This is my second CGI program!</p>+	   <p>My hobbies are+		 <ul> <li>swimming</li>+		      <li>music</li>+		      <li>skiing</li>+                 </ul>+	   </p>+-- ++fgRed = "color" :=: "red"+bgGreen = "background" :=: "green"+styleImportant = fgRed :^: bgGreen++important x = using styleImportant x++helo4 = ask $+	standardPage "Hello" $+	important <p>This is important!</p>++-- ++helo5 = standardQuery "What's your name?" $+  <#>Hi there! What's your name? <%+     activate greeting textInputField empty %>+  </#>++greeting :: String -> CGI ()+greeting name =+  standardQuery "Hello" $+  <p>Hello <%= name %>. This is my first interactive CGI program!</p>++-- ++helo6 = standardQuery "What's your name?" $+  <p>Hi there! What's your name?+	<% activate mtable textInputField empty %>+  </p>++mtable name =+  standardQuery "Multiplication Table" $+  do <p>Hello <%= name %> ! </p>+     <p>Let's see a multiplication table! </p>+     <p>Give me a multiplier <% activate ptable inputField empty %> </p>++ptable :: Int -> CGI ()+ptable mpy =+  standardQuery "Multiplication Table" $+  <table> <% mapM_ pLine [1..12] %> </table>+  where+    align = <[ align="right" ]>+    pLine i = <tr><td> <%= (show i) %> <% align %> </td>+		  <td>*</td>+		  <td> <%= (show mpy) %> </td>+		  <td>=</td>+		  <td> <%= (show (i * mpy)) %> <% align %> </td>+              </tr>++-- ++helo7 = standardQuery "What's your name?" $+  p (do text "Hi there! What's your name?"+	activate mdrill textInputField empty)++mdrill name =+  standardQuery "Multiplication" $+  <#>+     <p>Hello <%= name %>!</p>+     <p>Let's exercise some multiplication!</p>+     <p>Give me a multiplier <% mpyF <- inputField <[value="2"]> %> </p>+     <p>Number of exercises  <% rptF <- inputField <[value="10"]> %> </p>+     <% submit (F2 mpyF rptF) (firstExercise name) empty %>+  </#>++firstExercise name (F2 mpyF rptF) = +  runExercises 1 [] []+  where+    mpy, rpt :: Int+    mpy = CGI.value mpyF+    rpt = CGI.value rptF+-- +    runExercises nr successes failures =+      if nr > rpt then +        finalReport+      else+        do factor <- io (randomRIO (0,12))+	   standardQuery ("Question " ++ show nr ++ " of " ++ show rpt) $+	     do text (show factor ++ " * " ++ show mpy ++ " = ")+		activate (checkAnswer factor) inputField empty+      where+	checkAnswer factor answer =+          let correct = answer == factor * mpy +	      message = if correct then "correct! " else "wrong! "+	      continue = if correct then +	      		      runExercises (nr+1) (factor:successes) failures+			 else+			      runExercises (nr+1) successes (factor:failures)+	  in standardQuery ("Answer " ++ show nr ++ " of " ++ show rpt) $+	  do p (text (show factor ++ " * " ++ show mpy ++ " = " ++ show (factor * mpy)))+	     text ("Your answer " ++ show answer ++ " was " ++ message)+	     submit0 continue <[value="CONTINUE"]>+-- +	finalReport =+	  let lenSucc = length successes +	      pItem (m, l, r) = li (text ("Multiplier " ++ show m +++	                              " : " ++ show l +++				      " correct out of " ++ show r))+	  in+	  do initialHandle <- P.init ("multi-" ++ name) []+	     currentHandle <- P.add initialHandle (mpy, lenSucc, rpt)+	     hiScores <- P.get currentHandle+	     standardQuery "Final Report" $ +	       <p>Here are your recent scores.+		  <ul> <% mapM_ pItem hiScores %> </ul>+               </p>+-- ++helo8 = standardQuery "What's your name?" $+  p (do text "Hi there! What's your name?"+	activate mdrillSelect textInputField empty)++mdrillSelect name =+  standardQuery "Multiplication" $+  <#><p>Hello <%= name %>!</p>+     <p>Let's exercise some multiplication!</p>+     <p>Give me a multiplier+	<% mpyF <- selectSingle show Nothing [2..12] empty %></p>+     <p>Number of exercises+        <% rptF <- inputField <[value="10"]> %> </p>+     <% submit (F2 mpyF rptF) (firstExercise name) empty %>+  </#>+-- ++helo9 = standardQuery "What's your name?" $+  p (do text "Hi there! What's your name?"+	activate mdrillRadio textInputField empty)++mdrillRadio name =+  standardQuery "Multiplication" $+  <#>+    <p>Hello <%= name %>!</p>+    <p>Let's exercise some multiplication!</p>+    <p>Give me a multiplier+       <% mpyF <- selectSingle show Nothing [2..12] empty %></p>+    <% rptF <- radioGroup %>+    <p>Number of exercises+         5 <% radioButton rptF 5 empty %>+	10 <% radioButton rptF 10 empty %>+	20 <% radioButton rptF 20 empty %>+	<% radioError rptF %>+    </p>+    <% submit (F2 mpyF rptF) (firstExercise name) empty %>+  </#>++-- ++helo10 = standardQuery "What's your name?" $+  p (do text "Hi there! What's your email address?"+	activate mdrillEmail inputField empty+	-- inf <- inputField empty+	-- submit inf mdrillEmailHandle empty+	)++mdrillEmailHandle emailH =+  mdrillEmail (value emailH)+mdrillEmail email =+  let name = unEmailAddress email in+  standardQuery "Multiplication" $+  do p (text ("Hello " ++ name ++ "!"))+     p (text "Let's exercise some multiplication!")+     mpyF <- p (text "Give me a multiplier " >>+                selectSingle show Nothing [2..12] empty)+     rptF <- p (text "Number of exercises " >>+                inputField (attr "value" "10"))+     submit (F2 mpyF rptF) (firstExercise name) empty++-- ++helo11 = +  C.check "name" >>= \mNameH ->+  case mNameH of+    Nothing ->+      standardQuery "What's your name?" $+        p (do text "Hi there! What's your name?"+	      activate mdrillCookie textInputField empty)+    Just nameC ->+      do mname <- C.get nameC+	 case mname of+	   Nothing ->+	     helo11					    -- retry if outdated+	   Just name ->+	     mdrill name++mdrillCookie name =+  do C.create "name" name+     mdrill name
+ cabal/cabal/tests/systemTests/wash2hs/wash2hs.cabal view
@@ -0,0 +1,14 @@+Name: Wash-2hs+Version: 1.4.34+License: BSD3+Build-Depends: base, text, lang+copyright: filler for test suite+maintainer: filler for test suite+synopsis: filler for test suite++executable: wash2hs+hs-source-dir: hs+Other-Modules: WASHClean,  WASHExpression,  WASHGenerator,  WASHOut,+                WASHData,   WASHFlags,       WASHMain,       WASHParser,+                WASHUtil+main-is: WASHMain.hs
+ cabal/cabal/tests/systemTests/withHooks/C.testSuffix view
@@ -0,0 +1,4 @@+module C where+a = 42 :: Int++main2 = print a
+ cabal/cabal/tests/systemTests/withHooks/D.gc view
@@ -0,0 +1,4 @@+module D where+a = 42 :: Int++main2 = print a
+ cabal/cabal/tests/systemTests/withHooks/Main.hs view
@@ -0,0 +1,3 @@+module Main where++main = putStrLn "Happy New Year!"
+ cabal/cabal/tests/systemTests/withHooks/Makefile view
@@ -0,0 +1,1 @@+include ../Tests.mk
+ cabal/cabal/tests/systemTests/withHooks/Setup.buildinfo.in view
@@ -0,0 +1,5 @@+include-dirs: /tmp, /etc+extensions: CPP++executable: withHooks+extensions: TemplateHaskell
+ cabal/cabal/tests/systemTests/withHooks/Setup.lhs view
@@ -0,0 +1,78 @@+#!/usr/bin/runhugs++> module Main where++> import Distribution.Simple+> import Distribution.PackageDescription (PackageDescription,+>                                         readPackageDescription, readHookedBuildInfo)+> import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..))+> import Distribution.Setup(CopyFlags(..), CopyDest(..), ConfigFlags(..))+> import Distribution.Compat.Directory (copyFile)+> import Distribution.Compat.FilePath(joinPaths)+> import Distribution.Simple.Utils (defaultHookedPackageDesc)+> import Distribution.Program(simpleProgram, rawSystemProgramConf)+> import System.Directory (removeFile, createDirectoryIfMissing)+> import System.Exit(ExitCode(..))+> import Control.Monad(when)+> import Data.Maybe(fromJust, isNothing)++ myPreConf :: Args -> ConfigFlags -> IO HookedBuildInfo++> myPreConf (h:_) flags = do+>                        when (h /= "--woohoo")+>                             (error "--woohoo flag (for testing) not passed to ./setup configure.")+>                        copyFile "Setup.buildinfo.in" "Setup.buildinfo"+>                        m <- defaultHookedPackageDesc+>                        when (isNothing m) (error "can't open hooked package description!")+>                        readHookedBuildInfo (configVerbose flags) (fromJust m)+>+> myPreConf [] _ = error "--woohoo flag (for testing) not passed to ./setup configure."++> ppTestHandler :: a -> b -> FilePath -- ^InFile+>               -> FilePath -- ^OutFile+>               -> Int      -- ^verbose+>               -> IO ExitCode+> ppTestHandler _ _ inFile outFile verbose+>     = do when (verbose > 0) $+>            putStrLn (inFile++" has been preprocessed as a test to "++outFile)+>          stuff <- readFile inFile+>          writeFile outFile ("-- this file has been preprocessed as a test\n\n" ++ stuff)+>          return ExitSuccess++> testing :: Args -> Bool -> a -> b -> IO ExitCode+> testing [] _ _ _ = return ExitSuccess+> testing a@(h:_) _ _ _ = do putStrLn $ "testing: " ++ (show a)+>                            if h == "--pass"+>                               then return ExitSuccess+>                               else return (ExitFailure 1)++> myCopyHook :: PackageDescription+>            -> LocalBuildInfo+>            -> Maybe UserHooks+>            -> CopyFlags -- ^install-prefix, verbose+>            -> IO ()+> myCopyHook a b c d@(CopyFlags (CopyPrefix p) _) = do+>   -- call 'ls' from our hookedPrograms hook... pointless except as a demo+>   rawSystemProgramConf 0 "ls" (withPrograms b) []+>   let copySource = case compilerFlavor $ compiler b of+>        GHC  -> foldl1 joinPaths ["dist", "build", "withHooks", "withHooks"]+>        Hugs -> foldl1 joinPaths ["dist", "build", "Main.hs"] -- some random file+>   createDirectoryIfMissing True p+>   copyFile copySource (p `joinPaths` "withHooks")++>   -- now call the default copy hook so the rest of the test case works nice ... so tricky ;)+>   (copyHook defaultUserHooks) a b c d+> myCopyHook _ _ _ _ = error "Please use --copy-prefix."++Override "gc" to test the overriding mechanism.++> main :: IO ()+> main = defaultMainWithHooks defaultUserHooks+>        {preConf=myPreConf,+>         hookedPrograms=[simpleProgram "ls"],+>         runTests=testing,+>         postConf=(\_ _ _ _ -> return ExitSuccess),+>         hookedPreProcessors=  [("testSuffix", ppTestHandler), ("gc", ppTestHandler)],+>         postClean=(\_ _ _ _ -> removeFile "Setup.buildinfo" >> return ExitSuccess),+>         copyHook=myCopyHook+>        }
+ cabal/cabal/tests/systemTests/withHooks/WithHooks.hs view
@@ -0,0 +1,3 @@+module WithHooks where++f = 34
+ cabal/cabal/tests/systemTests/withHooks/withHooks.cabal view
@@ -0,0 +1,11 @@+Name: withHooks+Version: 1.0+copyright: filler for test suite+maintainer: filler for test suite+synopsis: filler for test suite+build-depends: base+exposed-modules: Main, C, D++Executable: withHooks+Other-Modules: Main+Main-is: Main.hs
+ cabal/ghc-packages view
@@ -0,0 +1,2 @@+cabal+
hackport.cabal view
@@ -1,5 +1,5 @@ Name:           hackport-Version:	0.2.13+Version:	0.2.14 License:	GPL License-file:   LICENSE Author:		Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -20,7 +20,7 @@ Executable	hackport   Main-Is:	Main.hs   Default-Language: Haskell98-  Hs-Source-Dirs: ., cabal-install-0.9.5_rc20101226+  Hs-Source-Dirs: ., cabal/cabal, cabal/cabal-install   Build-Depends:     base >= 2.0 && < 5,     filepath,@@ -29,15 +29,14 @@     network,     pretty,     regex-compat,-    Cabal == 1.10.*,     HTTP >= 4000.0.3,     zlib,     tar,     xml>1.3.5,     array,-  -- array is inherited from cabal-install -  -- tar >= 0.3.0.0 && < 0.4-    extensible-exceptions+    extensible-exceptions,+    -- cabal depends+    unix    -- extensions due to hackport   other-extensions:@@ -72,7 +71,6 @@     Paths_hackport     Main     Overlays-    Portage     Portage.Version     Portage.Dependency     Portage.GHCCore@@ -101,7 +99,6 @@     network,     pretty,     regex-compat,-    Cabal > 1.8 && < 1.11,     HTTP >= 4000.0.3,     zlib,     tar,