packages feed

hackport 0.2.1 → 0.2.6

raw patch · 77 files changed

+15313/−1236 lines, 77 filesdep +arraydep +extensible-exceptionsdep +prettydep ~Cabaldep ~HTTPdep ~base

Dependencies added: array, extensible-exceptions, pretty

Dependency ranges changed: Cabal, HTTP, base

Files

− Action.hs 
@@ -1,121 +0,0 @@-module Action where--import Config-import Error--import Control.Monad.State-import Control.Monad.Error-import Network.URI (parseURI)-import System.IO-import System.Environment--type HPAction = ErrorT HackPortError (StateT HPState IO)--data HPState = HPState-	{ config :: Config-	, indention :: Int-	}--verbose :: HPAction a -> (String,a->String) -> HPAction a-verbose action (premsg,postmsg) = do-	echoIndent-	echo premsg-	flush-	res <- indent action-	echoLn (postmsg res)-	return res--sayNormal :: HPAction a -> (String,a->String) -> HPAction a-sayNormal action strs = do-	cfg <- getCfg-	case verbosity cfg of-		Silent -> action-		_ -> action `verbose` strs--sayDebug :: HPAction a -> (String,a->String) -> HPAction a-sayDebug action strs = do-	cfg <- getCfg-	case verbosity cfg of-		Debug -> action `verbose` strs-		_ -> action--info :: String -> HPAction ()-info str = do-	cfg <- getCfg-	case verbosity cfg of-		Silent -> return ()-		_ -> echoLn str---- | Prints a string iff in debug output mode-whisper :: String -> HPAction ()-whisper str = do-	cfg <- getCfg-	case verbosity cfg of-		Debug -> echoLn str-		_ -> return ()--getCfg :: HPAction Config-getCfg = gets config--setOverlayPath :: Maybe String -> HPAction ()-setOverlayPath mt = modify $ \hps ->-    hps { config = (config hps) { overlayPath = mt } }--setPortagePath :: Maybe String -> HPAction ()-setPortagePath mt = modify $ \hps ->-    hps { config = (config hps) { portagePath = mt } }--lessIndent :: HPAction ()-lessIndent = modify $ \s -> s { indention = indention s - 1 }--moreIndent :: HPAction ()-moreIndent = modify $ \s -> s { indention = indention s + 1 }--echoIndent :: HPAction ()-echoIndent = do-	ind <- gets indention-	echo (replicate ind '\t')--indent :: HPAction a -> HPAction a-indent action = do-	moreIndent-	res <- action-	lessIndent-	return res--echo :: String -> HPAction ()-echo str = liftIO $ hPutStr stderr str--flush :: HPAction ()-flush = liftIO (hFlush stderr)--echoLn :: String -> HPAction ()-echoLn str = echoIndent >> echo str >> liftIO (hPutChar stderr '\n')--loadConfig :: HPAction OperationMode-loadConfig = do-	args <- liftIO getArgs-	case parseConfig args of-		Left errmsg -> throwError (ArgumentError errmsg)-		Right (opts,opmode) -> do-			cfg <- foldM optionToConfig defaultConfig opts-			modify $ \s -> s { config = cfg }-			return opmode--optionToConfig :: Config -> HackPortOptions -> HPAction Config-optionToConfig cfg opt = case opt of-	OverlayPath str -> return cfg { overlayPath = Just str }-        PortagePath str -> return cfg { portagePath = Just str }-	Server str -> case parseURI str of-		Nothing -> throwError (InvalidServer str)-		Just uri -> return cfg { server = uri }-	TempDir str -> return cfg { tmp = str }-	Verbosity str -> case parseVerbosity str of-		Nothing -> throwError (UnknownVerbosityLevel str)-		Just verb -> return cfg { verbosity=verb }-	Help -> return cfg-        RefreshCache -> return cfg { refreshCache = True }--performHPAction :: HPAction a -> IO (Either HackPortError a)-performHPAction action =-    evalStateT (runErrorT action) (HPState defaultConfig 0)
− Bash.hs 
@@ -1,45 +0,0 @@-module Bash where--import Control.Monad.Error-import System.Process-import System.Directory-import System.IO-import System.Exit--import Action-import Config-import Error--getSystemPortdir :: HPAction String-getSystemPortdir = do-    dir <- runBash "source /etc/make.conf;echo -n $PORTDIR"-    case dir of-        "" -> return "/usr/portage"-        _ -> return dir--getPortdir :: HPAction String-getPortdir = do-    cfg <- getCfg-    case portagePath cfg of-        Just dir -> return dir-        Nothing -> do-            sys <- getSystemPortdir-            setPortagePath (Just sys)-            return sys--runBash ::-	String -> -- ^ The command line-	HPAction String -- ^ The command-line's output-runBash command = do-	mpath <- liftIO $ findExecutable "bash"-	bash <- maybe (throwError BashNotFound) return mpath-	(inp,outp,err,pid) <- liftIO $ runInteractiveProcess bash ["-c",command] Nothing Nothing-	liftIO $ hClose inp-	result <- liftIO $ hGetContents outp-	errors <- liftIO $ hGetContents err-	length result `seq` liftIO (hClose outp)-	length errors `seq` liftIO (hClose err)-	exitCode <- liftIO $ waitForProcess pid-	case exitCode of-		ExitFailure _ -> throwError $ BashError errors-		ExitSuccess   -> return result
BlingBling.hs view
@@ -1,15 +1,52 @@ module BlingBling where +import qualified Progress+ import System.IO+import Control.Exception as Exception (bracket)  -- what nobody needs but everyone wants...  -- FIXME: do something more fun here forMbling :: [a] -> (a -> IO b) -> IO [b]-forMbling lst f = do-    origBuffering <- hGetBuffering stdout-    hSetBuffering stdout NoBuffering+forMbling lst f =+  withBuffering stdout NoBuffering $ do     xs <- mapM (\x -> putStr "." >> f x) lst     putStrLn ""-    hSetBuffering stdout origBuffering     return xs++blingProgress :: Progress.Progress s String a -> IO a+blingProgress progress = do+  isTerm <- hIsTerminalDevice stdout+  if isTerm+    then canIHasTehBling+    else boring++  where+    boring = Progress.fold (flip const) fail return progress++    canIHasTehBling =+      withBuffering stdout NoBuffering $ do+        putChar (fst (char 0))+        result <- spin 0 progress+        putStr "\b \b"+        return result++    spin _ (Progress.Fail e) = fail e+    spin _ (Progress.Done r) = return r+    spin n (Progress.Step _ p) = do+        putStr ['\b', c]+        spin n' p+      where (c, n') = char n++    char :: Int -> (Char, Int)+    char 0 = ('/',  1)+    char 1 = ('-',  2)+    char 2 = ('\\', 3)+    char _ = ('|',  0)++withBuffering :: Handle -> BufferMode -> IO a -> IO a+withBuffering hnd mode action =+  Exception.bracket+    (hGetBuffering hnd) (hSetBuffering hnd)+    (\_ -> hSetBuffering hnd mode >> action)
Cabal2Ebuild.hs view
@@ -23,22 +23,25 @@ -- module Cabal2Ebuild         (EBuild(..)+        ,Dependency(..)         ,cabal2ebuild+        ,convertDependencies         ,showEBuild) where  import qualified Distribution.PackageDescription as Cabal                                                 (PackageDescription(..))-import qualified Distribution.Package as Cabal  (PackageIdentifier(..), Dependency(..))-import qualified Distribution.Version as Cabal  (VersionRange(..), versionBranch, Version)+import qualified Distribution.Package as Cabal  (PackageIdentifier(..)+                                                , Dependency(..)+                                                , PackageName(..))+import qualified Distribution.Version as Cabal  (VersionRange, foldVersionRange', versionBranch, Version) import qualified Distribution.License as Cabal  (License(..)) import qualified Distribution.Text as Cabal  (display)---import qualified Distribution.Compiler as Cabal (CompilerFlavor(..))  import Data.Char          (toLower,isUpper)-import Data.List          (intercalate, groupBy, partition, nub, sortBy, init, last)-import Data.Ord           (comparing)-import Data.Maybe         (catMaybes, fromJust) +import Portage.Dependency+import Portage.Version+ data EBuild = EBuild {     name :: String,     version :: String,@@ -49,27 +52,19 @@     slot :: String,     keywords :: [String],     iuse :: [String],-    depend :: [Dependency],+    haskell_deps :: [Dependency],+    build_tools :: [Dependency],+    extra_libs :: [Dependency],+    cabal_dep :: Dependency,+    ghc_dep :: Dependency,+    depend :: [String],+    rdepend :: [String],     features :: [String],     -- comments on various fields for communicating stuff to the user     licenseComments :: String,     my_pn :: Maybe String --If the package's name contains upper-case   } -type Package = String-newtype Version = Version [Int] deriving (Ord, Eq)-type UseFlag = String-data Dependency = AnyVersionOf               Package-                | ThisVersionOf      Version Package   -- =package-version-                | LaterVersionOf     Version Package   -- >package-version-                | EarlierVersionOf   Version Package   -- <package-version-                | OrLaterVersionOf   Version Package   -- >=package-version-                | OrEarlierVersionOf Version Package   -- <=package-version-                | DependEither Dependency Dependency   -- depend || depend-                | DependIfUse  UseFlag    Dependency   -- use? ( depend )-                | ThisMajorOf        Version Package   -- =package-version*-    deriving Eq- ebuildTemplate :: EBuild ebuildTemplate = EBuild {     name = "foobar",@@ -81,14 +76,18 @@     slot = "0",     keywords = ["~amd64","~x86"],     iuse = [],+    haskell_deps = [],+    build_tools = [],+    extra_libs = [],+    cabal_dep = AnyVersionOf "dev-haskell/cabal",+    ghc_dep = defaultDepGHC,     depend = [],+    rdepend = [],     features = [],     licenseComments = "",     my_pn = Nothing   } -- cabal2ebuild :: Cabal.PackageDescription -> EBuild cabal2ebuild pkg = ebuildTemplate {     name        = map toLower cabalPkgName,@@ -99,29 +98,32 @@     src_uri         = Cabal.pkgUrl pkg,     license         = convertLicense (Cabal.license pkg),     licenseComments = licenseComment (Cabal.license pkg),-    depend          = defaultDepGHC-                    : (simplify_deps $-                         convertDependency (Cabal.Dependency "Cabal"-                                           (Cabal.descCabalVersion pkg))-                        ++ convertDependencies (Cabal.buildDepends pkg)),+    haskell_deps    = simplify_deps $ convertDependencies (Cabal.buildDepends pkg),+    cabal_dep       = head $ convertDependency (Cabal.Dependency (Cabal.PackageName "Cabal")+                                               (Cabal.descCabalVersion pkg)),     my_pn           = if any isUpper cabalPkgName then Just cabalPkgName else Nothing,     features        = features ebuildTemplate-                   ++ (if null (Cabal.executables pkg) then [] else ["bin"])-                   ++ maybe [] (const ["lib","profile","haddock"]) (Cabal.library pkg)+                   ++ (if hasExe then ["bin"] else [])+                   ++ maybe [] (const (["lib","profile","haddock"]+                        ++ if cabalPkgName == "hscolour" then [] else ["hscolour"])+                        ) (Cabal.library pkg) -- hscolour can't colour its own sources   } where-        cabalPkgName = Cabal.pkgName (Cabal.package pkg)+        cabalPkgName = Cabal.display $ Cabal.pkgName (Cabal.package pkg)+        -- hasLib = isJust (Cabal.library pkg)+        hasExe = (not . null) (Cabal.executables pkg)   defaultDepGHC :: Dependency-defaultDepGHC     = OrLaterVersionOf (Version [6,6,1]) "dev-lang/ghc"+defaultDepGHC = OrLaterVersionOf (Version [6,8,1] Nothing [] 0) "dev-lang/ghc"  -- map the cabal license type to the gentoo license string format convertLicense :: Cabal.License -> String-convertLicense Cabal.GPL          = "GPL-2"    -- almost certainly version 2-convertLicense Cabal.LGPL         = "LGPL-2.1" -- probably version 2.1-convertLicense Cabal.BSD3         = "BSD"      -- do we really not-convertLicense Cabal.BSD4         = "BSD"      -- distinguish between these?+convertLicense (Cabal.GPL mv)     = "GPL-" ++ (maybe "2" Cabal.display mv)  -- almost certainly version 2+convertLicense (Cabal.LGPL mv)    = "LGPL-" ++ (maybe "2.1" Cabal.display mv) -- probably version 2.1+convertLicense Cabal.BSD3         = "BSD"+convertLicense Cabal.BSD4         = "BSD-4" convertLicense Cabal.PublicDomain = "public-domain" convertLicense Cabal.AllRightsReserved = ""+convertLicense Cabal.MIT          = "MIT" convertLicense _                  = ""  licenseComment :: Cabal.License -> String@@ -135,46 +137,48 @@ convertDependencies = concatMap convertDependency  convertDependency :: Cabal.Dependency -> [Dependency]-convertDependency (Cabal.Dependency pname _)+convertDependency (Cabal.Dependency pname@(Cabal.PackageName _name) _)   | pname `elem` coreLibs = []      -- no explicit dep on core libs convertDependency (Cabal.Dependency pname versionRange)-  = case versionRange of-      (Cabal.IntersectVersionRanges v1 v2) -> [convert v1, convert v2]-      v                                    -> [convert v]-+  = convert versionRange   where-    ebuildName = "dev-haskell/" ++ map toLower pname--    convert :: Cabal.VersionRange -> Dependency-    convert Cabal.AnyVersion = AnyVersionOf ebuildName-    convert (Cabal.ThisVersion v) = ThisVersionOf (cabalVtoHPv v) ebuildName-    convert (Cabal.LaterVersion v)   = LaterVersionOf (cabalVtoHPv v) ebuildName-    convert (Cabal.EarlierVersion v) = EarlierVersionOf (cabalVtoHPv v) ebuildName-    convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.LaterVersion v2))-      | v1 == v2 = OrLaterVersionOf (cabalVtoHPv v1) ebuildName-    convert (Cabal.UnionVersionRanges (Cabal.ThisVersion v1) (Cabal.EarlierVersion v2))-      | v1 == v2 = OrEarlierVersionOf (cabalVtoHPv v1) ebuildName-    convert (Cabal.UnionVersionRanges r1 r2)-      = DependEither (convert r1) (convert r2)+    -- XXX: not always true, we should look properly for deps in the overlay+    -- to find the correct category+    ebuildName = "dev-haskell/" ++ map toLower (Cabal.display pname)+    convert :: Cabal.VersionRange -> [Dependency]+    convert =  Cabal.foldVersionRange'+             (          [AnyVersionOf                        ebuildName] -- ^ @\"-any\"@ version+            )(\v     -> [ThisVersionOf      (cabalVtoHPv v)  ebuildName] -- ^ @\"== v\"@+            )(\v     -> [LaterVersionOf     (cabalVtoHPv v)  ebuildName] -- ^ @\"> v\"@+            )(\v     -> [EarlierVersionOf   (cabalVtoHPv v)  ebuildName] -- ^ @\"< v\"@+            )(\v     -> [OrLaterVersionOf   (cabalVtoHPv v)  ebuildName] -- ^ @\">= v\"@+            )(\v     -> [OrEarlierVersionOf (cabalVtoHPv v)  ebuildName] -- ^ @\"<= v\"@+{- FIXME -} )(\v1 _  -> [ThisMajorOf        (cabalVtoHPv v1) ebuildName] -- ^ @\"== v.*\"@ wildcard. (incl lower, excl upper)+            )(\r1 r2 -> case (r1,r2) of+                            ([r1'], [r2']) -> [DependEither r1' r2']       -- ^ @\"_ || _\"@ union+                            _              -> error "convertDependency: compound either"+            )(\r1 r2 -> r1 ++ r2+            ) --- converts Cabal versiion type to hackopr version+-- converts Cabal version type to hackport version cabalVtoHPv :: Cabal.Version -> Version-cabalVtoHPv = Version . Cabal.versionBranch--instance Show Version where-    show (Version v) = intercalate "." $ map show v+cabalVtoHPv = (\v -> Version v Nothing [] 0) . Cabal.versionBranch -coreLibs :: [String]-coreLibs =+coreLibs :: [Cabal.PackageName]+coreLibs = map Cabal.PackageName   ["array"   ,"base"---,"bytestring"   --already has ebuild+  ,"bytestring"   -- intentionally no ebuild. use ghc's version+                  -- to avoid dreaded 'diamond dependency' problem   ,"containers"   ,"directory"---,"filepath"     --already has ebuild+  --,"editline"+  ,"filepath"     -- intentionally no ebuild. use ghc's version   ,"ghc"+  ,"ghc-prim"   ,"haskell98"   ,"hpc"          --has ebuild, but only in the overlay+  ,"integer"   ,"old-locale"   ,"old-time"   ,"packedstring"@@ -183,13 +187,14 @@   ,"random"   ,"readline"     --has ebuild, but only in the overlay   ,"rts"+  ,"syb"          -- intentionally no ebuild. use ghc's version   ,"template-haskell"   ,"unix"         --has ebuild, but only in the overlay   ]  showEBuild :: EBuild -> String showEBuild ebuild =-  ss "# Copyright 1999-2008 Gentoo Foundation". nl.+  ss "# Copyright 1999-2010 Gentoo Foundation". nl.   ss "# Distributed under the terms of the GNU General Public License v2". nl.   ss "# $Header:  $". nl.   nl.@@ -213,27 +218,26 @@   ss "KEYWORDS=". quote' (sepBy " " $ keywords ebuild).nl.   ss "IUSE=". quote' (sepBy ", " $ iuse ebuild). nl.   nl.-  ss "DEPEND=". quote' (sepBy "\n\t\t" $ map showDepend $ depend ebuild). nl.+  ( if (not . null . build_tools $ ebuild)+      then ss "BUILDTOOLS=". quote' (sepBy "\n\t\t" $ map showDepend $ build_tools ebuild). nl+      else id+  ).+  ( if (not . null . extra_libs $ ebuild )+      then ss "EXTRALIBS=". quote' (sepBy "\n\t\t" $ map showDepend $ extra_libs ebuild). nl+      else id+  ).+  ( if (not . null . haskell_deps $ ebuild)+      then ss "HASKELLDEPS=". quote' (sepBy "\n\t\t" $ map showDepend $ haskell_deps ebuild). nl+      else id+  ).+  ss "RDEPEND=". quote' (sepBy "\n\t\t" $ rdepend ebuild). nl.+  ss "DEPEND=". quote' (sepBy "\n\t\t" $ depend ebuild). nl.   (case my_pn ebuild of      Nothing -> id      Just _ -> nl. ss "S=". quote ("${WORKDIR}/${MY_P}"). nl)   $ []   where replaceVars = replaceCommonVars (name ebuild) (my_pn ebuild) (version ebuild) -showDepend :: Dependency -> Package-showDepend (AnyVersionOf         p) = p-showDepend (ThisVersionOf      v p) = "~" ++ p ++ "-" ++ show v-showDepend (LaterVersionOf     v p) = ">" ++ p ++ "-" ++ show v-showDepend (EarlierVersionOf   v p) = "<" ++ p ++ "-" ++ show v-showDepend (OrLaterVersionOf   v p) = ">=" ++ p ++ "-" ++ show v-showDepend (OrEarlierVersionOf v p) = "<=" ++ p ++ "-" ++ show v-showDepend (DependEither       dep1 dep2) = showDepend dep1-                                     ++ " || " ++ showDepend dep2-showDepend (DependIfUse        useflag dep@(DependEither _ _)) -                                                = useflag ++ "? " ++ showDepend dep-showDepend (DependIfUse        useflag dep)  = useflag ++ "? ( " ++ showDepend dep++ " )"-showDepend (ThisMajorOf        v p) = "=" ++ p ++ "-" ++ show v ++ "*"- ss :: String -> String -> String ss = showString @@ -294,108 +298,3 @@ 		++[("${PN}",pn)] 		++ maybe [] (\x->[("${MY_PN}",x)]) mypn 		++[("${PV}",pv)]) str---{- Here goes code for dependencies simplification -}--simplify_group_table :: Package ->-                        Maybe Version ->-                        Maybe Version ->-                        Maybe Version ->-                        Maybe Version ->-                        Maybe Version -> [Dependency]---- simplify_group_table p ol       l        e        oe       exact --- 1) trivial cases:-simplify_group_table    p Nothing  Nothing  Nothing  Nothing  Nothing  = error $ p ++ ": unsolvable constraints"-simplify_group_table    p (Just v) Nothing  Nothing  Nothing  Nothing  = [OrLaterVersionOf v p]-simplify_group_table    p Nothing  (Just v) Nothing  Nothing  Nothing  = [LaterVersionOf v p]-simplify_group_table    p Nothing  Nothing  (Just v) Nothing  Nothing  = [EarlierVersionOf v p]-simplify_group_table    p Nothing  Nothing  Nothing  (Just v) Nothing  = [OrEarlierVersionOf v p]-simplify_group_table    p Nothing  Nothing  Nothing  Nothing  (Just v) = [ThisVersionOf v p]---- 2) simplification passes-simplify_group_table    p (Just (Version v1)) Nothing (Just (Version v2)) Nothing Nothing-    -- specian case: >=a-v.N a<v.(N+1)   => =a-v.N*-    | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1) p]-    | otherwise                                        = [OrLaterVersionOf (Version v1) p, EarlierVersionOf (Version v2) p]---- TODO: simplify constraints of type: >=a-v1; > a-v2 and such---- o3) therwise sink:-simplify_group_table    p (Just v)     l@(_)       e@(_)        oe@(_)       exact@(_) =   OrLaterVersionOf v p : simplify_group_table p Nothing  l e oe exact-simplify_group_table    p ol@(Nothing) (Just v)    e@(_)        oe@(_)       exact@(_) =     LaterVersionOf v p : simplify_group_table p ol Nothing e oe exact-simplify_group_table    p ol@(Nothing) l@(Nothing) (Just v)     oe@(_)       exact@(_) =   EarlierVersionOf v p : simplify_group_table p ol l Nothing oe exact-simplify_group_table    p ol@(Nothing) l@(Nothing) e@(Nothing)  (Just v)     exact@(_) = OrEarlierVersionOf v p : simplify_group_table p ol l e Nothing  exact--- already defined earlier--- simplify_group_table    p ol@(Nothing) l@(Nothing) e@(Nothing)  oe@(Nothing) (Just v)  = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing----  >a-v1 >a-v2         => >a-(max v1 v2)--- key idea: all constraints are enforcing constraints, so we can't get--- more, than one interval.-simplify_group :: [Dependency] -> [Dependency]-simplify_group [dep@(AnyVersionOf _package)] = [dep]-simplify_group deps = simplify_group_table package-                                           min_or_later_v   -- >=-                                           min_later_v      -- >-                                           max_earlier_v    -- <-                                           max_or_earlier_v -- <=-                                           exact_this_v     -- ==-    where-          package = fromJust.getPackage $ head deps-          max_earlier_v    = safe_minimum $ map earlier_v deps-          max_or_earlier_v = safe_minimum $ map or_earlier_v deps-          min_later_v      = safe_maximum $ map later_v deps-          min_or_later_v   = safe_maximum $ map or_later_v deps-          exact_this_v     = case catMaybes (map this_v deps) of-                                  []  -> Nothing-                                  [v] -> Just v-                                  xs  -> error $ "too many exact versions:" ++ show xs-          ---          earlier_v (EarlierVersionOf v _p) = Just v-          earlier_v _                       = Nothing--          or_earlier_v (OrEarlierVersionOf v _p) = Just v-          or_earlier_v _                         = Nothing--          later_v (LaterVersionOf v _p) = Just v-          later_v _                     = Nothing--          or_later_v (OrLaterVersionOf v _p) = Just v-          or_later_v _                     = Nothing--          this_v (ThisVersionOf v  _p) = Just v-          this_v _                     = Nothing-          ---          safe_minimum xs = case catMaybes xs of-                                 [] -> Nothing-                                 xs' -> Just $ minimum xs'-          safe_maximum xs = case catMaybes xs of-                                 [] -> Nothing-                                 xs' -> Just $ maximum xs'---- divide packages to groups (by package name), simplify groups, merge again-simplify_deps :: [Dependency] -> [Dependency]-simplify_deps deps = (concatMap (simplify_group.nub) $-                       groupBy cmpPkgName $-                         sortBy (comparing getPackageString) groupable)-                     ++ ungroupable-    where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps-          ---          cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2)-          cmpMaybe (Just p1) (Just p2) = p1 == p2-          cmpMaybe _         _         = False-          ---getPackage :: Dependency -> Maybe Package-getPackage (AnyVersionOf package) = Just package-getPackage (ThisVersionOf      _version package) = Just package-getPackage (LaterVersionOf     _version package) = Just package-getPackage (EarlierVersionOf   _version package) = Just package-getPackage (OrLaterVersionOf   _version package) = Just package-getPackage (OrEarlierVersionOf _version package) = Just package-getPackage (DependEither _dependency _Dependency) = Nothing-getPackage (DependIfUse  _useFlag    _Dependency) = Nothing-getPackage (ThisMajorOf        _version package) = Just package----getPackageString :: Dependency -> Package-getPackageString dep = maybe "" id $ getPackage dep
− Cache.hs 
@@ -1,93 +0,0 @@-module Cache where--import Action-import CacheFile-import Config-import Error-import Index-import P2-import Version-import Overlays--import Distribution.Text ( simpleParse )--import Control.Arrow-import Data.Char-import Data.List-import Network.URI (URI, uriPath)-import Network.HTTP (Request(..), RequestMethod(GET), simpleHTTP, rspBody)-import qualified Data.ByteString.Lazy as L-import System.Time-import System.FilePath-import Control.Monad.Error(throwError)-import Control.Monad.Writer-import Control.Monad (unless)-import System.Directory (doesFileExist,createDirectoryIfMissing)--import qualified Data.Map as Map---- | A long time. Used in checkCacheDate-alarmingLongTime :: TimeDiff-alarmingLongTime = TimeDiff-	{ tdYear = 0-	, tdMonth = 0-	, tdDay = 7-	, tdHour = 0-	, tdMin = 0-	, tdSec = 0-	, tdPicosec = 0-	}--cacheURI :: URI -> URI-cacheURI uri = uri {uriPath = uriPath uri </> indexFile}--updateCache :: HPAction ()-updateCache = do-	path <- getOverlayPath-	cfg <- getCfg-	let cache = cacheURI $ server cfg-	res <- (liftIO $ simpleHTTP (Request cache GET [] "")) `sayNormal` ("Fetching cache from "++show cache++"...",const "done.")-	case res of-		Left err -> throwError (ConnectionFailed (show cache) (show err))-		Right resp -> liftIO $ do-                        createDirectoryIfMissing False (path </> hackportDir)-                        Prelude.writeFile (cacheFile path) (rspBody resp)--readCache :: FilePath -> HPAction Index-readCache portdir = do-	let cachePath = cacheFile portdir-	exists <- liftIO $ doesFileExist cachePath-	unless exists $ do-		info "No cache file present, attempting to update..."-		updateCache-	str <- liftIO $ L.readFile cachePath-	return $ readIndex str--readDefaultCache :: HPAction Index-readDefaultCache = do-    overlayPath <- getOverlayPath-    readCache overlayPath--indexToPortage :: Index -> Portage -> (Portage, [String])-indexToPortage index port = second nub . runWriter $ do-    pkgs <- forM index $ \(pkg_h_name, pkg_h_ver, pkg_desc) -> do-        let pkg_name = map toLower pkg_h_name-        pkg_cat <- lookupCat pkg_name-        Just ver <- return . simpleParse $ pkg_h_ver-        return $ Ebuild (P pkg_cat pkg_name)-                        (fromCabalVersion ver)-                        "<hackage>"-                        (Just pkg_desc)-    return $ Map.map sort $ Map.fromListWith (++) [ (ePackage e, [e]) | e <- pkgs ]-    where-    catMap = Map.fromListWith (++) [ (p, [c]) | P c p <- Map.keys port ]-    lookupCat :: String -> Writer [String] String-    lookupCat p = do-        case Map.lookup p catMap of-            Nothing -> return "hackage"-            Just [x] -> return x-            Just xs -> do-                let c | elem "dev-haskell" xs = "dev-haskell"-                      | otherwise = head xs-                tell ["WARNING: Category clash for package " ++ p ++ ", defaulting to " ++ c ++ ". Other categories: " ++ unwords (delete c xs)]-                return c
− Config.hs 
@@ -1,125 +0,0 @@-module Config where--import Network.URI-import System.Console.GetOpt-import Text.Regex--data HackPortOptions-	= OverlayPath String-        | PortagePath String-	| Server String-	| TempDir String-	| Verbosity String-	| Help-        | RefreshCache--data OperationMode-	= List String-	| Merge String-	| DiffTree DiffMode-	| Update-	| ShowHelp-	| Status String-	| MakeEbuild String--data DiffMode-	= ShowAll-	| ShowMissing-	| ShowAdditions-	| ShowNewer-	| ShowCommon-	deriving Eq--data Config = Config-	{ overlayPath		::Maybe String-        , portagePath           ::Maybe String-	, server		::URI-	, tmp			::String-	, verbosity		::Verbosity-        , refreshCache          ::Bool-	}--data Verbosity-	= Debug-	| Normal-	| Silent--packageRegex :: Regex-packageRegex = mkRegex "^(.*?)-([0-9].*)$"--defaultConfig :: Config-defaultConfig = Config-	{ overlayPath = Nothing-        , portagePath = Nothing-	, server = URI "http:" (Just $ URIAuth "" "hackage.haskell.org" "") "/packages/archive/" "" ""-	, tmp = "/tmp"-	, verbosity = Normal-        , refreshCache = False-	}--hackageOptions :: [OptDescr HackPortOptions]-hackageOptions =-	[Option ['o'] ["overlay-path"] (ReqArg OverlayPath "PATH") "The overlay tree to merge to"-        ,Option ['p'] ["portdir"] (ReqArg PortagePath "PATH") "The portage directory to use"-	,Option ['s'] ["server"] (ReqArg Server "URL") "The Hackage server to query"-	,Option ['t'] ["temp-dir"] (ReqArg TempDir "PATH") "A temp directory where tarballs can be stored"-	,Option ['v'] ["verbosity"] (ReqArg Verbosity "debug|normal|silent") "Set verbosity level (default is 'normal')"-	,Option ['h', '?'] ["help"] (NoArg Help) "Display this help message"-        ,Option ['r'] ["refresh-cache"] (NoArg RefreshCache) "Refresh the hackport cache before running the command"-	]--parseConfig :: [String] -> Either String ([HackPortOptions],OperationMode)-parseConfig opts = let-	(popts,args,errs) = getOpt Permute hackageOptions opts-	mode | not (null errs) = Left $ "Error while parsing flags:\n"-	                             ++ concat errs-	     | not (null [ () | Help <- popts ]) = Right ShowHelp-	     | otherwise = case args of-		"merge":[] -> Left "Need a package's name and version to merge it.\n"-		"merge":package:[] -> Right (Merge package)-		"merge":_:rest -> Left ("'merge' takes 1 argument("++show ((length rest)+1)++" given).\n")-		"list":[] -> Right (List "")-		"list":package:[] -> Right (List package)-		"list":rest -> Left ("'list' takes at most one argument ("++show (length rest)++" given).\n")-		"diff":[] -> Right (DiffTree ShowAll)-		"diff":"all":[] -> Right (DiffTree ShowAll)-		"diff":"missing":[] -> Right (DiffTree ShowMissing)-		"diff":"additions":[] -> Right (DiffTree ShowAdditions)-		"diff":"newer":[] -> Right (DiffTree ShowNewer)-		"diff":"common":[] -> Right (DiffTree ShowCommon)-		"diff":arg:[] -> Left ("Unknown argument to diff: '" ++ arg ++ "'. Use all,missing,additions,newer or common.\n")-		"diff":_:xs -> Left ("'diff' takes one argument("++show ((length xs)+1)++" given).\n")-		"update":[] -> Right Update-		"update":rest -> Left ("'update' takes zero arguments("++show (length rest)++" given).\n")-		"status":[] -> Right (Status "")-                "status":"toportage":[] -> Right (Status "toportage")-		"status":xs-> Left ("invalid argument(s) to 'status': " ++ show xs)-		"make-ebuild":[] -> Left "Need .cabal file to make ebuild."-		"make-ebuild":package:[] -> Right (MakeEbuild package)-		"make-ebuild":_:rest -> Left ("'make-ebuild' takes 1 argument("++show ((length rest)+1)++" given).\n")--		[] -> Right ShowHelp-		_ -> Left "Unknown opertation mode\n"-	in case mode of-		Left err -> Left err-		Right m -> Right (popts,m)--hackageUsage :: IO ()-hackageUsage = putStr $ flip usageInfo hackageOptions $ unlines-	[ "Usage:"-	, "\t\"hackport [OPTION] MODE [MODETARGET]\""-	, "\t\"hackport [OPTION] list [PKG]\" lists all packages or packages matching search term"-	, "\t\"hackport [OPTION] merge PKG-VERSION\" merges a package into the portage tree"-	, "\t\"hackport [OPTION] diff\" prints the difference between the portage-tree and the server's packages"-	, "\t\"hackport [OPTION] update\" updates the local cache"-	, "\t\"hackport [OPTION] status\" compares the overlay with the portage tree"-	, "\t\"hackport [OPTION] make-ebuild\" creates standalone ebuild from given .cabal file"-	, "Options:"-	]--parseVerbosity :: String -> Maybe Verbosity-parseVerbosity "debug" = Just Debug-parseVerbosity "normal" = Just Normal-parseVerbosity "silent" = Just Silent-parseVerbosity _ = Nothing-
Diff.hs view
@@ -1,70 +1,188 @@ module Diff-    ( diffAction+    ( runDiff+    , DiffMode(..)     ) where -import qualified Data.Map as Map+import Control.Monad ( mplus )+import Control.Exception ( assert )+import Data.Maybe ( fromJust, listToMaybe )+import Data.List ( sortBy, groupBy )+import Data.Ord ( comparing ) -import Control.Monad.Trans-import Data.Char+import qualified Portage.Overlay as Portage+import qualified Portage.Cabal as Portage+import qualified Portage.PackageId as Portage -import Action-import Cache-import Config (DiffMode(..))-import P2-import Version-import Overlays+import qualified Data.Version as Cabal -data DiffState a-	= OnlyLeft a-	| OnlyRight a-	| Both a a+-- cabal+import Distribution.Verbosity+import Distribution.Text(display)+import qualified Distribution.Package as Cabal+import qualified Distribution.Client.PackageIndex as Index+import Distribution.Simple.Utils (equating) +-- cabal-install+import qualified Distribution.Client.IndexUtils as Index (getAvailablePackages )+import qualified Distribution.Client.Types as Cabal+import Distribution.Client.Utils (mergeBy, MergeResult(..))++data DiffMode+	= ShowAll+	| ShowMissing+	| ShowAdditions+	| ShowNewer+	| ShowCommon+        | ShowPackages [String]+	deriving Eq+++{-+type DiffState a = MergeResult a a tabs :: String -> String tabs str = let len = length str in str++(if len < 3*8 	then replicate (3*8-len) ' ' 	else "") -showDiffState :: Package -> DiffState Version -> String-showDiffState pkg st = (tabs (show pkg)) ++ " [" ++ (case st of-	Both x y -> showVersion x ++ (case compare x y of-		EQ -> "="-		GT -> ">"-		LT -> "<") ++ showVersion y-	OnlyLeft x -> showVersion x ++ ">none"-	OnlyRight y ->  "none<"++showVersion y)++"]" +-- TODO: is the new showPackageCompareInfo showing the packages in the same+-- way as showDiffState did? -diffAction :: DiffMode -> HPAction ()-diffAction dm = do-    overlayPath <- getOverlayPath-    cache <- readCache overlayPath-    overlayTree <- liftIO $ readPortageTree overlayPath-    let (hackageTree, clashes) = indexToPortage cache overlayTree-    liftIO $ mapM_ putStrLn clashes-    diff hackageTree overlayTree dm+showDiffState :: Cabal.PackageName -> DiffState Portage.Version -> String+showDiffState pkg st = (tabs (display pkg)) ++ " [" ++ (case st of+  InBoth x y -> display x ++ (case compare x y of+    EQ -> "="+    GT -> ">"+    LT -> "<") ++ display y+  OnlyInLeft x -> display x ++ ">none"+  OnlyInRight y -> "none<" ++ display y) ++ "]"+-} -diff :: Portage -> Portage -> DiffMode -> HPAction ()-diff pt1 pt2 mode = do-        let pkgs1 = Map.map (OnlyLeft  . eVersion . maximum) pt1-        let pkgs2 = Map.map (OnlyRight . eVersion . maximum) pt2-        let union = Map.unionWith (\(OnlyLeft x) (OnlyRight y) -> Both x y) pkgs1 pkgs2-	let showFilter st = case mode of-		ShowAll -> True-		ShowMissing -> case st of-			OnlyLeft _ -> True-			Both x y -> x > y-			OnlyRight _ -> False-		ShowAdditions -> case st of-			OnlyLeft _ -> False-			Both x y -> x < y-			OnlyRight _ -> True-		ShowNewer -> case st of-			OnlyLeft _ -> False-			Both x y -> x > y-			OnlyRight _ -> False-		ShowCommon -> case st of-			OnlyLeft _ -> False-			Both x y -> x == y-			OnlyRight _ -> False-        let packages = filter (showFilter . snd) (Map.assocs union)-        mapM_ (info . uncurry showDiffState) packages+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++  -- get package list from the overlay+  overlay0 <- (Portage.loadLazy overlayPath)+  let overlayIndex = Portage.fromOverlay (Portage.reduceOverlay overlay0)++  let (subHackage, subOverlay)+        = case dm of+            ShowPackages pkgs ->+              (concatMap (Index.searchByNameSubstring hackageIndex) pkgs+              ,concatMap (Index.searchByNameSubstring overlayIndex) pkgs)+            _ ->+              (Index.allPackages hackageIndex+              ,Index.allPackages overlayIndex)+  diff subHackage subOverlay dm++data PackageCompareInfo = PackageCompareInfo {+    name :: Cabal.PackageName,+--    hackageVersions :: [ Cabal.Version ],+--    overlayVersions :: [ Cabal.Version ]+    hackageVersion :: Maybe Cabal.Version,+    overlayVersion :: Maybe Cabal.Version+  } deriving Show++showPackageCompareInfo :: PackageCompareInfo -> String+showPackageCompareInfo pkgCmpInfo =+    display (name pkgCmpInfo) ++ " ["+    ++ hackageS ++ sign ++ overlayS ++ "]" +  where+  overlay = overlayVersion pkgCmpInfo+  hackage = hackageVersion pkgCmpInfo+  hackageS = maybe "none" display hackage+  overlayS = maybe "none" display overlay+  sign = case compare hackage overlay of+          EQ -> "="+          GT -> ">"+          LT -> "<"++diff :: [Cabal.AvailablePackage]+     -> [Portage.ExistingEbuild]+     -> DiffMode+     -> IO ()+diff hackage overlay dm = do+  mapM_ (putStrLn . showPackageCompareInfo) pkgCmpInfos+  where+  merged = mergePackages (map (Portage.normalizeCabalPackageId . Cabal.packageId) hackage)+                         (map Portage.ebuildCabalId overlay)+  pkgCmpInfos = filter pkgFilter (map (uncurry mergePackageInfo) merged)+  pkgFilter :: PackageCompareInfo -> Bool+  pkgFilter pkgCmpInfo =+    let om = overlayVersion pkgCmpInfo+        hm = hackageVersion pkgCmpInfo+        st = case (om,hm) of+              (Just ov, Just hv) -> InBoth ov hv+              (Nothing, Just hv) -> OnlyInRight hv+              (Just ov, Nothing) -> OnlyInLeft ov+              _ -> error "impossible"+    in+    case dm of+      ShowAll -> True+      ShowPackages _ -> True -- already filtered+      ShowNewer -> case st of+                     InBoth o h -> h>o+                     _ -> False+      ShowMissing -> case st of+                     OnlyInLeft _ -> False+                     InBoth x y -> x < y+                     OnlyInRight _ -> True+      ShowAdditions -> case st of+                     OnlyInLeft _ -> True+                     InBoth x y -> x > y+                     OnlyInRight _ -> False+      ShowCommon -> case st of+                     OnlyInLeft _ -> False+                     InBoth x y -> x == y+                     OnlyInRight _ -> False+ +-- | We get the 'PackageCompareInfo' by combining the info for the overlay+-- and hackage 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 :: [Cabal.PackageIdentifier]+                 -> [Cabal.PackageIdentifier]+                 -> PackageCompareInfo+mergePackageInfo hackage overlay =+  assert (length overlay + length hackage > 0) $+  PackageCompareInfo {+    name              = combine Cabal.pkgName latestHackage+                                Cabal.pkgName latestOverlay,+--    hackageVersions = map Cabal.pkgVersion hackage,+--    overlayVersions = map Cabal.pkgVersion overlay+    hackageVersion = fmap Cabal.pkgVersion latestHackage,+    overlayVersion = fmap Cabal.pkgVersion latestOverlay+  }+  where+    combine f x g y = fromJust (fmap f x `mplus` fmap g y)+    latestHackage = latestOf hackage+    latestOverlay = latestOf overlay+    latestOf :: [Cabal.PackageIdentifier] -> Maybe Cabal.PackageIdentifier+    latestOf = listToMaybe . reverse . sortBy (comparing Cabal.pkgVersion)++-- | 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 :: [Cabal.PackageIdentifier] -> [Cabal.PackageIdentifier]+              -> [([Cabal.PackageIdentifier], [Cabal.PackageIdentifier])]+mergePackages hackage overlay =+    map collect+  $ mergeBy (\i a -> fst i `compare` fst a)+            (groupOn Cabal.pkgName hackage)+            (groupOn Cabal.pkgName overlay)+  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)
+ DistroMap.hs view
@@ -0,0 +1,159 @@+{-# OPTIONS -XPatternGuards #-}+{-+Generate a distromap, like these:+http://hackage.haskell.org/packages/archive/00-distromap/+Format:++("xmobar","0.8",Just "http://packages.gentoo.org/package/x11-misc/xmobar")+("xmobar","0.9",Just "http://packages.gentoo.org/package/x11-misc/xmobar")+("xmobar","0.9.2",Just "http://packages.gentoo.org/package/x11-misc/xmobar")+("xmonad","0.5",Just "http://packages.gentoo.org/package/x11-wm/xmonad")+("xmonad","0.6",Just "http://packages.gentoo.org/package/x11-wm/xmonad")+("xmonad","0.7",Just "http://packages.gentoo.org/package/x11-wm/xmonad")+("xmonad","0.8",Just "http://packages.gentoo.org/package/x11-wm/xmonad")+("xmonad","0.8.1",Just "http://packages.gentoo.org/package/x11-wm/xmonad")+("xmonad","0.9",Just "http://packages.gentoo.org/package/x11-wm/xmonad")+("xmonad","0.9.1",Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay")++Multiple entries for each package is allowed, given that there are different versions.+++Setup:+  Join all packages from portage and the overlay into a big map;+  From Portage.PackageId: PackageName = category/package+  PVULine = (packagename, versionstring, url)+  Create such a map: Map PackageName DistroLine+  Only one PVULine per version, and prefer portage over the overlay.++Algorithm;+  1. Take a package from hackage+  2. Look for it in the map+    a. For each version:+        find a match in the list of versions:+          yield the PVULine+-}++module DistroMap+  ( distroMap ) where++import Control.Applicative+import qualified Data.List as List ( nub )+import qualified Data.Map as Map+import Data.Map ( Map )+import System.FilePath ( (</>) )+import Debug.Trace ( trace )+import Data.Maybe ( fromJust )++import Distribution.Verbosity+import Distribution.Text ( display )+import Distribution.Client.Types ( Repo, AvailablePackageDb(..), AvailablePackage(..) )+import Distribution.Simple.Utils ( warn, notice, info )++import qualified Data.Version as Cabal+import qualified Distribution.Package as Cabal+import qualified Distribution.Client.PackageIndex as CabalInstall+import qualified Distribution.Client.IndexUtils as CabalInstall++import Portage.Overlay ( Overlay(..), readOverlayByPackage, getDirectoryTree, DirectoryTree )+import qualified Portage.PackageId as Portage+import qualified Portage.Version as Portage++type PVU = (Cabal.PackageName, Cabal.Version, Maybe String)+type PVU_Map = Map Portage.PackageName [(Cabal.Version, Maybe String)]+type PVU_Item = (Portage.PackageName, [(Cabal.Version, Maybe String)])++distroMap :: Verbosity -> Repo -> FilePath -> FilePath -> [String] -> IO ()+distroMap verbosity repo portagePath overlayPath args = do+  info verbosity "distro map called"+  info verbosity ("verbosity: " ++ show verbosity)+  info verbosity ("portage: " ++ portagePath)+  info verbosity ("overlay: " ++ overlayPath)+  info verbosity ("args: " ++ show args)++  portage <- readOverlayByPackage <$> getDirectoryTree portagePath+  overlay <- readOverlayByPackage <$> getDirectoryTree overlayPath++  info verbosity ("portage packages: " ++ show (length portage))+  info verbosity ("overlay packages: " ++ show (length overlay))++  let portageMap = buildPortageMap portage+      overlayMap = buildOverlayMap overlay+      completeMap = unionMap portageMap overlayMap++  info verbosity ("portage map: " ++ show (Map.size portageMap))+  info verbosity ("overlay map: " ++ show (Map.size overlayMap))+  info verbosity ("complete map: " ++ show (Map.size completeMap))++  AvailablePackageDb { packageIndex = packageIndex } <-+    CabalInstall.getAvailablePackages verbosity [repo]++  let pkgs0 = map (map packageInfoId) (CabalInstall.allPackagesByName packageIndex)+      hackagePkgs = [ (Cabal.pkgName (head p), map Cabal.pkgVersion p) | p <- pkgs0 ]++  info verbosity ("cabal packages: " ++ show (length hackagePkgs))++  let pvus = concat $ map (\(p,vs) -> lookupPVU completeMap p vs) hackagePkgs+  info verbosity ("found pvus: " ++ show (length pvus))++  mapM_ (putStrLn . showPVU) pvus+  return ()+++showPVU :: PVU -> String+showPVU (p,v,u) = show $ (display p, display v, u)++-- building the PVU_Map++reduceVersion :: Portage.Version -> Portage.Version+reduceVersion (Portage.Version ns _ _ _) = Portage.Version ns Nothing [] 0++reduceVersions :: [Portage.Version] -> [Portage.Version]+reduceVersions = List.nub . map reduceVersion++buildMap :: [(Portage.PackageName, [Portage.Version])]+         -> (Portage.PackageName -> Portage.Version -> Maybe String)+         -> PVU_Map+buildMap pvs f = Map.mapWithKey (\p vs -> [ (fromJust $ Portage.toCabalVersion v, f p v)+                                          | v <- reduceVersions vs ])+                                (Map.fromList pvs)++buildPortageMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map+buildPortageMap lst = buildMap lst $ \ (Portage.PackageName c p) _v ->+  Just $ "http://packages.gentoo.org/package" </> display c </> display p++buildOverlayMap :: [(Portage.PackageName, [Portage.Version])] -> PVU_Map+buildOverlayMap lst = buildMap lst $ \_ _ -> Just "http://en.gentoo-wiki.com/wiki/Haskell/overlay"++unionMap :: PVU_Map -> PVU_Map -> PVU_Map+unionMap = Map.unionWith f+  where+  f :: [(Cabal.Version, Maybe String)]+    -> [(Cabal.Version, Maybe String)]+    -> [(Cabal.Version, Maybe String)]+  f vas vbs = Map.toList (Map.union (Map.fromList vas) (Map.fromList vbs))+++-- resolving Cabal.PackageName to Portage.PackageName++lookupPVU :: PVU_Map -> Cabal.PackageName -> [Cabal.Version] -> [PVU]+lookupPVU pvu_map pn cvs =+  case findItems pvu_map (Portage.normalizeCabalPackageName pn) of+    [] -> []+    [item] -> ret item+    items | [item] <- preferableItem items -> ret item+          | otherwise -> trace (noDefaultText items) []+  where+  noDefaultText is = unlines $ ("no default for package: " ++ display pn)+                           : [ " * " ++ (display cat)+                             | (Portage.PackageName cat _, _) <- is]++  ret (_, vs) = [ (pn, v, u) | (v, u) <- vs, v `elem` cvs ]+  preferableItem items =+    [ item+    | item@(Portage.PackageName cat _pn, _vs) <- items+    , cat == Portage.Category "dev-haskell"]+  findItems pvu_map cpn = Map.toList $ Map.filterWithKey f pvu_map+    where+    f (Portage.PackageName _cat pn) _vs = cpn == pn++
Error.hs view
@@ -1,8 +1,9 @@ {-# OPTIONS -fglasgow-exts #-}-module Error where+module Error (HackPortError(..), throwEx, catchEx, hackPortShowError) where  import Data.Typeable-import Control.Monad.Error (Error)+import Control.Exception.Extensible as EE+import Control.Monad.Error  data HackPortError 	= ArgumentError String@@ -25,17 +26,23 @@ 	-- | WrongCacheVersion 	-- | InvalidCache 	| InvalidServer String-	deriving (Typeable)+	deriving (Typeable, Show) -instance Error HackPortError+instance Error HackPortError where -type HackPortResult a = Either+instance Exception HackPortError where +throwEx :: HackPortError -> IO a+throwEx = EE.throw++catchEx :: IO a -> (HackPortError -> IO a) -> IO a+catchEx = EE.catch+ hackPortShowError :: HackPortError -> String hackPortShowError err = case err of 	ArgumentError str -> "Argument error: "++str 	ConnectionFailed server reason -> "Connection to hackage server '"++server++"' failed: "++reason-	PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server."+	PackageNotFound pkg -> "Package '"++ pkg ++"' not found on server. Try 'hackport update'?" 	InvalidTarballURL url reason -> "Error while downloading tarball '"++url++"': "++reason 	InvalidSignatureURL url reason -> "Error while downloading signature '"++url++"': "++reason 	VerificationFailed file signature -> "Error while checking signature('"++signature++"') of '"++file++"'"
− Fetch.hs 
@@ -1,75 +0,0 @@-module Fetch(downloadTarball,downloadFileVerify) where--import Prelude hiding (catch)--import Network.HTTP (ConnError(..),Request(..),simpleHTTP-                    ,Response(..),RequestMethod(..))-import Network.URI (URI,uriPath,parseURI)-import Text.Regex (Regex,mkRegex,matchRegex)-import System.GPG-import Control.Monad.Error-import System.Directory-import System.FilePath-import Data.Typeable--import Error-import Action--filenameRegex :: Regex-filenameRegex = mkRegex "^.*?/([^/]*?)"--uriToFileName :: URI -> Maybe FilePath-uriToFileName uri = maybe Nothing (\x->Just (head x)) (matchRegex filenameRegex (uriPath uri))--downloadURI :: FilePath		-- ^ a directory to store the file-            -> URI 		-- ^ the url-            -> HPAction FilePath	-- ^ the path of the downloaded file-downloadURI path uri = do-	fileName <- maybe (throwError $ InvalidTarballURL (show uri) "URL doesn't contain a filename") return (uriToFileName uri)-	httpResult <- liftIO $ simpleHTTP request-	Response {rspCode=code,rspBody=body,rspReason=reason} <- either (\x->throwError $ DownloadFailed (show uri) "Connection failed") return httpResult-	if code==(2,0,0) then (do-		let writePath=path </> fileName-		liftIO $ writeFile writePath body-		return writePath) else throwError $ DownloadFailed (show uri) ("Code "++show code++":"++reason)-	where-	request = Request-		{rqURI=uri-		,rqMethod=GET-		,rqHeaders=[]-		,rqBody=""}---downloadFileVerify ::-	FilePath ->		-- ^ the directory to store the files-	String ->		-- ^ the url of the tarball-	String ->		-- ^ the url of the signature-	HPAction (FilePath,FilePath)	-- ^ the tarballs and signatures path-downloadFileVerify path url sigurl = do-	tarballPath <- downloadTarball path url-	sigPath <- downloadSig path sigurl `catchError` (\x->liftIO (removeFile tarballPath) >> throwError x)-	verified <- liftIO $ verifyFile stdOptions tarballPath sigPath-	if verified then return (tarballPath,sigPath) else (do-		liftIO $ removeFile tarballPath-		liftIO $ removeFile sigPath-		throwError $ VerificationFailed url sigurl)--downloadTarball ::-	FilePath ->-	String ->-	HPAction FilePath-downloadTarball dir url = download dir url InvalidTarballURL--downloadSig ::-	FilePath ->-	String ->-	HPAction FilePath-downloadSig dir url = download dir url InvalidSignatureURL--download :: FilePath				-- ^ the folder to store the file in-	 -> String				-- ^ the url-	 -> (String -> String -> HackPortError)	-- ^ a function to construct an error-	 -> HPAction FilePath			-- ^ the resulting file's path-download dir url errFunc = do-	parsedURL <- maybe (throwError $ errFunc url "Parsing failed") return (parseURI url)-	downloadURI dir parsedURL
− GenerateEbuild.hs 
@@ -1,60 +0,0 @@-module GenerateEbuild where--import Action-import Cabal2Ebuild-import Config--import Prelude hiding (catch)-import Control.Monad.Error-import Distribution.Package-import Data.Version (showVersion)-import Network.URI-import System.Directory-import System.FilePath--mergeEbuild :: FilePath -> String -> EBuild -> IO ()-mergeEbuild target category ebuild = do-    let edir = target </> category </> name ebuild-    let epath = edir </> name ebuild ++"-"++ version ebuild <.> "ebuild"-    createDirectoryIfMissing True edir-    writeFile epath (showEBuild ebuild)--fixSrc :: PackageIdentifier -> EBuild -> HPAction EBuild-fixSrc p ebuild = do-	cfg <- getCfg-	return $ ebuild {-		src_uri = show $ (server cfg) {-			uriPath = (uriPath (server cfg))-				</> pkgName p-				</> showVersion (pkgVersion p)-				</> pkgName p ++ "-" ++-					showVersion (pkgVersion p)-				<.> "tar.gz"-			}-		}--{-hackage2ebuild ::-	(PackageIdentifier,String,String) ->	-- ^ the package-	HPAction EBuild-hackage2ebuild (pkg,tarball,sig) = do-	cfg <- getCfg-	tarballPath <- (if verify cfg then (do-		(tarPath,sigPath) <- downloadFileVerify (tmp cfg) tarball sig-		liftIO $ removeFile sigPath-		return tarPath) else (downloadTarball (tmp cfg) tarball))-		`sayNormal` ("Downloading tarball from '"++tarball++"' to '"++(tmp cfg)++"'... ",const "done.")-	tarType <- maybe (liftIO (removeFile tarballPath) >> throwError (UnknownCompression tarball)) return (tarballGetType tarballPath)-		`sayDebug` ("Guessing compression type of tarball... ",const "done.")-	filesInTarball <- tarballGetFiles (tarCommand cfg) tarballPath tarType-		`sayDebug` ("Getting list of files from tarball... ",const "done.")-		`catchError` (\x->liftIO (removeFile tarballPath) >> throwError x)-	(cabalDir,cabalName) <- maybe (throwError $ NoCabalFound tarball) return (findCabal filesInTarball)-		`sayDebug` ("Trying to find cabal file... ",\(dir,name)->"Found cabal file '"++name++"' in '"++dir++"'.")-	cabalFile <- tarballExtractFile tarballPath tarType (cabalDir++"/"++cabalName)-		`sayDebug` ("Extracting cabal file... ",const "done.")-	packageDescription <- case parseDescription cabalFile of-		ParseFailed err -> throwError $ CabalParseFailed cabalName (showError err)-		ParseOk descr -> return descr-		`sayDebug` ("Parsing '"++cabalName++"'... ",const "done.")-	let ebuild=cabal2ebuild (packageDescription{pkgUrl=tarball}) --we don't trust the cabal file as we just successfully downloaded the tarbal somewhere-	return ebuild {cabalPath=Just cabalDir}-}
− Index.hs 
@@ -1,45 +0,0 @@-module Index where--import qualified Data.Set as Set-import qualified Data.Map as Map-import Data.Version (Version,parseVersion)-import Codec.Compression.GZip(decompress)-import Data.ByteString.Lazy.Char8(ByteString,unpack)-import Codec.Archive.Tar-import Distribution.PackageDescription-import Distribution.Package-import System.FilePath.Posix-import MaybeRead (readPMaybe)--type Index = [(String,String,GenericPackageDescription)]-type IndexMap = Map.Map String (Set.Set Version)--readIndex :: ByteString -> Index-readIndex str = do-    let unziped = decompress str-        untared = readTarArchive unziped-    entr <- archiveEntries untared-    case splitDirectories (tarFileName (entryHeader entr)) of-        [".",pkgname,vers,file] -> do-            let descr = case parsePackageDescription (unpack (entryData entr)) of-                    ParseOk _ pkg_desc -> pkg_desc-                    _  -> error $ "Couldn't read cabal file "++show file-            return (pkgname,vers,descr)-        _ -> fail "doesn't look like the proper path"--filterIndexByPV :: (String -> String -> Bool) -> Index -> Index-filterIndexByPV cond index = [ x | x@(p,v,_d) <- index, cond p v]--indexMapFromList :: [PackageIdentifier] -> IndexMap-indexMapFromList pids = Map.unionsWith Set.union $-    [ Map.singleton name (Set.singleton vers)-    | (PackageIdentifier {pkgName = name,pkgVersion = vers}) <- pids ]--indexToPackageIdentifier :: Index -> [PackageIdentifier]-indexToPackageIdentifier index = do-    (name,vers_str,_) <- index-    Just vers <- return $ readPMaybe parseVersion vers_str-    return $ PackageIdentifier {pkgName = name,pkgVersion = vers}--bestVersions :: IndexMap -> Map.Map String Version-bestVersions = Map.map Set.findMax
+ LICENSE view
@@ -0,0 +1,674 @@+                    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>.
Main.hs view
@@ -1,136 +1,581 @@ module Main where -import Control.Monad.Error-import Data.Char+import Control.Applicative+import Control.Monad import Data.Maybe import Data.List-import Data.Version-import Distribution.Package-import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))+import Data.Monoid+        ( Monoid(..) )++-- cabal+import Distribution.Simple.Setup+        ( Flag(..), fromFlag+        , trueArg+        , flagToMaybe, flagToList+        , optionVerbosity+        ) import Distribution.PackageDescription.Configuration-         ( finalizePackageDescription, flattenPackageDescription )-import Distribution.Simple.PackageIndex (PackageIndex)+         ( flattenPackageDescription )+import Distribution.ReadE ( succeedReadE )+import Distribution.Simple.Command -- commandsRun+import Distribution.Simple.Utils ( die, cabalVersion, warn )+import qualified Distribution.PackageDescription.Parse as Cabal+import qualified Distribution.Package as Cabal+import Distribution.Verbosity (Verbosity, normal) import Distribution.Text (display)-import System.IO-import Distribution.System (buildOS, buildArch)-import qualified Data.Map as Map-import Text.ParserCombinators.Parsec -import Action+import Distribution.Client.Types+import Distribution.Client.Update++import qualified Distribution.Client.PackageIndex as Index+import qualified Distribution.Client.IndexUtils as Index++import Portage.Overlay as Overlay ( loadLazy, inOverlay )+import Portage.Host as Host ( getInfo, portage_dir )+import Portage.PackageId ( normalizeCabalPackageId )++import Network.URI+import System.Environment ( getArgs, getProgName )+import System.Directory ( doesDirectoryExist )+import System.Exit ( exitFailure )+import System.FilePath ( (</>) )+ import qualified Cabal2Ebuild as E-import Cache-import Config+ import Diff import Error-import GenerateEbuild-import Index import Status-import Package import Overlays-import P2+import Merge+import DistroMap ( distroMap ) -import qualified Distribution.PackageDescription as Cabal-import Distribution.Verbosity (normal)-import Cabal2Ebuild+import qualified Paths_cabal_install+import qualified Paths_hackport -list :: String -> HPAction ()-list name = do-    index <- readCache =<< getOverlayPath-    let index' | null name = index-               | otherwise = filterIndexByPV matchSubstringCaseInsensitive index-        pkgs = [ pkg ++ "-" ++ ver | (pkg,ver,_) <- index']-    if null pkgs-      then throwError (PackageNotFound name)-      else liftIO . putStr . unlines . sort $ pkgs-    where-        matchSubstringCaseInsensitive pName _pVver =-                map toLower name `isInfixOf` map toLower pName+-----------------------------------------------------------------------+-- List+----------------------------------------------------------------------- -merge :: String -> HPAction ()-merge pstr = do-    (m_category, pname, m_version) <- case parsePVC of-        Right v -> return v-        Left err -> throwError (ArgumentError ("Could not parse [category/]package[-version]: " ++ show err))-    portdir <- getOverlayPath-    overlay <- liftIO $ readPortageTree portdir-    cache <- readCache portdir-    let (indexTree,clashes) = indexToPortage cache overlay-    mapM_ (liftIO . putStrLn) clashes-    whisper $ "Searching for: "++ pstr-    let pkgs =-          Map.elems-            . Map.filterWithKey (\(P _ pname') _ -> map toLower pname' == map toLower pname)-            $ indexTree-    return ()-    pkg <- case pkgs of-        [] -> throwError (PackageNotFound pname)-        [xs] -> case m_version of-            Nothing -> return (maximum xs) -- highest version-            Just v -> do-                let ebuilds = filter (\e -> eVersion e == v) xs-                case ebuilds of-                    [] -> throwError (PackageNotFound (pname ++ '-':show v))-                    [e] -> return e-                    _ -> fail "the impossible happened"-        _ -> fail "the impossible happened"-    category <- do-        case m_category of-            Just cat -> return cat-            Nothing -> do-                case pCategory (ePackage pkg) of-                    "hackage" -> return "dev-haskell"-                    c -> return c-    let Just genericDesc = ePkgDesc pkg-        Right (desc, _) = finalizePackageDescription []-                            (Nothing :: Maybe (PackageIndex PackageIdentifier))-                            buildOS buildArch-                            (CompilerId GHC (Version [6,8,2] []))-                            [] genericDesc-    ebuild <- fixSrc (packageId desc) (E.cabal2ebuild desc)-    liftIO $ do-        putStrLn $ "Merging " ++ category ++ '/': pname ++ "-" ++ display (pkgVersion (packageId desc))-        putStrLn $ "Destination: " ++ portdir-        mergeEbuild portdir category ebuild-    where-    parsePVC = parse readPVC "" pstr-    readPVC = do-        mc <- option Nothing $ try $ do-            c <- readCat-            char '/'-            return (Just c)-        (p, mv) <- readPkgAndVer-        eof-        return (mc, p, mv)+data ListFlags = ListFlags {+    listVerbosity :: Flag Verbosity+    -- , listOverlayPath :: Flag FilePath+    -- , listServerURI :: Flag String+  } -makeEbuild :: String -> HPAction ()-makeEbuild cabalFileName = liftIO $ do+instance Monoid ListFlags where+  mempty = ListFlags {+    listVerbosity = mempty+    -- , listOverlayPath = mempty+    -- , listServerURI = mempty+  }+  mappend a b = ListFlags {+    listVerbosity = combine listVerbosity+    -- , listOverlayPath = combine listOverlayPath+    -- , listServerURI = combine listServerURI+  }+    where combine field = field a `mappend` field b++defaultListFlags :: ListFlags+defaultListFlags = ListFlags {+    listVerbosity = Flag normal+    -- , listOverlayPath = NoFlag+    -- , listServerURI = Flag defaultHackageServerURI+  }++listCommand :: CommandUI ListFlags+listCommand = CommandUI {+    commandName = "list",+    commandSynopsis = "List packages",+    commandDescription = Just $ \_pname ->+        "TODO: this is the commandDescription for listCommand\n",+    commandUsage = usagePackages "list",+    commandDefaultFlags = defaultListFlags,+    commandOptions = \_showOrParseArgs ->+      [ optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })+      {-+      , option [] ["overlay"]+         "Use cached packages list from specified overlay"+         listOverlayPath (\v flags -> flags { listOverlayPath = v })+         (reqArgFlag "PATH")+       -}+      ]+  }++listAction :: ListFlags -> [String] -> GlobalFlags -> IO ()+listAction flags extraArgs globalFlags = do+  let verbosity = fromFlag (listVerbosity flags)+  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+  let repo = defaultRepo overlayPath+  index <- fmap packageIndex (Index.getAvailablePackages verbosity [ repo ])+  overlay <- Overlay.loadLazy overlayPath+  let pkgs | null extraArgs = Index.allPackages index+           | otherwise = concatMap (Index.searchByNameSubstring index) extraArgs+      normalized = map (normalizeCabalPackageId . packageInfoId) pkgs+  let decorated = map (\p -> (Overlay.inOverlay overlay p, p)) normalized+  mapM_ (putStrLn . pretty) decorated+  where+  pretty :: (Bool, Cabal.PackageIdentifier) -> String+  pretty (isInOverlay, pkgId) =+      let dec | isInOverlay = " * "+              | otherwise   = "   "+      in dec ++ display pkgId+++-----------------------------------------------------------------------+-- Make Ebuild+-----------------------------------------------------------------------++data MakeEbuildFlags = MakeEbuildFlags {+    makeEbuildVerbosity :: Flag Verbosity+  }++instance Monoid MakeEbuildFlags where+  mempty = MakeEbuildFlags {+    makeEbuildVerbosity = mempty+  }+  mappend a b = MakeEbuildFlags {+    makeEbuildVerbosity = combine makeEbuildVerbosity+  }+    where combine field = field a `mappend` field b++defaultMakeEbuildFlags :: MakeEbuildFlags+defaultMakeEbuildFlags = MakeEbuildFlags {+    makeEbuildVerbosity = Flag normal+  }++makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO ()+makeEbuildAction flags args _globalFlags = do+  when (null args) $+    die "make-ebuild needs at least one argument"+  let _verbosity = fromFlag (makeEbuildVerbosity flags)+  forM_ args $ \cabalFileName -> do     pkg <- Cabal.readPackageDescription normal cabalFileName-    let ebuild = cabal2ebuild (flattenPackageDescription pkg)-    let ebuildFileName = name ebuild ++ "-" ++ version ebuild ++ ".ebuild"-    writeFile ebuildFileName (showEBuild ebuild)+    let ebuild = E.cabal2ebuild (flattenPackageDescription pkg)+    let ebuildFileName = E.name ebuild ++ "-" ++ E.version ebuild ++ ".ebuild"+    writeFile ebuildFileName (E.showEBuild ebuild) -hpmain :: HPAction ()-hpmain = do-    mode <- loadConfig-    requestedUpdate <- fmap refreshCache getCfg-    when requestedUpdate $-        case mode of-            Update -> return ()-            _ -> updateCache-    case mode of-        ShowHelp -> liftIO hackageUsage-        List pkg -> list pkg-        Merge pkg -> merge pkg-        DiffTree dtmode -> diffAction dtmode-        Update -> updateCache-        Status action -> statusAction action-        MakeEbuild cabalFileName -> makeEbuild cabalFileName+makeEbuildCommand :: CommandUI MakeEbuildFlags+makeEbuildCommand = CommandUI {+    commandName = "make-ebuild",+    commandSynopsis = "Make an ebuild from a .cabal file",+    commandDescription = Just $ \_pname ->+        "TODO: this is the commandDescription for makeEbuildCommand\n",+    commandUsage = \_ -> [],+    commandDefaultFlags = defaultMakeEbuildFlags,+    commandOptions = \_showOrParseArgs ->+      [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v })+      ]+  } +-----------------------------------------------------------------------+-- Diff+-----------------------------------------------------------------------++data DiffFlags = DiffFlags {+    -- diffMode :: Flag String, -- DiffMode,+    diffVerbosity :: Flag Verbosity+    -- , diffServerURI :: Flag String+  }++instance Monoid DiffFlags where+  mempty = DiffFlags {+    -- diffMode = mempty,+    diffVerbosity = mempty+    -- , diffServerURI = mempty+  }+  mappend a b = DiffFlags {+    -- diffMode = combine diffMode,+    diffVerbosity = combine diffVerbosity+    -- , diffServerURI = combine diffServerURI+  }+    where combine field = field a `mappend` field b++defaultDiffFlags :: DiffFlags+defaultDiffFlags = DiffFlags {+    -- diffMode = Flag "all",+    diffVerbosity = Flag normal+    -- , diffServerURI = Flag defaultHackageServerURI+  }++diffCommand :: CommandUI DiffFlags+diffCommand = CommandUI {+    commandName = "diff",+    commandSynopsis = "Run diff",+    commandDescription = Just $ \_pname ->+        "TODO: this is the commandDescription for diffCommand\n",+    commandUsage = usagePackages "diff",+    commandDefaultFlags = defaultDiffFlags,+    commandOptions = \_showOrParseArgs ->+      [ optionVerbosity diffVerbosity (\v flags -> flags { diffVerbosity = v })+      {-+      , option [] ["mode"]+         "Diff mode, one of: all, newer, missing, additions, common"+         diffMode (\v flags -> flags { diffMode = v })+         (reqArgFlag "MODE") -- I don't know how to map it strictly to DiffMode+      -}+      ]+  }++diffAction :: DiffFlags -> [String] -> GlobalFlags -> IO ()+diffAction flags args globalFlags = do+  let verbosity = fromFlag (diffVerbosity flags)+      -- dm0 = fromFlag (diffMode flags)+  dm <- case args of+          [] -> return ShowAll+          ["all"] -> return ShowAll+          ["missing"] -> return ShowMissing+          ["additions"] -> return ShowAdditions+          ["newer"] -> return ShowNewer+          ["common"] -> return ShowCommon+          ("package":  pkgs) -> return (ShowPackages pkgs)+          -- TODO: ["package",packagePattern] ->+          --          return ShowPackagePattern packagePattern+          _ -> die $ "Unknown mode: " ++ unwords args+  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+  let repo = defaultRepo overlayPath+  runDiff verbosity overlayPath dm repo++-----------------------------------------------------------------------+-- Update+-----------------------------------------------------------------------++data UpdateFlags = UpdateFlags {+    updateVerbosity :: Flag Verbosity+    -- , updateServerURI :: Flag String+  }++instance Monoid UpdateFlags where+  mempty = UpdateFlags {+    updateVerbosity = mempty+    -- , updateServerURI = mempty+  }+  mappend a b = UpdateFlags {+    updateVerbosity = combine updateVerbosity+    -- , updateServerURI = combine updateServerURI+  }+    where combine field = field a `mappend` field b++defaultUpdateFlags :: UpdateFlags+defaultUpdateFlags = UpdateFlags {+    updateVerbosity = Flag normal+    -- , updateServerURI = Flag defaultHackageServerURI+  }++updateCommand :: CommandUI UpdateFlags+updateCommand = CommandUI {+    commandName = "update",+    commandSynopsis = "Update the local cache",+    commandDescription = Just $ \_pname ->+        "TODO: this is the commandDescription for updateCommand\n",+    commandUsage = usageFlags "update",+    commandDefaultFlags = defaultUpdateFlags,+    commandOptions = \_ ->+      [ optionVerbosity updateVerbosity (\v flags -> flags { updateVerbosity = v })++      {-+      , option [] ["server"]+          "Set the server you'd like to update the cache from"+          updateServerURI (\v flags -> flags { updateServerURI = v} )+          (reqArgFlag "SERVER")+      -}+      ]+  }++updateAction :: UpdateFlags -> [String] -> GlobalFlags -> IO ()+updateAction flags extraArgs globalFlags = do+  unless (null extraArgs) $+    die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs+  let verbosity = fromFlag (updateVerbosity flags)+  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+  update verbosity [ defaultRepo overlayPath ]+  ++-----------------------------------------------------------------------+-- Status+-----------------------------------------------------------------------++data StatusFlags = StatusFlags {+    statusVerbosity :: Flag Verbosity,+    statusToPortage :: Flag Bool+  }++instance Monoid StatusFlags where+  mempty = StatusFlags {+    statusVerbosity = mempty,+    statusToPortage = mempty+  }+  mappend a b = StatusFlags {+    statusVerbosity = combine statusVerbosity,+    statusToPortage = combine statusToPortage+  }+    where combine field = field a `mappend` field b++defaultStatusFlags :: StatusFlags+defaultStatusFlags = StatusFlags {+    statusVerbosity = Flag normal,+    statusToPortage = Flag False+  }++statusCommand :: CommandUI StatusFlags+statusCommand = CommandUI {+    commandName = "status",+    commandSynopsis = "Show status(??)",+    commandDescription = Just $ \_pname ->+        "TODO: this is the commandDescription for statusCommand\n",+    commandUsage = usagePackages "status",+    commandDefaultFlags = defaultStatusFlags,+    commandOptions = \_ ->+      [ optionVerbosity statusVerbosity (\v flags -> flags { statusVerbosity = v })+      , option [] ["to-portage"]+          "Print only packages likely to be interesting to move to the portage tree."+          statusToPortage (\v flags -> flags { statusToPortage = v })+          trueArg+      ]+  }++statusAction :: StatusFlags -> [String] -> GlobalFlags -> IO ()+statusAction flags args globalFlags = do+  let verbosity = fromFlag (statusVerbosity flags)+      toPortdir = fromFlag (statusToPortage flags)+  portagePath <- getPortageDir verbosity globalFlags+  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+  runStatus verbosity portagePath overlayPath toPortdir args++-----------------------------------------------------------------------+-- Merge+-----------------------------------------------------------------------++data MergeFlags = MergeFlags {+    mergeVerbosity :: Flag Verbosity+    -- , mergeServerURI :: Flag String+  }++instance Monoid MergeFlags where+  mempty = MergeFlags {+    mergeVerbosity = mempty+    -- , mergeServerURI = mempty+  }+  mappend a b = MergeFlags {+    mergeVerbosity = combine mergeVerbosity+    -- , mergeServerURI = combine mergeServerURI+  }+    where combine field = field a `mappend` field b++defaultMergeFlags :: MergeFlags+defaultMergeFlags = MergeFlags {+    mergeVerbosity = Flag normal+    -- , mergeServerURI = Flag defaultHackageServerURI+  }++mergeCommand :: CommandUI MergeFlags+mergeCommand = CommandUI {+    commandName = "merge",+    commandSynopsis = "Make an ebuild out of hackage package",+    commandDescription = Just $ \_pname ->+      "TODO: this is the commandDescription for mergeCommand\n",+    commandUsage = usagePackages "merge",+    commandDefaultFlags = defaultMergeFlags,+    commandOptions = \_showOrParseArgs ->+      [ optionVerbosity mergeVerbosity (\v flags -> flags { mergeVerbosity = v })++      {-+      , option [] ["server"]+          "Set the server you'd like to update the cache from"+          mergeServerURI (\v flags -> flags { mergeServerURI = v} )+          (reqArgFlag "SERVER")+      -}+      ]+  }++mergeAction :: MergeFlags -> [String] -> GlobalFlags -> IO ()+mergeAction flags extraArgs globalFlags = do+  let verbosity = fromFlag (mergeVerbosity flags)+  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+  let repo = defaultRepo overlayPath+  merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath++-----------------------------------------------------------------------+-- DistroMap+-----------------------------------------------------------------------++data DistroMapFlags = DistroMapFlags {+    distroMapVerbosity :: Flag Verbosity+  }++instance Monoid DistroMapFlags where+  mempty = DistroMapFlags {+    distroMapVerbosity = mempty+    -- , mergeServerURI = mempty+  }+  mappend a b = DistroMapFlags {+    distroMapVerbosity = combine distroMapVerbosity+  }+    where combine field = field a `mappend` field b++defaultDistroMapFlags :: DistroMapFlags+defaultDistroMapFlags = DistroMapFlags {+    distroMapVerbosity = Flag normal+  }++distroMapCommand :: CommandUI DistroMapFlags+distroMapCommand = CommandUI {+    commandName = "distromap",+    commandSynopsis = "Build a distromap file",+    commandDescription = Just $ \_pname ->+      "TODO: this is the commandDescription for distroMapCommand\n",+    commandUsage = usagePackages "distromap",+    commandDefaultFlags = defaultDistroMapFlags,+    commandOptions = \_showOrParseArgs ->+      [ optionVerbosity distroMapVerbosity (\v flags -> flags { distroMapVerbosity = v })+      ]+  }++distroMapAction :: DistroMapFlags-> [String] -> GlobalFlags -> IO ()+distroMapAction flags extraArgs globalFlags = do+  let verbosity = fromFlag (distroMapVerbosity flags)+  overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)+  let repo = defaultRepo overlayPath+  portagePath <- getPortageDir verbosity globalFlags+  distroMap verbosity repo portagePath overlayPath extraArgs++-----------------------------------------------------------------------+-- Utils+-----------------------------------------------------------------------++defaultRepo :: FilePath -> Repo+defaultRepo overlayPath =+  Repo {+      repoKind = Left hackage,+      repoLocalDir = overlayPath </> ".hackport"+    }+  where+    hackage = RemoteRepo server_name uri+    server_name = "hackage.haskell.org"+    uri  = URI "http:" (Just (URIAuth "" server_name "")) "/packages/archive" "" ""++defaultRepoURI :: FilePath -> URI+defaultRepoURI overlayPath =+  case repoKind (defaultRepo overlayPath) of+    Left (RemoteRepo { remoteRepoURI = uri }) -> uri+    Right _                                   -> error $ "defaultRepoURI: unable to get URI for " ++ overlayPath++getServerURI :: String -> IO URI+getServerURI str =+  case parseURI str of+    Just uri -> return uri+    Nothing -> throwEx (InvalidServer str)++reqArgFlag :: ArgPlaceHolder -> SFlags -> LFlags -> Description ->+              (b -> Flag String) -> (Flag String -> b -> b) -> OptDescr b+reqArgFlag ad = reqArg ad (succeedReadE Flag) flagToList++usagePackages :: String -> String -> String+usagePackages op_name pname =+  "Usage: " ++ pname ++ " " ++ op_name ++ " [FLAGS] [PACKAGE]\n\n"+  ++ "Flags for " ++ op_name ++ ":"++usageFlags :: String -> String -> String+usageFlags flag_name pname =+      "Usage: " ++ pname ++ " " ++ flag_name ++ " [FLAGS]\n\n"+      ++ "Flags for " ++ flag_name ++ ":"++getPortageDir :: Verbosity -> GlobalFlags -> IO FilePath+getPortageDir verbosity globalFlags = do+  let portagePathM =  fromFlag (globalPathToPortage globalFlags)+  portagePath <- case portagePathM of+                   Nothing -> Host.portage_dir <$> Host.getInfo+                   Just path -> return path+  exists <- doesDirectoryExist $ portagePath </> "dev-haskell"+  when (not exists) $+    warn verbosity $ "Looks like an invalid portage directory: " ++ portagePath+  return portagePath++-----------------------------------------------------------------------+-- Main+-----------------------------------------------------------------------++data GlobalFlags =+    GlobalFlags { globalVersion :: Flag Bool+                , globalNumericVersion :: Flag Bool+                , globalPathToOverlay :: Flag (Maybe FilePath)+                , globalPathToPortage :: Flag (Maybe FilePath)+                }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags =+    GlobalFlags { globalVersion = Flag False+                , globalNumericVersion = Flag False+                , globalPathToOverlay = Flag Nothing+                , globalPathToPortage = Flag Nothing+                }++globalCommand :: CommandUI GlobalFlags+globalCommand = CommandUI {+    commandName = "",+    commandSynopsis = "",+    commandDescription = Just $ \_pname ->+        "TODO: this is the commandDescription for globalCommand\n",+    commandUsage = \_ -> [],+    commandDefaultFlags = defaultGlobalFlags,+    commandOptions = \_showOrParseArgs ->+        [ 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 ['p'] ["overlay-path"]+            "Override search path list where .hackport/ lives (default list: ['.', paludis-ovls or emerge-ovls])"+            globalPathToOverlay (\ovrl_path flags -> flags { globalPathToOverlay = ovrl_path })+            (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))+        , option [] ["portage-path"]+            "Override path to your portage tree"+            globalPathToPortage (\port_path flags -> flags { globalPathToPortage = port_path })+            (reqArg' "PATH" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))+        ]+    }++mainWorker :: [String] -> IO ()+mainWorker args =+  case commandsRun globalCommand commands args of+    CommandHelp help -> printHelp help+    CommandList opts -> printOptionsList opts+    CommandErrors errs -> printErrors errs+    CommandReadyToGo (globalflags, commandParse) -> do+      case commandParse of+        _ | fromFlag (globalVersion globalflags)        -> printVersion+          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion+        CommandHelp help        -> printHelp help+        CommandList opts        -> printOptionsList opts+        CommandErrors errs      -> printErrors errs+        CommandReadyToGo action -> catchEx (action globalflags) errorHandler+    where+    printHelp help = getProgName >>= putStr . help+    printOptionsList = putStr . unlines+    printErrors errs = do+      putStr (concat (intersperse "\n" errs))+      exitFailure+    printNumericVersion = putStrLn $ display Paths_hackport.version+    printVersion        = putStrLn $ "hackport version "+                                  ++ display Paths_hackport.version+                                  ++ "\nusing cabal-install "+                                  ++ display Paths_cabal_install.version+                                  ++ " and the Cabal library version "+                                  ++ display cabalVersion+    errorHandler :: HackPortError -> IO ()+    errorHandler e = do+      putStrLn (hackPortShowError e)+    commands =+      [ listCommand `commandAddAction` listAction+      , makeEbuildCommand `commandAddAction` makeEbuildAction+      , statusCommand `commandAddAction` statusAction+      , diffCommand `commandAddAction` diffAction+      , updateCommand `commandAddAction` updateAction+      , mergeCommand `commandAddAction` mergeAction+      , distroMapCommand `commandAddAction` distroMapAction+      ]+ main :: IO ()-main = do-    res <- performHPAction hpmain-    case res of-        Right _ -> return ()-        Left err -> do-            hPutStrLn stderr "An error occurred. To get more info run with --verbosity=debug"-            hPutStrLn stderr (hackPortShowError err)+main = getArgs >>= mainWorker
+ Merge.hs view
@@ -0,0 +1,378 @@+{-# OPTIONS -XPatternGuards #-}+{- | Merge a package from hackage to an ebuild.  ++Merging a library+=================++Compile time:+  ghc+  cabal+  build tools+  deps (haskell dependencies)+  extra-libs (c-libs)++Run time:+  ghc+  deps (haskell dependencies)+  extra-libs (c-libs)++RDEPEND="ghc ${DEPS} ${EXTRALIBS}"+DEPEND="${RDEPEND} cabal ${BUILDTOOLS}"++Merging an executable+=====================+Packages with both executable and library must be treated as libraries, as it will impose a stricter DEPEND.++Compile time:+  ghc+  cabal+  build tools+  deps+  extra-libs (c-libs)++Run time:+  extra-libs (c-libs)++RDEPEND="${EXTRALIBS}"+DEPEND="${RDEPEND} ghc cabal ${DEPS} ${BUILDTOOLS}"++-}+module Merge+  ( merge ) where++import Control.Monad.Error+import Control.Exception+import Data.Maybe+import Data.List+import Distribution.Package+import Distribution.Compiler (CompilerId(..), CompilerFlavor(GHC))+import Distribution.PackageDescription ( PackageDescription(..)+                                       , FlagName(..)+                                       , libBuildInfo+                                       , buildInfo+                                       , buildable+                                       , extraLibs+                                       , buildTools+                                       , hasLibs )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import Distribution.Text (display)++import System.Directory ( getCurrentDirectory+                        , setCurrentDirectory+                        , createDirectoryIfMissing+                        )+import System.Cmd (system)+import System.FilePath ((</>))++import qualified Cabal2Ebuild as E+import Cabal2Ebuild+import Error as E++import qualified Distribution.Package as Cabal+import qualified Distribution.Version as Cabal++import Distribution.System (buildPlatform)+import Distribution.Verbosity+import Distribution.Simple.Utils++import Network.URI++import Distribution.Client.IndexUtils ( getAvailablePackages )+import Distribution.Client.HttpUtils ( downloadURI )+import qualified Distribution.Client.PackageIndex as Index+import Distribution.Client.Types++import qualified Portage.PackageId as Portage+import qualified Portage.Version as Portage+import qualified Portage.Dependency as Portage+import qualified Portage.Host as Host+import qualified Portage.Overlay as Overlay+import qualified Portage.Resolve as Portage++import Debug.Trace ( trace )++(<->) :: String -> String -> String+a <-> b = a ++ '-':b++(<.>) :: String -> String -> String+a <.> b = a ++ '.':b++{-+Requested features:+  * Copy the old keywords and ~arch them+  * Add files to darcs?+  * Print diff with the next latest version?+BUGS:+  * Dependencies are always expected to be in dev-haskell+-}++readPackageString :: [String]+                  -> Either HackPortError ( Maybe Portage.Category+                                          , Cabal.PackageName+                                          , Maybe Portage.Version+                                          )+readPackageString args = do+  packageString <-+    case args of+      [] -> Left (ArgumentError "Need an argument, [category/]package[-version]")+      [pkg] -> return pkg+      _ -> Left (ArgumentError ("Too many arguments: " ++ unwords args))+  case Portage.parseFriendlyPackage packageString of+    Just v@(_,_,Nothing) -> return v+    -- we only allow versions we can convert into cabal versions+    Just v@(_,_,Just (Portage.Version _ Nothing [] 0)) -> return v+    _ -> Left (ArgumentError ("Could not parse [category/]package[-version]: " ++ packageString))++++-- | 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 avails Nothing = Just $ maximumBy (comparing packageInfoId) avails+resolveVersion avails (Just ver) = listToMaybe (filter match avails)+  where+    match avail = ver == pkgVersion (packageInfoId avail)++merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> IO ()+merge verbosity repo serverURI args overlayPath = do+  (m_category, user_pName, m_version) <-+    case readPackageString args of+      Left err -> throwEx err+      Right (c,p,m_v) ->+        case m_v of+          Nothing -> return (c,p,Nothing)+          Just v -> case Portage.toCabalVersion v of+                      Nothing -> throwEx (ArgumentError "illegal version")+                      Just ver -> return (c,p,Just ver)++  debug verbosity $ "Category: " ++ show m_category+  debug verbosity $ "Package: " ++ show user_pName+  debug verbosity $ "Version: " ++ show m_version++  let (Cabal.PackageName user_pname_str) = user_pName++  overlay <- Overlay.loadLazy overlayPath+  portage_path <- Host.portage_dir `fmap` Host.getInfo+  portage <- Overlay.loadLazy portage_path+  index <- fmap packageIndex $ getAvailablePackages 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++  -- select a single package taking into account the user specified version+  selectedPkg <-+    case resolveVersion availablePkgs m_version of+      Nothing -> do+        putStrLn "No such version for that package, available versions:"+        forM_ availablePkgs $ \ avail ->+          putStrLn (display . packageInfoId $ avail)+        throwEx (ArgumentError "no such version for that package")+      Just avail -> return avail++  -- print some info+  info verbosity "Selecting package:"+  forM_ availablePkgs $ \ avail -> do+    let match_text | packageInfoId avail == packageInfoId selectedPkg = "* "+                   | otherwise = "- "+    info verbosity $ match_text ++ (display . packageInfoId $ avail)++  let cabal_pkgId = packageInfoId selectedPkg+      norm_pkgId = Portage.normalizeCabalPackageId cabal_pkgId+      norm_pkgName = packageName norm_pkgId+  cat <- Portage.resolveCategory verbosity overlay norm_pkgName++  let pkgGenericDesc = packageDescription selectedPkg+      Right (pkgDesc0, flags) =+        finalizePackageDescription+          [ -- XXX: common things we should enable/disable?+            -- (FlagName "small_base", True) -- try to use small base+            (FlagName "cocoa", False)+          ]+          (\dep -> trace ("accepting dep(?): " ++ display dep) True)+          -- (Nothing :: Maybe (Index.PackageIndex PackageIdentifier))+          buildPlatform+          (CompilerId GHC (Cabal.Version [6,10,4] []))+          [] pkgGenericDesc+      pkgDesc = let deps = [ Dependency pn (Cabal.simplifyVersionRange vr)+                           | Dependency pn vr <- buildDepends pkgDesc0+                           ]+                in pkgDesc0 { buildDepends = deps }++      hasBuildableExes p =+        any (buildable . buildInfo)+        . executables $ p+      treatAsLibrary = (not . hasBuildableExes) pkgDesc && hasLibs pkgDesc++      -- calculate build tools+      bt = [ pkg' -- TODO: currently ignoring version range+           | Cabal.Dependency (Cabal.PackageName pkg ) _range <- buildToolsDeps pkgDesc+           , Just pkg' <- return (lookup pkg buildToolsTable) +           ]++      packageNameResolver s = do+        (Portage.PackageName (Portage.Category p_cat) (Cabal.PackageName pn))+          <- Portage.resolveFullPortageName portage (Cabal.PackageName s)+        return $ E.AnyVersionOf (p_cat </> pn)++  -- calculate extra-libs+  extra <- findCLibs verbosity packageNameResolver pkgDesc+                    +  debug verbosity ("Selected flags: " ++ show flags)+  debug verbosity ("extra-libs: ")+  mapM_ (debug verbosity . show) extra++  debug verbosity ("build-tools:")+  mapM_ (debug verbosity . show) bt++  -- debug verbosity ("Finalized package:\n" ++ showPackageDescription pkgDesc)++               -- TODO: more fixes+               --        * inherit keywords from previous ebuilds+  let d e = if treatAsLibrary+              then Portage.showDepend (cabal_dep e)+                    : "${RDEPEND}"+                    : [ "${BUILDTOOLS}"  | not . null $ build_tools e ]+              else Portage.showDepend (cabal_dep e)+                    : Portage.showDepend (ghc_dep e)+                    : "${RDEPEND}"+                    : [ "${BUILDTOOLS}"  | not . null $ build_tools e ]+                       ++ [ "${HASKELLDEPS}" | not . null $ haskell_deps e ]+      rd e = if treatAsLibrary+              then Portage.showDepend (ghc_dep e)+                    : [ "${HASKELLDEPS}" | not . null $ haskell_deps e ]+                       ++ [ "${EXTRALIBS}" | not . null $ extra_libs e ]+              else [ "${EXTRALIBS}" | not . null $ extra_libs e ]+  let ebuild = fixSrc serverURI (packageId pkgDesc)+               . (\e -> e { depend = d e } )+               . (\e -> e { rdepend = rd e } )+               . (\e -> e { extra_libs  = extra_libs  e ++ extra } )+               . (\e -> e { build_tools = build_tools e ++ bt } )+               $ E.cabal2ebuild pkgDesc++  debug verbosity ("Treat as library: " ++ show treatAsLibrary)+  mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild+  fetchAndDigest+    verbosity+    (overlayPath </> display cat </> display norm_pkgName)+    (display cabal_pkgId <.> "tar.gz")+    (mkUri cabal_pkgId)++findCLibs :: Verbosity -> (String -> Maybe E.Dependency) -> PackageDescription -> IO [E.Dependency]+findCLibs verbosity portageResolver (PackageDescription { library = lib, executables = exes }) = do+  debug verbosity "Mapping extra-libraries into portage packages..."+  -- for extra libs we don't find, maybe look into into installed packages?+  when (not . null $ notFound) $+    warn verbosity ("Could not find portage packages for extra-libraries: " ++ unwords notFound)+  when (not . null $ found) $+    debug verbosity ("Found c-libraries deps: " ++ show found)+  return found+  where+  resolvers = [ staticTranslateExtraLib, portageResolver ]++  resolved = [ chain p resolvers+             | p <- libE ++ exeE+             ] :: [Either String E.Dependency]++  notFound = [ p | Left p <- resolved ]+  found = [ p | Right p <- resolved ]++  chain v [] = Left v+  chain v (f:fs) = case f v of+                     Nothing -> chain v fs+                     Just x -> Right x++  libE = maybe [] (extraLibs.libBuildInfo) lib+  exeE = concatMap (extraLibs.buildInfo) exes++staticTranslateExtraLib :: String -> Maybe E.Dependency+staticTranslateExtraLib lib = lookup lib m+  where+  m = [ ("z", E.AnyVersionOf "sys-libs/zlib")+      , ("bz2", E.AnyVersionOf "sys-libs/bzlib")+      , ("mysqlclient", E.LaterVersionOf (Portage.Version [4,0] Nothing [] 0) "virtual/mysql")+      , ("pq", E.LaterVersionOf (Portage.Version [7] Nothing [] 0) "virtual/postgresql-base")+      , ("ev", E.AnyVersionOf "dev-libs/libev")+      ]++buildToolsDeps :: PackageDescription -> [Cabal.Dependency]+buildToolsDeps (PackageDescription { library = lib, executables = exes }) = cabalDeps+  where+  cabalDeps = depL ++ depE+  depL = maybe [] (buildTools.libBuildInfo) lib+  depE = concatMap (buildTools.buildInfo) exes++buildToolsTable :: [(String, E.Dependency)]+buildToolsTable =+  [ ("happy", E.AnyVersionOf "dev-haskell/happy")+  , ("alex", E.AnyVersionOf "dev-haskell/alex")+  , ("c2hs", E.AnyVersionOf "dev-haskell/c2hs")+  ]++mkUri :: Cabal.PackageIdentifier -> URI+mkUri pid =+   -- example:+   -- http://hackage.haskell.org/packages/archive/Cabal/1.4.0.2/Cabal-1.4.0.2.tar.gz+   fromJust $ parseURI $+    "http://hackage.haskell.org/packages/archive/"+             </> p_name </> p_ver </> p_name <-> p_ver <.> "tar.gz"+  where+    p_ver = display (packageVersion pid)+    p_name = display (packageName pid)++fetchAndDigest :: Verbosity+               -> FilePath -- ^ directory of ebuild+               -> String -- ^ tarball name+               -> URI -- ^ tarball uri+               -> IO ()+fetchAndDigest verbosity ebuildDir tarballName tarballURI =+  withWorkingDirectory ebuildDir $ do+     repo_info <- Host.getInfo+     let tarDestination = (Host.distfiles_dir repo_info) </> tarballName+     downloadURI verbosity tarballURI tarDestination+     -- Just err -> throwEx (E.DownloadFailed (show tarballURI) (show err))+     -- TODO: downloadURI will throw a non-hackport exception if the+     -- download fails+     notice verbosity $ "Saved to " ++ tarDestination+     notice verbosity "Recalculating digests..."+     _ <- system "repoman manifest"+     return ()++withWorkingDirectory :: FilePath -> IO a -> IO a+withWorkingDirectory newDir action = do+  oldDir <- getCurrentDirectory+  bracket+    (setCurrentDirectory newDir)+    (\_ -> setCurrentDirectory oldDir)+    (\_ -> action)++mergeEbuild :: Verbosity -> FilePath -> String -> EBuild -> IO () +mergeEbuild verbosity target cat ebuild = do +  let edir = target </> cat </> name ebuild+      elocal = name ebuild ++"-"++ version ebuild <.> "ebuild"+      epath = edir </> elocal+  createDirectoryIfMissing True edir+  info verbosity $ "Writing " ++ elocal+  writeFile epath (showEBuild ebuild)++fixSrc :: URI -> PackageIdentifier -> EBuild -> EBuild+fixSrc serverURI p ebuild =+  ebuild {+    src_uri = show $ serverURI {+      uriPath =+        uriPath serverURI+          </> display (pkgName p) +          </> display (pkgVersion p) +          </> display (pkgName p) ++ "-" ++ display (pkgVersion p) +          <.> "tar.gz"+      },+    E.homepage = case E.homepage ebuild of+                "" -> "http://hackage.haskell.org/cgi-bin/hackage-scripts/package/"+                        ++ display (pkgName p)+                x -> x+    }
Overlays.hs view
@@ -1,59 +1,71 @@-module Overlays where+module Overlays+    ( getOverlayPath+    ) where -import Control.Monad.Error+import Control.Monad+import Data.List (nub, inits)+import Data.Maybe (maybeToList, listToMaybe, isJust, fromJust) import System.Directory-import Data.Maybe-import Data.List (nub)+import System.FilePath ((</>), splitPath, joinPath) -import Bash-import Action-import Config import Error import CacheFile+import Portage.Host -getOverlayPath :: HPAction String-getOverlayPath = do-    cfg <- getCfg-    case overlayPath cfg of-        Nothing -> do-          tree <- getOverlay `sayDebug` ("Guessing overlay...\n",\tree->"Found '"++tree++"'")-          setOverlayPath $ Just tree-          return tree-        Just tree -> return tree+-- cabal+import Distribution.Verbosity+import Distribution.Simple.Utils ( info ) -getOverlay :: HPAction String-getOverlay = do-	overlays <- getOverlays-	case overlays of-		[] -> throwError NoOverlay-		[x] -> return x-		mul -> search mul+getOverlayPath :: Verbosity -> Maybe FilePath -> IO String+getOverlayPath verbosity override_overlay = do+  overlays <- if isJust override_overlay+                  then do info verbosity $ "Forced " ++ fromJust override_overlay+                          return [fromJust override_overlay]+                  else getOverlays+  case overlays of+    [] -> throwEx NoOverlay+    [x] -> return x+    mul -> search mul   where-  search :: [String] -> HPAction String+  search :: [String] -> IO String   search mul = do-    let loop [] = throwError $ MultipleOverlays mul-        loop (x:xs) = (do-          found <- liftIO (doesFileExist (cacheFile x))-		`sayDebug` ("Checking '"++x++"'...\n",\res->if res then "found.\n" else "not found.")+    let loop [] = throwEx (MultipleOverlays mul)+        loop (x:xs) = do+          info verbosity $ "Checking '" ++ x ++ "'..."+          found <- doesFileExist (cacheFile x)           if found-            then return x-            else loop xs)-    whisper "There are several overlays in your /etc/make.conf"-    mapM (\x-> whisper (" * " ++x)) mul-    whisper "Looking for one with a HackPort cache..."+            then do+              info verbosity "OK!"+              return x+            else do+              info verbosity "Not ok."+              loop xs+    info verbosity "There are several overlays in your configuration."+    mapM_ (info verbosity . (" * " ++)) mul+    info verbosity "Looking for one with a HackPort cache..."     overlay <- loop mul-    whisper ("I choose " ++ overlay)-    whisper "Override my decision with hackport -p /my/overlay"+    info verbosity $ "I choose " ++ overlay+    info verbosity "Override my decision with hackport --overlay /my/overlay"     return overlay -portageOverlays :: HPAction [String]-portageOverlays = runBash "source /etc/make.conf;echo -n $PORTDIR_OVERLAY" >>= (return.words)+getOverlays :: IO [String]+getOverlays = do+  local    <- getLocalOverlay+  overlays <- overlay_list `fmap` getInfo+  return $ nub $ map clean $+                 maybeToList local+              ++ overlays+  where+  clean path = case reverse path of+                '/':p -> reverse p+                _ -> path -paludisOverlays :: HPAction [String]-paludisOverlays = return []+getLocalOverlay :: IO (Maybe FilePath)+getLocalOverlay = do+  curDir <- getCurrentDirectory+  let lookIn = map joinPath . reverse . inits . splitPath $ curDir+  fmap listToMaybe (filterM probe lookIn) -getOverlays :: HPAction [String]-getOverlays = do-    portage <- portageOverlays-    paludis <- paludisOverlays-    return (nub (portage ++ paludis))+  where+    probe dir = doesDirectoryExist (dir </> "dev-haskell")+
P2.hs view
@@ -13,23 +13,23 @@  import Data.Map (Map) import qualified Data.Map as Map-import Data.Maybe import qualified Data.List as List  import System.Directory-import System.IO import System.FilePath  import Text.Regex -import Version+import qualified Portage.Version as Portage +import Distribution.Text+ type Portage = PortageMap [Ebuild] type PortageMap a = Map Package a  data Ebuild = Ebuild {     ePackage :: Package,-    eVersion :: Version,+    eVersion :: Portage.Version,     eFilePath :: FilePath,     ePkgDesc :: Maybe Cabal.GenericPackageDescription }     deriving (Show)@@ -77,12 +77,10 @@                       | (Just v, fn) <- map ((filterVersion package) &&& id) files ]         return (map (uncurry (\v f -> Ebuild (P category package) v f Nothing)) ebuilds) -    filterVersion :: String -> String -> Maybe Version+    filterVersion :: String -> String -> Maybe Portage.Version     filterVersion p fn = do         [vstring] <- matchRegex (ebuildVersionRegex p) fn-        case (parseVersion vstring) of-            Left e -> fail (show e)-            Right v -> return v+        simpleParse vstring      ebuildVersionRegex name = mkRegex ("^"++name++"-(.*)\\.ebuild$")
− Package.hs 
@@ -1,76 +0,0 @@-{-|-    Maintainer  :  Andres Loeh <kosmikus@gentoo.org>-    Stability   :  provisional-    Portability :  haskell98--    Parser for categories and packages.--    Shamelessly borrowed from exi, somewhat modified--}--module Package-  where--import Control.Monad-import Text.ParserCombinators.Parsec--import Version--type Category  =  String-type Package   =  String-type Slot      =  String--getPV :: String -> (Category, Package, Version)-getPV xs      =  case parsePV xs of-                   Left   e  ->-                     error $ "getPV: cat/pkg-ver parse error '" ++ xs ++ "'\n" ++ show e-                   Right  x  ->  x--getP :: String -> (Category, Package)-getP xs       =  case parseP xs of-                   Left   e  ->-                     error $ "getCatPkg: cat/pkg parse error '" ++ xs ++ "'\n" ++ show e-                   Right  x  ->  x--parsePV :: String -> Either ParseError (Category, Package, Version)-parsePV       =  parse (readPV >>= \x -> eof >> return x) "<cat/pkg-ver>"--readPV :: GenParser Char st (Category, Package, Version)-readPV        =  do  cat         <-  readCat-                     char '/'-                     (pkg,mver)  <-  readPkgAndVer-                     case mver of-                       Nothing   ->  fail "readPV: version expected"-                       Just ver  ->  return (cat, pkg, ver)--parseP :: String -> Either ParseError (Category, Package)-parseP        =  parse (readP >>= \x -> eof >> return x) "<cat/pkg>"--readP :: GenParser Char st (Category, Package)-readP         =  do  cat         <-  readCat-                     char '/'-                     (pkg,mver)  <-  readPkgAndVer-                     case mver of-                       Nothing   ->  return (cat, pkg)-                       Just _    ->  error "readCatPkg: unexpected version"--readCat        ::  CharParser st Category-readPkgAndVer  ::  CharParser st (Package,Maybe Version)--readCat        =   many1 (letter <|> digit <|> oneOf "_-")-readPkgAndVer  =   do  pre    <-  many1 (letter <|> digit <|> oneOf "_+")-                       (p,v)  <-  option ("",Nothing)-                                            (do  char '-'-                                                 liftM (\v -> ("",Just v)) readVerOrFail-                                                   <|> liftM (\(p,v) -> ('-':p,v)) readPkgAndVer-                                            )-                       return (pre ++ p,v)--readVerOrFail  ::  CharParser st Version-readVerOrFail  =   try $-                   do  ver    <-  many1 (letter <|> digit <|> oneOf "_+.-")-                       case parseVersion ver of-                           Left   _  -> -                             fail $ "version parse error"-                           Right  x  -> return x-
+ Portage/Cabal.hs view
@@ -0,0 +1,15 @@+module Portage.Cabal+  (fromOverlay) where++import qualified Data.Map as Map++import qualified Distribution.Client.PackageIndex as Cabal++import qualified Portage.Overlay as Portage++fromOverlay :: Portage.Overlay -> Cabal.PackageIndex Portage.ExistingEbuild+fromOverlay overlay = Cabal.fromList $+  [ ebuild+  | (_pn, ebuilds) <- Map.toAscList (Portage.overlayMap overlay)+  , ebuild <- ebuilds+  ]
+ Portage/Dependency.hs view
@@ -0,0 +1,145 @@+module Portage.Dependency (+  Dependency(..),+  showDepend,+  simplify_deps+  ) where++import Portage.Version+import Distribution.Text (display)++import Data.Maybe ( fromJust, catMaybes )+import Data.List ( nub, groupBy, partition, sortBy )+import Data.Ord           (comparing)++type Package = String+type UseFlag = String++data Dependency = AnyVersionOf               Package+                | ThisVersionOf      Version Package   -- =package-version+                | LaterVersionOf     Version Package   -- >package-version+                | EarlierVersionOf   Version Package   -- <package-version+                | OrLaterVersionOf   Version Package   -- >=package-version+                | OrEarlierVersionOf Version Package   -- <=package-version+                | DependEither Dependency Dependency   -- depend || depend+                | DependIfUse  UseFlag    Dependency   -- use? ( depend )+                | ThisMajorOf        Version Package   -- =package-version*+    deriving (Eq,Show)++showDepend :: Dependency -> Package+showDepend (AnyVersionOf         p) = p+showDepend (ThisVersionOf      v p) = "~" ++ p ++ "-" ++ display v+showDepend (LaterVersionOf     v p) = ">" ++ p ++ "-" ++ display v+showDepend (EarlierVersionOf   v p) = "<" ++ p ++ "-" ++ display v+showDepend (OrLaterVersionOf   v p) = ">=" ++ p ++ "-" ++ display v+showDepend (OrEarlierVersionOf v p) = "<=" ++ p ++ "-" ++ display v+showDepend (DependEither       dep1 dep2) = showDepend dep1+                                     ++ " || " ++ showDepend dep2+showDepend (DependIfUse        useflag dep@(DependEither _ _))+                                                = useflag ++ "? " ++ showDepend dep+showDepend (DependIfUse        useflag dep)  = useflag ++ "? ( " ++ showDepend dep++ " )"+showDepend (ThisMajorOf        v p) = "=" ++ p ++ "-" ++ display v ++ "*"++{- Here goes code for dependencies simplification -}++simplify_group_table :: Package ->+                        Maybe Version ->+                        Maybe Version ->+                        Maybe Version ->+                        Maybe Version ->+                        Maybe Version -> [Dependency]++-- simplify_group_table p ol       l        e        oe       exact+-- 1) trivial cases:+simplify_group_table    p Nothing  Nothing  Nothing  Nothing  Nothing  = error $ p ++ ": unsolvable constraints"+simplify_group_table    p (Just v) Nothing  Nothing  Nothing  Nothing  = [OrLaterVersionOf v p]+simplify_group_table    p Nothing  (Just v) Nothing  Nothing  Nothing  = [LaterVersionOf v p]+simplify_group_table    p Nothing  Nothing  (Just v) Nothing  Nothing  = [EarlierVersionOf v p]+simplify_group_table    p Nothing  Nothing  Nothing  (Just v) Nothing  = [OrEarlierVersionOf v p]+simplify_group_table    p Nothing  Nothing  Nothing  Nothing  (Just v) = [ThisVersionOf v p]++-- 2) simplification passes+simplify_group_table    p (Just (Version v1 _ _ _)) Nothing (Just (Version v2 _ _ _)) Nothing Nothing+    -- special case: >=a-v.N a<v.(N+1)   => =a-v.N*+    | (init v1 == init v2) && (last v2 == last v1 + 1) = [ThisMajorOf (Version v1 Nothing [] 0) p]+    | otherwise                                        = [OrLaterVersionOf (Version v1 Nothing [] 0) p, EarlierVersionOf (Version v2 Nothing [] 0) p]++-- TODO: simplify constraints of type: >=a-v1; > a-v2 and such++-- o3) therwise sink:+simplify_group_table    p (Just v)     l@(_)       e@(_)        oe@(_)       exact@(_) =   OrLaterVersionOf v p : simplify_group_table p Nothing  l e oe exact+simplify_group_table    p ol@(Nothing) (Just v)    e@(_)        oe@(_)       exact@(_) =     LaterVersionOf v p : simplify_group_table p ol Nothing e oe exact+simplify_group_table    p ol@(Nothing) l@(Nothing) (Just v)     oe@(_)       exact@(_) =   EarlierVersionOf v p : simplify_group_table p ol l Nothing oe exact+simplify_group_table    p ol@(Nothing) l@(Nothing) e@(Nothing)  (Just v)     exact@(_) = OrEarlierVersionOf v p : simplify_group_table p ol l e Nothing  exact+-- already defined earlier+-- simplify_group_table    p ol@(Nothing) l@(Nothing) e@(Nothing)  oe@(Nothing) (Just v)  = OrEarlierVersionOf v p : simplify_group_table p ol l e oe Nothing++--  >a-v1 >a-v2         => >a-(max v1 v2)+-- key idea: all constraints are enforcing constraints, so we can't get+-- more, than one interval.+simplify_group :: [Dependency] -> [Dependency]+simplify_group [dep@(AnyVersionOf _package)] = [dep]+simplify_group [dep@(ThisMajorOf _v    _p)]  = [dep]+simplify_group deps = simplify_group_table package+                                           min_or_later_v   -- >=+                                           min_later_v      -- >+                                           max_earlier_v    -- <+                                           max_or_earlier_v -- <=+                                           exact_this_v     -- ==+    where+          package = fromJust.getPackage $ head deps+          max_earlier_v    = safe_minimum $ map earlier_v deps+          max_or_earlier_v = safe_minimum $ map or_earlier_v deps+          min_later_v      = safe_maximum $ map later_v deps+          min_or_later_v   = safe_maximum $ map or_later_v deps+          exact_this_v     = case catMaybes (map this_v deps) of+                                  []  -> Nothing+                                  [v] -> Just v+                                  xs  -> error $ "too many exact versions:" ++ show xs+          --+          earlier_v (EarlierVersionOf v _p) = Just v+          earlier_v _                       = Nothing++          or_earlier_v (OrEarlierVersionOf v _p) = Just v+          or_earlier_v _                         = Nothing++          later_v (LaterVersionOf v _p) = Just v+          later_v _                     = Nothing++          or_later_v (OrLaterVersionOf v _p) = Just v+          or_later_v _                     = Nothing++          this_v (ThisVersionOf v  _p) = Just v+          this_v _                     = Nothing+          --+          safe_minimum xs = case catMaybes xs of+                                 [] -> Nothing+                                 xs' -> Just $ minimum xs'+          safe_maximum xs = case catMaybes xs of+                                 [] -> Nothing+                                 xs' -> Just $ maximum xs'++-- divide packages to groups (by package name), simplify groups, merge again+simplify_deps :: [Dependency] -> [Dependency]+simplify_deps deps = (concatMap (simplify_group.nub) $+                       groupBy cmpPkgName $+                         sortBy (comparing getPackageString) groupable)+                     ++ ungroupable+    where (ungroupable, groupable) = partition ((==Nothing).getPackage) deps+          --+          cmpPkgName p1 p2 = cmpMaybe (getPackage p1) (getPackage p2)+          cmpMaybe (Just p1) (Just p2) = p1 == p2+          cmpMaybe _         _         = False+          --+getPackage :: Dependency -> Maybe Package+getPackage (AnyVersionOf package) = Just package+getPackage (ThisVersionOf      _version package) = Just package+getPackage (LaterVersionOf     _version package) = Just package+getPackage (EarlierVersionOf   _version package) = Just package+getPackage (OrLaterVersionOf   _version package) = Just package+getPackage (OrEarlierVersionOf _version package) = Just package+getPackage (DependEither _dependency _Dependency) = Nothing+getPackage (DependIfUse  _useFlag    _Dependency) = Nothing+getPackage (ThisMajorOf        _version package) = Just package+--+getPackageString :: Dependency -> Package+getPackageString dep = maybe "" id $ getPackage dep
+ Portage/Host.hs view
@@ -0,0 +1,102 @@+module Portage.Host+  ( getInfo -- :: IO [(String, String)]+  , LocalInfo(..)+  ) where++import Util (run_cmd)+import Data.Char (isSpace)+import Data.Maybe (fromJust, isJust)+++data LocalInfo =+    LocalInfo { distfiles_dir :: String+              , overlay_list  :: [FilePath]+              , portage_dir   :: FilePath+              }++defaultInfo :: LocalInfo+defaultInfo = LocalInfo { distfiles_dir = "/usr/portage/distfiles"+                        , overlay_list  = []+                        , portage_dir   = "/usr/portage"+                        }++-- query paludis and then emerge+getInfo :: IO LocalInfo+getInfo = fromJust `fmap`+    performMaybes [ (fmap . fmap) parse_paludis_output (run_cmd "paludis --info")+                  , (fmap . fmap) parse_emerge_output  (run_cmd "emerge --info")+                  , return (Just defaultInfo)+                  ]+    where performMaybes [] = return Nothing+          performMaybes (act:acts) =+              do r <- act+                 if isJust r+                     then return r+                     else performMaybes acts++data LocalPaludisOverlay =+    LocalPaludisOverlay { repo_name :: String+                        , format    :: String+                        , location  :: FilePath+                        , distdir   :: FilePath+                        }++bad_paludis_overlay :: LocalPaludisOverlay+bad_paludis_overlay =+    LocalPaludisOverlay { repo_name = undefined+                        , format    = undefined+                        , location  = undefined+                        , distdir   = undefined+                        }++parse_paludis_output :: String -> LocalInfo+parse_paludis_output raw_data =+    foldl updateInfo defaultInfo $ parse_paludis_overlays raw_data+    where updateInfo info po =+              case (format po) of+                  "ebuild" | (repo_name po) /= "gentoo" -- hack, skip main repo+                      -> info{ distfiles_dir = distdir po -- we override last distdir here (FIXME?)+                             , overlay_list  = (location po) : overlay_list info+                             }+                  "ebuild" -- hack, main repo -- (repo_name po) == "gentoo"+                      -> info{ portage_dir = location po }++                  _   -> info++parse_paludis_overlays :: String -> [LocalPaludisOverlay]+parse_paludis_overlays raw_data =+    parse_paludis_overlays' (reverse $ lines raw_data) bad_paludis_overlay++-- parse in reverse order :]+parse_paludis_overlays' :: [String] -> LocalPaludisOverlay -> [LocalPaludisOverlay]+parse_paludis_overlays' [] _ = []+parse_paludis_overlays' (l:ls) info =+    case (words l) of+    -- look for "Repository <repo-name>:"+    ["Repository", r_name] -> info{repo_name = init r_name} :+                                      go bad_paludis_overlay+    -- else - parse attributes+    _ -> case (break (== ':') (refine l)) of+            ("location", ':':value)+                -> go info{location = refine value}+            ("distdir", ':':value)+                -> go info{distdir = refine value}+            ("format", ':':value)+                -> go info{format = refine value}+            _   -> go info+    where go = parse_paludis_overlays' ls+          refine = dropWhile isSpace++parse_emerge_output :: String -> LocalInfo+parse_emerge_output raw_data =+    foldl updateInfo defaultInfo $ lines raw_data+    where updateInfo info str =+              case (break (== '=') str) of+                  ("DISTDIR", '=':value)+                      -> info{distfiles_dir = unquote value}+                  ("PORTDIR", '=':value)+                      -> info{portage_dir = unquote value}+                  ("PORTDIR_OVERLAY", '=':value)+                      -> info{overlay_list = words $ unquote value}+                  _   -> info+          unquote = init . tail
+ Portage/Overlay.hs view
@@ -0,0 +1,169 @@+module Portage.Overlay+  ( ExistingEbuild(..)+  , Overlay(..)+  , load, loadLazy+  , readOverlayByPackage, getDirectoryTree, DirectoryTree++  , reduceOverlay+  , inOverlay+  )+  where++import qualified Portage.PackageId as Portage++import qualified Distribution.Package as Cabal++import Distribution.Text (simpleParse, display)+import Distribution.Simple.Utils ( comparing, equating )++import Data.List as List+import qualified Data.Map as Map+import Data.Map (Map)+import System.Directory (getDirectoryContents, doesDirectoryExist)+import System.IO.Unsafe (unsafeInterleaveIO)+import System.FilePath  ((</>), splitExtension)++--main = do+--  pkgs <- blingProgress . Progress.fromList . readOverlay+--      =<< getDirectoryTree "."+--  putStrLn $ unlines [ display pkg+--                     | pkg <- pkgs+--                     , isNothing (Portage.toCabalPackageId pkg) ]++--TODO: move this to another module:+data ExistingEbuild = ExistingEbuild {+    ebuildId      :: Portage.PackageId,+    ebuildCabalId :: Cabal.PackageIdentifier,+    ebuildPath    :: FilePath+  } deriving (Show,Ord,Eq)++instance Cabal.Package ExistingEbuild where packageId = ebuildCabalId++data Overlay = Overlay {+    overlayPath  :: FilePath,+    overlayMap :: Map Portage.PackageName [ExistingEbuild]+  } deriving Show++inOverlay :: Overlay -> Cabal.PackageId -> Bool+inOverlay overlay pkgId = not (Map.null packages)+  where+    packages = Map.filterWithKey+                (\(Portage.PackageName _cat overlay_pn) ebuilds -> +                    let cabal_pn = Cabal.pkgName pkgId+                        ebs = [ ()+                                  | e <- ebuilds+                                  , let ebuild_cabal_id = ebuildCabalId e+                                  , ebuild_cabal_id == pkgId+                                  ]+                    in cabal_pn == overlay_pn && (not (null ebs))) om+    om = overlayMap overlay++load :: FilePath -> IO Overlay+load dir = fmap (mkOverlay . readOverlay) (getDirectoryTree dir)+  where+    mkOverlay _packages = Overlay {+      overlayPath  = dir+--      TODO: ignore all ebuilds that have no Cabal version number+--    , overlayIndex = PackageIndex.fromList packages+      , overlayMap   = undefined+    }++loadLazy :: FilePath -> IO Overlay+loadLazy dir = fmap (mkOverlay . readOverlayByPackage) (getDirectoryTree dir)+  where+    allowed v = case v of+      (Portage.Version _ Nothing [] _) -> True+      _                                -> False+    a <-> b = a ++ '-':b+    a <.> b = a ++ '.':b++    mkOverlay :: [(Portage.PackageName, [Portage.Version])] -> Overlay+    mkOverlay packages = Overlay {+      overlayPath  = dir,+      overlayMap =+          Map.fromList+            [ (pkgName, [ ExistingEbuild portageId cabalId filepath+                        | version <- allowedVersions+                        , let portageId = Portage.PackageId pkgName version+                        , Just cabalId <- [ Portage.toCabalPackageId portageId ]+                        , let filepath =+                                dir </> display pkgName <-> display version <.> "ebuild"+                        ])+            | (pkgName, allVersions) <- packages+            , let allowedVersions = filter allowed allVersions+           ]+    }++-- make sure there is only one ebuild for each version number (by selecting+-- the highest ebuild version revision)+reduceOverlay :: Overlay -> Overlay+reduceOverlay overlay = overlay { overlayMap = Map.map reduceVersions (overlayMap overlay) }+  where+  versionNumbers (Portage.Version nums _ _ _) = nums+  reduceVersions :: [ExistingEbuild] -> [ExistingEbuild]+  reduceVersions ebuilds = -- gah!+          map (maximumBy (comparing (Portage.pkgVersion . ebuildId)))+          . groupBy (equating (versionNumbers . Portage.pkgVersion . ebuildId))+          . sortBy (comparing (Portage.pkgVersion . ebuildId))+          $ ebuilds++readOverlayByPackage :: DirectoryTree -> [(Portage.PackageName, [Portage.Version])]+readOverlayByPackage tree =+  [ (name, versions name pkgTree)+  | (category, catTree) <- categories        tree+  , (name,     pkgTree) <- packages category catTree+  ]++  where+    categories :: DirectoryTree -> [(Portage.Category, DirectoryTree)]+    categories entries =+      [ (category, entries')+      | Directory dir entries' <- entries+      , Just category <- [simpleParse dir] ]++    packages :: Portage.Category -> DirectoryTree+             -> [(Portage.PackageName, DirectoryTree)]+    packages category entries =+      [ (Portage.PackageName category name, entries')+      | Directory dir entries' <- entries+      , Just name <- [simpleParse dir] ]++    versions :: Portage.PackageName -> DirectoryTree -> [Portage.Version]+    versions name@(Portage.PackageName (Portage.Category category) _) entries =+      [ version+      | File fileName <- entries+      , let (baseName, ext) = splitExtension fileName+      , ext == ".ebuild"+      , let fullName = category ++ '/' : baseName+      , Just (Portage.PackageId name' version) <- [simpleParse fullName]+      , name == name' ]++readOverlay :: DirectoryTree -> [Portage.PackageId]+readOverlay tree = [ Portage.PackageId pkgId version+                   | (pkgId, versions) <- readOverlayByPackage tree+                   , version <- versions+                   ]++type DirectoryTree  = [DirectoryEntry]+data DirectoryEntry = File FilePath | Directory FilePath [DirectoryEntry]++getDirectoryTree :: FilePath -> IO DirectoryTree+getDirectoryTree = dirEntries++  where+    dirEntries :: FilePath -> IO [DirectoryEntry]+    dirEntries dir = do+      names <- getDirectoryContents dir+      sequence+        [ do isDirectory <- doesDirectoryExist path+             if isDirectory+               then do entries <- unsafeInterleaveIO (dirEntries path)+                       return (Directory name entries)+               else    return (File      name)+        | name <- names+        , not (ignore name)+        , let path = dir </> name ]++    ignore ['.']      = True+    ignore ['.', '.'] = True+    ignore _          = False
+ Portage/PackageId.hs view
@@ -0,0 +1,113 @@+-- | Portage package identifiers, which unlike Cabal ones include a category.+--+module Portage.PackageId (+    Category(..),+    PackageName(..),+    PackageId(..),+    Portage.Version(..),+    fromCabalPackageId,+    toCabalPackageId,+    parseFriendlyPackage,+    normalizeCabalPackageName,+    normalizeCabalPackageId+  ) where++import qualified Distribution.Package as Cabal+import Distribution.Text (Text(..))++import qualified Distribution.Compat.ReadP as Parse++import qualified Portage.Version as Portage++import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<>))+import qualified Data.Char as Char (isAlphaNum, isSpace, toLower)+-- import qualified Data.Char as Char (isDigit)+-- import Data.List (intersperse)++newtype Category = Category { unCategory :: String }+  deriving (Eq, Ord, Show, Read)++data PackageName = PackageName Category Cabal.PackageName+  deriving (Eq, Ord, Show, Read)++data PackageId = PackageId { packageId :: PackageName, pkgVersion :: Portage.Version }+  deriving (Eq, Ord, Show, Read)++{-+instance Text PN where+  disp (PN n) = Disp.text n+  parse = do+    ns <- Parse.sepBy1 component (Parse.char '-')+    return (PN (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).+-}++fromCabalPackageId :: Category -> Cabal.PackageIdentifier -> PackageId+fromCabalPackageId category (Cabal.PackageIdentifier name version) =+  PackageId (PackageName category (normalizeCabalPackageName name))+            (Portage.fromCabalVersion version)++normalizeCabalPackageName :: Cabal.PackageName -> Cabal.PackageName+normalizeCabalPackageName (Cabal.PackageName name) =+  Cabal.PackageName (map Char.toLower name)++normalizeCabalPackageId :: Cabal.PackageIdentifier -> Cabal.PackageIdentifier+normalizeCabalPackageId (Cabal.PackageIdentifier name version) =+  Cabal.PackageIdentifier (normalizeCabalPackageName name) version++toCabalPackageId :: PackageId -> Maybe Cabal.PackageIdentifier+toCabalPackageId (PackageId (PackageName _cat name) version) =+  fmap (Cabal.PackageIdentifier name)+           (Portage.toCabalVersion version)++instance Text Category where+  disp (Category c) = Disp.text c+  parse = fmap Category (Parse.munch1 categoryChar)+    where+      categoryChar c = Char.isAlphaNum c || c == '-'++instance Text PackageName where+  disp (PackageName category name) =+    disp category <> Disp.char '/' <> disp name++  parse = do+    category <- parse+    _ <- Parse.char '/'+    name <- parse+    return (PackageName category name)++instance Text PackageId where+  disp (PackageId name version) =+    disp name <> Disp.char '-' <> disp version++  parse = do+    name <- parse+    _ <- Parse.char '-'+    version <- parse+    return (PackageId name version)++parseFriendlyPackage :: String -> Maybe (Maybe Category, Cabal.PackageName, Maybe Portage.Version)+parseFriendlyPackage str =+  case [ p | (p,s) <- Parse.readP_to_S parser str+       , all Char.isSpace s ] of+    [] -> Nothing+    (x:_) -> Just x+  where+  parser = do+    mc <- Parse.option Nothing $ do+      c <- parse+      _ <- Parse.char '/'+      return (Just c)+    p <- parse+    mv <- Parse.option Nothing $ do+      _ <- Parse.char '-'+      v <- parse+      return (Just v)+    return (mc, p, mv)+
+ Portage/Resolve.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE PatternGuards #-}++module Portage.Resolve where++import qualified Portage.Overlay as Overlay+import qualified Portage.PackageId as Portage++import Distribution.Verbosity+import Distribution.Text (display)+import qualified Distribution.Package as Cabal+import Distribution.Simple.Utils++import qualified Data.Map as Map++import Error++import Debug.Trace (trace)++-- | If a package already exist in the overlay, find which category it has.+-- If it does not exist, we default to \'dev-haskell\'.+resolveCategory :: Verbosity -> Overlay.Overlay -> Cabal.PackageName -> IO Portage.Category+resolveCategory verbosity overlay pn = do+  info verbosity "Searching for which category to use..."+  case resolveCategories overlay pn of+    [] -> do+      info verbosity "No previous version of this package, defaulting category to dev-haskell."+      return devhaskell+    [cat] -> do+      info verbosity $ "Exact match of already existing package, using category: "+                         ++ display cat+      return cat+    cats -> do+      warn verbosity $ "Multiple matches of categories: " ++ unwords (map display cats)+      if devhaskell `elem` cats+        then do notice verbosity "Defaulting to dev-haskell"+                return devhaskell+        else do warn verbosity "Multiple matches and no known default. Override by specifying "+                warn verbosity "package category like so  'hackport merge categoryname/package[-version]."+                throwEx (ArgumentError "Specify package category and try again.")+  where+  devhaskell = Portage.Category "dev-haskell"++resolveCategories :: Overlay.Overlay -> Cabal.PackageName -> [Portage.Category]+resolveCategories overlay pn =+  [ cat +  | (Portage.PackageName cat pn') <- Map.keys om+  , pn == Portage.normalizeCabalPackageName pn'+  ]+  where+    om = Overlay.overlayMap overlay++resolveFullPortageName :: Overlay.Overlay -> Cabal.PackageName -> Maybe Portage.PackageName+resolveFullPortageName overlay pn =+  case resolveCategories overlay pn of+    [] -> Nothing+    [cat] -> ret cat+    cats | (cat:_) <- (filter (`elem` cats) priority) -> ret cat+         | otherwise -> trace ("Ambiguous package name: " ++ show pn ++ ", hits: " ++ show cats) Nothing+  where+  ret c = return (Portage.PackageName c pn)+  mkC = Portage.Category+  -- if any of these categories show up in the result list, the match isn't+  -- ambiguous, pick the first match in the list+  priority = [ mkC "dev-haskell"+             , mkC "sys-libs"+             , mkC "dev-libs"+             , mkC "x11-libs"+             , mkC "media-libs"+             , mkC "net-libs"+             , mkC "sci-libs"+             ]+
+ Portage/Version.hs view
@@ -0,0 +1,86 @@+{-|+    Author      :  Andres Loeh <kosmikus@gentoo.org>+    Stability   :  provisional+    Portability :  haskell98++    Version parser, according to Portage spec.++    Shamelessly borrowed from exi, ported from Parsec to ReadP++-}++module Portage.Version (+    Version(..),+    Suffix(..),+    fromCabalVersion,+    toCabalVersion,+  ) where++import qualified Distribution.Version as Cabal++import Distribution.Text (Text(..))++import qualified Distribution.Compat.ReadP as Parse+import qualified Text.PrettyPrint as Disp+import Text.PrettyPrint ((<>))+import qualified Data.Char as Char (isAlpha, isDigit)++data Version = Version [Int]         -- [1,42,3] ~= 1.42.3+                       (Maybe Char)  -- optional letter+                       [Suffix]+                       Int           -- revision, 0 means none+  deriving (Eq, Ord, Show, Read)++data Suffix = Alpha Int | Beta Int | Pre Int | RC Int | P Int+  deriving (Eq, Ord, Show, Read)++fromCabalVersion :: Cabal.Version -> Version+fromCabalVersion (Cabal.Version nums _tags) = Version nums Nothing [] 0++toCabalVersion :: Version -> Maybe Cabal.Version+toCabalVersion (Version nums Nothing [] _) = Just (Cabal.Version nums [])+toCabalVersion _                           = Nothing++instance Text Version where+  disp (Version ver c suf rev) =+    dispVer ver <> dispC c <> dispSuf suf <> dispRev rev+    where+      dispVer   = Disp.hcat . Disp.punctuate (Disp.char '.') . map Disp.int+      dispC     = maybe Disp.empty Disp.char+      dispSuf   = Disp.hcat . map disp+      dispRev 0 = Disp.empty+      dispRev n = Disp.text "-r" <> Disp.int n++  parse = do+    ver <- Parse.sepBy1 digits (Parse.char '.')+    c   <- Parse.option Nothing (fmap Just (Parse.satisfy Char.isAlpha))+    suf <- Parse.many parse+    rev <- Parse.option 0 (Parse.string "-r" >> digits)+    return (Version ver c suf rev)++instance Text Suffix where+  disp suf = case suf of+    Alpha n -> Disp.text "_alpha" <> dispPos n+    Beta n  -> Disp.text "_beta"  <> dispPos n+    Pre n   -> Disp.text "_pre"   <> dispPos n+    RC n    -> Disp.text "_rc"    <> dispPos n+    P  n    -> Disp.text "_p"     <> dispPos n++    where+      dispPos :: Int -> Disp.Doc+      dispPos 0 = Disp.empty+      dispPos n = Disp.int n++  parse = Parse.char '_'+       >> Parse.choice+    [ Parse.string "alpha" >> fmap Alpha maybeDigits+    , Parse.string "beta"  >> fmap Beta  maybeDigits+    , Parse.string "pre"   >> fmap Pre   maybeDigits+    , Parse.string "rc"    >> fmap RC    maybeDigits+    , Parse.string "p"     >> fmap P     maybeDigits+    ]+    where+      maybeDigits = Parse.option 0 digits++digits :: Parse.ReadP r Int+digits = fmap read (Parse.munch1 Char.isDigit)
+ Progress.hs view
@@ -0,0 +1,62 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Progress+-- Copyright   :  (c) Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  duncan@haskell.org+-- Portability :  portable+--+-- Common types for dependency resolution.+-----------------------------------------------------------------------------+module Progress (+    Progress(..),+    fold, unfold, fromList,+  ) where++import Prelude hiding (fail)++-- | 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 'Progress' 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+--+fold :: (step -> a -> a) -> (fail -> a) -> (done -> a)+     -> Progress step fail done -> a+fold step fail done = go+  where+    go (Step s p) = step s (go p)+    go (Fail f)   = fail f+    go (Done r)   = done r++unfold :: (s -> Either (Either fail done) (step, s))+       -> s -> Progress step fail done+unfold f = go+  where+    go s = case f s of+      Left (Left  fail) -> Fail fail+      Left (Right done) -> Done done+      Right (step, s')  -> Step step (go s')++fromList :: [a] -> Progress () b [a]+fromList xs0 = unfold next xs0+  where+    next []     = Left (Right xs0)+    next (_:xs) = Right ((), xs)++instance Functor (Progress step fail) where+  fmap f = fold Step Fail (Done . f)++instance Monad (Progress step fail) where+  return a = Done a+  p >>= f  = fold Step Fail f p
+ README view
@@ -0,0 +1,111 @@+Hackport+========++About+-----++Hackport is a utility application for Gentoo Linux to ease the tasks for the+Haskell Project.++The main purpose for Hackport is to interact with Hackage and create+Ebuilds from Cabal packages. It also does handy functions to compare+hackage, the overlay and the portage tree.++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.++    'hackport merge <package>'+        Create a Gentoo Linux Ebuild for hackage package named <package>.+        The category defaults to dev-haskell, but is overridden if an older+        version has been merged previously to another category. The category+        can also be overridden with the syntax category/package. Example:++            $ hackport merge x11-wm/xmonad++        Hackport will make an ebuild that uses the haskell-cabal eclass, and+        set the following properties:++        PN (package name)+            Package name converted into lower case+        PV (package version)+            Package version with tags dropped.+        KEYWORDS+            Defaults to ~amd64 ~x86+        CABAL_FEATURES+            Set to "bin" for executables, and "lib haddock profile" for+            libraries. Packages that contains both a binary and library will+            get the union.+        DEPEND+            GHC dependency defaults to >=dev-lang/ghc-6.6.1.+            Cabal dependency is fetched from Cabal field 'Cabal-Version'.+            All other package dependencies are converted into gentoo syntax.+            Range dependencies are flattened and usually needs manual+            tweaking.+        DESCRIPTION+            From Synopsis if it is non-empty, otherwise Description.+        HOMEPAGE+            From Homepage+        SRC_URI+            From package url+        LICENSE +            From cabal license converted into gentoo licenses+        SLOT+            Defaults to "0"++    'hackport diff [missing|additions|newer|common]'+        Prints a list showing a diff between hackage and the overlay.+        For each package it shows the latest version in both hackage and the+        overlay.+++        Optional parameters:+            'all', the default action+                List all packages.+            'missing'+                List packages that exist in hackage but not in the overlay,+                or where the hackage version is more recent.+            'additions'+                List packages only in the overlay, or where the overlay has+                a more recent version.+            'newer'+                List packages where hackage has a more recent version.+            'common'+                List packages where hackage and the overlay has the same+                version.++    'hackport status [toportage]'+        Provides an overview comparing the overlay to the portage tree.+        It will teel you, for each package and version, if the package exist++            - only in the portage tree+            - only in the overlay+            - both in the portage tree and the overlay+            - both in the portage tree and the overlay,+                but the ebuilds are not identical++        Optional parameters:+            '--to-portage'+                Only print packages that are likely to be interesting to+                move to the portage tree.+                It will print packages when they exist in both portage and+                the overlay, and:+                    - the ebuilds differ, or+                    - the overlay has a more recent version++    'hackport make-ebuild <path/to/package.ebuild>'+        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.++-------++    Henning Günther+    Duncan Coutts+    Lennart Kolmodin
Status.hs view
@@ -2,15 +2,11 @@     ( FileStatus(..)     , fromStatus     , status-    , statusAction+    , runStatus     ) where -import Action import AnsiColor-import Bash import P2-import Utils-import Overlays  import Control.Monad.State @@ -24,6 +20,11 @@  import qualified Data.Traversable as T +-- cabal+import Distribution.Verbosity+import Distribution.Simple.Utils (equating, comparing)+import Distribution.Text(display)+ data FileStatus a         = Same a         | Differs a a@@ -32,7 +33,7 @@         deriving (Show,Eq)  instance Ord a => Ord (FileStatus a) where-    compare x y = compare (fromStatus x) (fromStatus y)+    compare = comparing fromStatus  instance Functor FileStatus where     fmap f st =@@ -50,19 +51,17 @@         OverlayOnly a -> a         PortageOnly a -> a -status :: HPAction (Map Package [FileStatus Ebuild])-status = do-    portdir <- getPortdir-    overlayPath <- getOverlayPath-    overlay <- liftIO $ readPortageTree overlayPath-    portage <- liftIO $ readPortagePackages portdir (Map.keys overlay)+status :: Verbosity -> FilePath -> FilePath -> IO (Map Package [FileStatus Ebuild])+status _verbosity portdir overlayPath = do+    overlay <- readPortageTree overlayPath+    portage <- readPortagePackages portdir (Map.keys overlay)     let (over, both, port) = portageDiff overlay portage      both' <- T.forM both $ mapM $ \e -> liftIO $ do             -- can't fail, we know the ebuild exists in both portagedirs             -- also, one of them is already bound to 'e'-            let (Just e1) = lookupEbuildWith portage (ePackage e) (comparing eVersion e)-                (Just e2) = lookupEbuildWith overlay (ePackage e) (comparing eVersion e)+            let (Just e1) = lookupEbuildWith portage (ePackage e) (equating eVersion e)+                (Just e2) = lookupEbuildWith overlay (ePackage e) (equating eVersion e)             eq <- equals (eFilePath e1) (eFilePath e2)             return $ if eq                         then Same e@@ -75,14 +74,17 @@                 ]     return meld -statusAction :: String -> HPAction ()-statusAction action = do-    let pkgFilter =-            case action of-                "" -> id-                "toportage" -> toPortageFilter-    pkgs <- status-    statusPrinter (pkgFilter pkgs)+runStatus :: Verbosity -> FilePath -> FilePath -> Bool -> [String] -> IO ()+runStatus verbosity portdir overlayPath toPortageFlag pkgs = do+  let pkgFilter | toPortageFlag = toPortageFilter+                | otherwise = id+  tree0 <- status verbosity portdir overlayPath+  let tree = pkgFilter tree0+  if (null pkgs)+    then statusPrinter tree+    else forM_ pkgs $ \pkg -> do+          let filteredTree = Map.filterWithKey (\k _ -> pPackage k == pkg) tree+          statusPrinter filteredTree  -- |Only return packages that seems interesting to sync to portage; --@@ -104,18 +106,18 @@         then Just sts         else Nothing -statusPrinter :: Map Package [FileStatus Ebuild] -> HPAction ()+statusPrinter :: Map Package [FileStatus Ebuild] -> IO () statusPrinter packages = do-    liftIO $ putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"-    liftIO $ putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"-    liftIO $ putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"-    liftIO $ putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree"-    forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> liftIO $ do+    putStrLn $ toColor (Same "Green") ++ ": package in portage and overlay are the same"+    putStrLn $ toColor (Differs "Yellow" "") ++ ": package in portage and overlay differs"+    putStrLn $ toColor (OverlayOnly "Red") ++ ": package only exist in the overlay"+    putStrLn $ toColor (PortageOnly "Magenta") ++ ": package only exist in the portage tree"+    forM_ (Map.toAscList packages) $ \(pkg, ebuilds) -> do         let (P c p) = pkg         putStr $ c ++ '/' : bold p         putStr " "         forM_ ebuilds $ \e -> do-            putStr $ toColor (fmap (show . eVersion) e)+            putStr $ toColor (fmap (display . eVersion) e)             putChar ' '         putStrLn "" @@ -131,12 +133,12 @@ portageDiff :: Portage -> Portage -> (Portage, Portage, Portage) portageDiff p1 p2 = (in1, ins, in2)     where ins = Map.filter (not . null) $-                    Map.intersectionWith (List.intersectBy $ comparing eVersion) p1 p2+                    Map.intersectionWith (List.intersectBy $ equating eVersion) p1 p2           in1 = difference p1 p2           in2 = difference p2 p1           difference x y = Map.filter (not . null) $                        Map.differenceWith (\xs ys ->-                        let lst = foldr (List.deleteBy (comparing eVersion)) xs ys in+                        let lst = foldr (List.deleteBy (equating eVersion)) xs ys in                         if null lst                             then Nothing                             else Just lst@@ -151,7 +153,7 @@     return (equal' f1 f2)  equal' :: L.ByteString -> L.ByteString -> Bool-equal' = comparing essence+equal' = equating essence     where     essence = filter (not . isEmpty) . filter (not . isComment) . L.lines     isComment = L.isPrefixOf (L.pack "#") . L.dropWhile isSpace
+ TODO view
@@ -0,0 +1,35 @@++Easier+====++* Document the commands in Main.hs with text from README.+   commandDescription and commandSynopsis fields in the CommandUI records++* continue on the CLI. see what additional flags the commands need, if there+    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+      (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+    the cabal field to describe c libs should be translated if we know the+    proper gentoo package name.++* see if PackageIndex and IndexUtils from cabal install can be used instead of Index+    see Distribution.Simple.PackageIndex+    PackageIndex Ebuild?++* make clear destinction of Hackage.Package and Portage.Package (notice the namespaces)+   Look into Portage, P2 and whatever other hacks there might be and+   properly separate them into the two categories.+   See the already existing Portage.PackageId++* look into Ebuild's field ePkgDesc and its uses++* Merge the separate tool keyword-stat into hackport, and make it use the+    hackport API.+    See http://code.haskell.org/gentoo/keyword-stat/
+ Util.hs view
@@ -0,0 +1,31 @@+{-|+    Author      :  Sergei Trofimovich <slyfox@inbox.ru>+    Stability   :  experimental+    Portability :  haskell98++    Ungrouped utilitary stuff lays here until someone finds better place for it :]+-}++module Util+    ( run_cmd -- :: String -> IO (Maybe String)+    ) where++import System.IO+import System.Process+import System.Exit (ExitCode(..))++-- 'run_cmd' executes command and returns it's standard output+-- as 'String'.++run_cmd :: String -> IO (Maybe String)+run_cmd cmd = do (hI, hO, hE, hProcess) <- runInteractiveCommand cmd+                 hClose hI+                 output <- hGetContents hO+                 errors <- hGetContents hE -- TODO: propagate error to caller+                 length output `seq` hClose hO+                 length errors `seq` hClose hE++                 exitCode <- waitForProcess hProcess+                 return $ if (output == "" || exitCode /= ExitSuccess)+                          then Nothing+                          else Just output
− Utils.hs 
@@ -1,7 +0,0 @@-module Utils where--comparing :: (Eq b) => (a -> b) -> a -> a -> Bool-comparing f x y = f x == f y--compareWith :: (Ord b) => (a -> b) -> a -> a -> Ordering-compareWith f x y = compare (f x) (f y)
− Version.hs 
@@ -1,122 +0,0 @@-{-|-    Maintainer  :  Andres Loeh <kosmikus@gentoo.org>-    Stability   :  provisional-    Portability :  haskell98--    Version parser, according to Portage spec.--    Shamelessly borrowed from exi, somewhat modified---}--module Version-  (-  Version(),-  Suffix(..),-  fromCabalVersion,-  showVersion,-  showSuffix,-  readVersion,-  parseVersion,-  getVersion,-  showRevPR-  ) where--import qualified Distribution.Version as Cabal-import Control.Monad-import Data.List-import Data.Maybe-import Text.ParserCombinators.Parsec--data Version   =  Version   [Int]         -- [1,42,3] ~= 1.42.3-                            (Maybe Char)  -- optional letter-                            [Suffix]-                            Int           -- revision, 0 means none-  deriving (Eq, Ord)--data Suffix   =  Alpha Int | Beta Int | Pre Int | RC Int | P_ Int-  deriving (Eq,Ord)--instance Show Version where-  show = showVersion--instance Show Suffix where-  show = showSuffix--showVersion :: Version -> String-showVersion (Version ver c suf rev)-        = showver ++ showc ++ concatMap showSuffix suf ++ showRev rev-  where showver  =  concat . intersperse "." . map show $ ver-        showc    =  maybe "" (:[]) c--showSuffix :: Suffix -> String-showSuffix (Alpha n)  =  "_alpha" ++ showPos n-showSuffix (Beta n)   =  "_beta"  ++ showPos n-showSuffix (Pre n)    =  "_pre"   ++ showPos n-showSuffix (RC n)     =  "_rc"    ++ showPos n-showSuffix (P_ n)     =  "_p"     ++ showPos n--showPos :: Int -> String-showPos 0 = ""-showPos n = show n--showRev :: Int -> String-showRev 0 = ""-showRev n = "-r" ++ show n--showRevPR :: Int -> String-showRevPR n = "r" ++ show n--fromCabalVersion :: Cabal.Version -> Version-fromCabalVersion (Cabal.Version nums _tags) =-    Version nums Nothing [] 0---- | Function to call if you want to parse a version number.-getVersion :: String -> Version-getVersion ver = case parseVersion ver of-                   Left   _  ->-                     error $ "getVersion: version parse error '" ++ ver ++ "'"-                   Right  x  ->  x--parseVersion :: String -> Either ParseError Version-parseVersion = parse (readVersion >>= \x -> eof >> return x) "<version number>"--readVersion :: CharParser st Version-readVersion =  do  (ver,  _verr)  <-  readVer-                   (c,    _cr  )  <-  readC-                   (suf,  _sufr)  <-  readSufs-                   (rev,  _revr)  <-  readRev-                   return (Version ver c suf rev)--readVer      ::  CharParser st ([Int],          String)-readNum      ::  CharParser st (Int,            String)-readC        ::  CharParser st (Maybe Char,     String)-readSuf      ::  CharParser st (Suffix,         String)-readSufType  ::  CharParser st (Int -> Suffix,  String)-readSufs     ::  CharParser st ([Suffix],       String)-readRev      ::  CharParser st (Int,            String)--readVer      =  liftM ((\(x,y) -> (x, concat . intersperse "." $ y)) . unzip) (sepBy1 readNum (char '.'))-readNum      =  do  ds <- many1 digit-                    case read ds of-                      n -> return (n,ds)-readC        =  option (Nothing,  "")  (liftM (\x -> (Just x, [x])) letter)-readSuf      =  do  char '_'-                    (f,sr)  <-  readSufType-                    (n,nr)  <-  option (0, "") readNum-                    return (f n,"_" ++ sr ++ nr)--readSufType  =  choice [-                          liftM (\x -> (Alpha,  x)) (try $ string "alpha"),-                          liftM (\x -> (Beta,   x)) (try $ string "beta" ),-                          liftM (\x -> (Pre,    x)) (try $ string "pre"  ),-                          liftM (\x -> (RC,     x)) (try $ string "rc"   ),-                          liftM (\x -> (P_,     x)) (try $ string "p"    )-                       ]--readSufs     =  fmap ( ( \ (x,y) -> (x, concat y) ) . unzip ) (many readSuf)--readRev      =  option (0,        "")  (  do  rr      <- string "-r"-                                              (n,nr)  <-  readNum-                                              return (n,rr ++ nr)-                                       )
+ cabal-install-0.8.2/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-install-0.8.2/Distribution/Client/BuildReports/Storage.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- 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.8.2/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-install-0.8.2/Distribution/Client/BuildReports/Upload.hs view
@@ -0,0 +1,71 @@+{-# 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.8.2/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-install-0.8.2/Distribution/Client/Config.hs view
@@ -0,0 +1,565 @@+-----------------------------------------------------------------------------+-- |+-- 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+         , Flag, toFlag, flagToMaybe, fromFlagOrDefault, flagToList )+import Distribution.Simple.InstallDirs+         ( InstallDirs(..), defaultInstallDirs+         , PathTemplate, toPathTemplate, fromPathTemplate )+import Distribution.ParseUtils+         ( FieldDescr(..), liftField+         , ParseResult(..), locatedErrorMsg, showPWarning+         , readFields, warning, lineNo+         , simpleField, listField, parseFilePathQ, showFilePath, parseTokenQ )+import qualified Distribution.ParseUtils as ParseUtils+         ( Field(..) )+import qualified Distribution.Text as Text+         ( Text(..) )+import Distribution.ReadE+         ( readP_to_E )+import Distribution.Simple.Command+         ( CommandUI(commandOptions), commandDefaultFlags, ShowOrParseArgs(..)+         , viewAsFieldDescr, OptionField, option, reqArg )+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+  return mempty {+    savedConfigureFlags  = mempty {+      configHcFlavor     = toFlag defaultCompiler,+      configUserInstall  = toFlag defaultUserInstall,+      configVerbosity    = toFlag normal+    },+    savedUserInstallDirs = mempty {+      prefix             = toFlag (toPathTemplate userPrefix)+    }+  }++-- | 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+  return mempty {+    savedGlobalFlags     = mempty {+      globalCacheDir     = toFlag cacheDir,+      globalRemoteRepos  = [defaultRemoteRepo]+    },+    savedInstallFlags    = mempty {+      installSummaryFile = [toPathTemplate (logsDir </> "build.log")],+      installBuildReports= toFlag AnonymousReports+    }+  }++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"++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++--TODO: this is now exported in Cabal-1.5+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)++    reqArgFlag ad = reqArg ad (fmap toFlag (readP_to_E err parseFilePathQ))+                              (map (show . showFilePath) . flagToList)+      where err _ = "paths with spaces must use Haskell String syntax"
+ cabal-install-0.8.2/Distribution/Client/Configure.hs view
@@ -0,0 +1,205 @@+-----------------------------------------------------------------------------+-- |+-- 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 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+                 -> Maybe (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) `fmap` installed+      localPkg = AvailablePackage {+        packageInfoId                = packageId pkg,+        Available.packageDescription = pkg,+        packageSource                = LocalUnpackedPackage+      }+      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.8.2/Distribution/Client/Dependency.hs view
@@ -0,0 +1,233 @@+-----------------------------------------------------------------------------+-- |+-- 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,++    dependencyConstraints,+    dependencyTargets,++    PackagesPreference(..),+    PackagesPreferenceDefault(..),+    PackagePreference(..),++    upgradableDependencies,+  ) where++import Distribution.Client.Dependency.Bogus (bogusResolver)+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(..), Package(..), PackageFixedDeps(..) )+import Distribution.Version+         ( VersionRange, anyVersion, orLaterVersion, isAnyVersion )+import Distribution.Compiler+         ( CompilerId(..) )+import Distribution.System+         ( Platform )+import Distribution.Simple.Utils (comparing)+import Distribution.Client.Utils (mergeBy, MergeResult(..))++import Data.List (maximumBy)+import Data.Monoid (Monoid(mempty))+import Data.Maybe (fromMaybe)+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+                    -> Maybe (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+                                -> Maybe (PackageIndex InstalledPackage)+                                -> PackageIndex AvailablePackage+                                -> PackagesPreference+                                -> [PackageConstraint]+                                -> [PackageName]+                                -> Progress String String InstallPlan+resolveDependenciesWithProgress platform comp (Just installed) =+  dependencyResolver defaultResolver platform comp installed++resolveDependenciesWithProgress platform comp Nothing =+  dependencyResolver bogusResolver platform comp mempty++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++dependencyResolver+  :: DependencyResolver+  -> Platform -> CompilerId+  -> PackageIndex InstalledPackage+  -> PackageIndex AvailablePackage+  -> PackagesPreference+  -> [PackageConstraint]+  -> [PackageName]+  -> Progress String String InstallPlan+dependencyResolver resolver platform comp installed available+                            pref constraints targets =+  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+    $ resolver 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++-- | 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++-- | 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.8.2/Distribution/Client/Dependency/Bogus.hs view
@@ -0,0 +1,129 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Dependency.Bogus+-- Copyright   :  (c) David Himmelstrup 2005, Bjorn Bringert 2007+--                    Duncan Coutts 2008+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A dependency resolver for when we do not know what packages are installed.+-----------------------------------------------------------------------------+module Distribution.Client.Dependency.Bogus (+    bogusResolver+  ) where++import Distribution.Client.Types+         ( AvailablePackage(..), ConfiguredPackage(..) )+import Distribution.Client.Dependency.Types+         ( DependencyResolver, Progress(..)+         , PackageConstraint(..), PackagePreferences(..) )+import qualified Distribution.Client.InstallPlan as InstallPlan++import Distribution.Package+         ( PackageName, PackageIdentifier(..), Dependency(..)+         , Package(..), packageVersion )+import Distribution.PackageDescription+         ( GenericPackageDescription(..), CondTree(..), FlagAssignment )+import Distribution.PackageDescription.Configuration+         ( finalizePackageDescription )+import qualified Distribution.Client.PackageIndex as PackageIndex+import Distribution.Client.PackageIndex (PackageIndex)+import Distribution.Version+         ( VersionRange, anyVersion, intersectVersionRanges, withinRange )+import Distribution.Simple.Utils+         ( comparing )+import Distribution.Text+         ( display )++import Data.List+         ( maximumBy )+import Data.Maybe+         ( fromMaybe )+import qualified Data.Map as Map++-- | This resolver thinks that every package is already installed.+--+-- We need this for hugs and nhc98 which do not track installed packages.+-- We just pretend that everything is installed and hope for the best.+--+bogusResolver :: DependencyResolver+bogusResolver platform comp _ available+              preferences constraints targets =+    resolveFromAvailable []+      (combineConstraints preferences constraints targets)+  where+    resolveFromAvailable chosen [] = Done chosen+    resolveFromAvailable chosen ((name, verConstraint, flags, verPref): deps) =+      case latestAvailableSatisfying available name verConstraint verPref of+        Nothing  -> Fail ("Unresolved dependency: " ++ display dep)+        Just apkg@(AvailablePackage _ pkg _) ->+          case finalizePackageDescription flags none platform comp [] pkg of+            Right (_, flags') -> Step msg (resolveFromAvailable chosen' deps)+              where+                msg     = "selecting " ++ display (packageId pkg)+                cpkg    = fudgeChosenPackage apkg flags'+                chosen' = InstallPlan.Configured cpkg : chosen+            _ -> error "bogusResolver: impossible happened"+          where+            none :: Dependency -> Bool+            none = const True+      where+        dep = Dependency name verConstraint++fudgeChosenPackage :: AvailablePackage -> FlagAssignment -> ConfiguredPackage+fudgeChosenPackage (AvailablePackage pkgid pkg source) flags =+  ConfiguredPackage (AvailablePackage pkgid (stripDependencies pkg) source)+                    flags ([] :: [PackageIdentifier]) -- empty list of deps+  where+    -- | Pretend that a package has no dependencies. Go through the+    -- 'GenericPackageDescription' and strip them all out.+    --+    stripDependencies :: GenericPackageDescription -> GenericPackageDescription+    stripDependencies gpkg = gpkg {+        condLibrary     = fmap stripDeps (condLibrary gpkg),+        condExecutables = [ (name, stripDeps tree)+                          | (name, tree) <- condExecutables gpkg ]+      }+    stripDeps :: CondTree v [Dependency] a -> CondTree v [Dependency] a+    stripDeps = mapTreeConstrs (const [])++    mapTreeConstrs :: (c -> c) -> CondTree v c a -> CondTree v c a+    mapTreeConstrs f (CondNode a c ifs) = CondNode a (f c) (map g ifs)+      where+        g (cnd, t, me) = (cnd, mapTreeConstrs f t, fmap (mapTreeConstrs f) me)++combineConstraints :: (PackageName -> PackagePreferences)+                   -> [PackageConstraint]+                   -> [PackageName]+                   -> [(PackageName, VersionRange, FlagAssignment, VersionRange)]+combineConstraints preferences constraints targets =+  [ (name, ver, flags, pref)+  | name <- targets+  , let ver   = fromMaybe anyVersion (Map.lookup name versionConstraints)+        flags = fromMaybe []         (Map.lookup name flagsConstraints)+        PackagePreferences pref _ = preferences name ]+  where+    versionConstraints = Map.fromListWith intersectVersionRanges+      [ (name, versionRange)+      | PackageVersionConstraint name versionRange <- constraints ]++    flagsConstraints =  Map.fromListWith (++)+      [ (name, flags)+      | PackageFlagsConstraint name flags <- constraints ]++-- | Gets the best available package satisfying a dependency.+--+latestAvailableSatisfying :: PackageIndex AvailablePackage+                          -> PackageName -> VersionRange -> VersionRange+                          -> Maybe AvailablePackage+latestAvailableSatisfying index name versionConstraint versionPreference =+  case PackageIndex.lookupDependency index dep of+    []   -> Nothing+    pkgs -> Just (maximumBy best pkgs)+  where+    dep  = Dependency name versionConstraint+    best = comparing (\p -> (isPreferred p, packageVersion p))+    isPreferred p = packageVersion p `withinRange` versionPreference
+ cabal-install-0.8.2/Distribution/Client/Dependency/TopDown.hs view
@@ -0,0 +1,776 @@+-----------------------------------------------------------------------------+-- |+-- 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.8.2/Distribution/Client/Dependency/TopDown/Constraints.hs view
@@ -0,0 +1,316 @@+-----------------------------------------------------------------------------+-- |+-- 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.8.2/Distribution/Client/Dependency/TopDown/Types.hs view
@@ -0,0 +1,93 @@+-----------------------------------------------------------------------------+-- |+-- 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.8.2/Distribution/Client/Dependency/Types.hs view
@@ -0,0 +1,114 @@+-----------------------------------------------------------------------------+-- |+-- 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.8.2/Distribution/Client/Fetch.hs view
@@ -0,0 +1,192 @@+-----------------------------------------------------------------------------+-- |+-- 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(..) )+import Distribution.Client.Dependency+         ( resolveDependenciesWithProgress+         , 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.Package+         ( PackageIdentifier, 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.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+  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+      -> [UnresolvedDependency]+      -> IO ()+fetch verbosity packageDBs repos comp conf deps = do+  installed <- getInstalledPackages verbosity comp packageDBs conf+  AvailablePackageDb available availablePrefs+            <- getAvailablePackages verbosity repos+  deps' <- IndexUtils.disambiguateDependencies available deps++  let -- 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).+      installed' = fmap (hideGivenDeps deps') installed+      hideGivenDeps pkgs index =+        foldr PackageIndex.deletePackageName index+          [ name | UnresolvedDependency (Dependency name _) _ <- pkgs ]++  let  progress = resolveDependenciesWithProgress+                   buildPlatform (compilerId comp)+                   installed' available+                   (PackagesPreference PreferLatestForSelected+                     [ PackageVersionPreference name ver+                     | (name, ver) <- Map.toList availablePrefs ])+                   (dependencyConstraints deps')+                   (dependencyTargets deps')+  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)+                            (return . Left) (return . Right) progress+  case maybePlan of+    Left message -> die message+    Right pkgs   -> do+      ps <- filterM (fmap not . isFetched)+              [ pkg | (InstallPlan.Configured+                        (InstallPlan.ConfiguredPackage pkg _ _))+                          <- InstallPlan.toList pkgs ]+      when (null ps) $+        notice verbosity $ "No packages need to be fetched. "+                        ++ "All the requested packages are already cached."++      sequence_ +        [ fetchPackage verbosity repo pkgid+        | (AvailablePackage pkgid _ (RepoTarballPackage repo)) <- ps ]++-- |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.8.2/Distribution/Client/Haddock.hs view
@@ -0,0 +1,101 @@+-----------------------------------------------------------------------------+-- |+-- 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 "htemp" $ \tempDir -> do++        let flags = ["--gen-contents", "--gen-index", "--odir="++tempDir] +                    ++ map (\(i,h) -> "--read-interface=" ++ h ++ "," ++ i) 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 [Char])+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.8.2/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.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.8.2/Distribution/Client/IndexUtils.hs view
@@ -0,0 +1,301 @@+-----------------------------------------------------------------------------+-- |+-- 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,+  readRepoIndex,+  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 qualified Codec.Compression.GZip as GZip (decompress)+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 (Maybe (PackageIndex InstalledPackage))+getInstalledPackages verbosity comp packageDbs conf =+  fmap (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 'cabal 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 "+          ++ "'cabal 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+        . GZip.decompress+      =<< 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 'cabal 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.8.2/Distribution/Client/Init.hs view
@@ -0,0 +1,556 @@+{-# 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.8.2/Distribution/Client/Init/Heuristics.hs view
@@ -0,0 +1,187 @@+{-# 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 ]+        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) && entry /= "dist" =+          scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy)+      | otherwise = return []++-- 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.8.2/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-install-0.8.2/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-install-0.8.2/Distribution/Client/Install.hs view
@@ -0,0 +1,786 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Install+-- Copyright   :  (c) David Himmelstrup 2005+-- License     :  BSD-like+--+-- Maintainer  :  lemmih@gmail.com+-- 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 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(..)+         , upgradableDependencies+         , Progress(..), foldProgress, )+import Distribution.Client.Fetch (fetchPackage)+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+         ( ConfigFlags(..), configureCommand, filterConfigureFlags+         , ConfigExFlags(..), InstallFlags(..) )+import Distribution.Client.Config+         ( defaultLogsDir, 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 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 )++data InstallMisc = InstallMisc {+    rootCmd    :: Maybe FilePath,+    libVersion :: Maybe Version+  }++-- |Installs the packages needed to satisfy a list of dependencies.+install, upgrade+  :: Verbosity+  -> PackageDBStack+  -> [Repo]+  -> Compiler+  -> ProgramConfiguration+  -> ConfigFlags+  -> ConfigExFlags+  -> InstallFlags+  -> [UnresolvedDependency]+  -> IO ()+install verbosity packageDB repos comp conf+  configFlags configExFlags installFlags deps =++  installWithPlanner planner+        verbosity packageDB repos comp conf+        configFlags configExFlags installFlags+  where+    planner :: Planner+    planner | null deps = planLocalPackage verbosity+                            comp configFlags configExFlags+            | otherwise = planRepoPackages PreferLatestForSelected+                            comp configFlags configExFlags installFlags deps++upgrade verbosity packageDB repos comp conf+  configFlags configExFlags installFlags deps =++  installWithPlanner planner+        verbosity packageDB repos comp conf+        configFlags configExFlags installFlags+  where+    planner :: Planner+    planner | null deps = planUpgradePackages+                            comp configFlags configExFlags+            | otherwise = planRepoPackages PreferAllLatest+                            comp configFlags configExFlags installFlags deps++type Planner = Maybe (PackageIndex InstalledPackage)+            -> AvailablePackageDb+            -> IO (Progress String String InstallPlan)++-- |Installs the packages generated by a planner.+installWithPlanner ::+           Planner+        -> Verbosity+        -> PackageDBStack+        -> [Repo]+        -> Compiler+        -> ProgramConfiguration+        -> ConfigFlags+        -> ConfigExFlags+        -> InstallFlags+        -> IO ()+installWithPlanner planner verbosity packageDBs repos comp conf+  configFlags configExFlags installFlags = do++  installed <- getInstalledPackages verbosity comp packageDBs conf+  available <- getAvailablePackages verbosity repos++  progress <- planner installed available++  notice verbosity "Resolving dependencies..."+  maybePlan <- foldProgress (\message rest -> info verbosity message >> rest)+                            (return . Left) (return . Right) progress+  case maybePlan of+    Left message -> die message+    Right installPlan -> do+      let nothingToInstall = null (InstallPlan.ready installPlan)+      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++      unless dryRun $ do+        logsDir <- defaultLogsDir+        let platform = InstallPlan.planPlatform installPlan+            compid   = InstallPlan.planCompiler installPlan+        installPlan' <-+          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 logsDir)++        -- build reporting, local and remote+        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+    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 index+                           else Nothing,+      useProgramConfig = conf,+      useDistPref      = fromFlagOrDefault+                           (useDistPref defaultSetupScriptOptions)+                           (configDistPref configFlags),+      useLoggingHandle = Nothing,+      useWorkingDir    = Nothing+    }+    reportingLevel = fromFlag (installBuildReports installFlags)+    useLogFile :: FilePath -> Maybe (PackageIdentifier -> FilePath)+    useLogFile logsDir = 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)+    dryRun       = fromFlag (installDryRun installFlags)+    miscOptions  = InstallMisc {+      rootCmd    = if fromFlag (configUserInstall configFlags)+                     then Nothing      -- ignore --root-cmd if --user.+                     else flagToMaybe (installRootCmd installFlags),+      libVersion = flagToMaybe (configCabalVersion configExFlags)+    }++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+  case installed of+    Nothing    -> return () -- warning ?+    Just index -> Haddock.regenerateHaddockIndex verbosity index 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)+++-- | 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) `fmap` installed+      localPkg = AvailablePackage {+        packageInfoId                = packageId pkg,+        Available.packageDescription = pkg,+        packageSource                = LocalUnpackedPackage+      }+      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+                 -> ConfigFlags -> ConfigExFlags -> InstallFlags+                 -> [UnresolvedDependency] -> Planner+planRepoPackages defaultPref comp configFlags configExFlags installFlags+  deps installed (AvailablePackageDb available availablePrefs) = do++  deps' <- IndexUtils.disambiguateDependencies available deps+  let installed'+        | fromFlag (installReinstall installFlags)+                    = fmap (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 ]++planUpgradePackages :: Compiler -> ConfigFlags -> ConfigExFlags -> Planner+planUpgradePackages _comp _configFlags _configExFlags (Just installed)+  (AvailablePackageDb available _availablePrefs) = die $+       "the 'upgrade' command (when used without any package arguments) has "+    ++ "been disabled in this release. It has been disabled because it has "+    ++ "frequently led people to accidentally break their set of installed "+    ++ "packages. It will be re-enabled when it is safer to use.\n"+    ++ "Below is the list of packages that it would have tried to upgrade. You "+    ++ "can use the 'install' command to install the ones you want. Note that "+    ++ "it is generally not recommended to upgrade core packages.\n"+    ++ unlines [ display pkgid | Dependency pkgid _ <- deps ]++--TODO: improve upgrade so we can re-enable it+--  return $+--  resolveDependenciesWithProgress buildPlatform (compilerId comp)+--    (Just installed) available preferences constraints targets+  where+    deps        = upgradableDependencies installed available+--    preferences = mergePackagePrefs PreferAllLatest availablePrefs configExFlags+--    constraints = [ PackageVersionConstraint name ver+--                  | Dependency name ver <- deps ]+--               ++ [ PackageVersionConstraint name ver+--                  | Dependency name ver <- configConstraints configFlags ]+--    targets     = [ name | Dependency name _ <- deps ]++planUpgradePackages comp _ _ _ _ =+  die $ display (compilerId comp)+     ++ " does not track installed packages so cabal cannot figure out what"+     ++ " packages need to be upgraded."++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 ]++printDryRun :: Verbosity -> Maybe (PackageIndex InstalledPackage)+            -> InstallPlan -> IO ()+printDryRun verbosity minstalled 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 minstalled of+        Nothing        -> ""+        Just installed ->+          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++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++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 installPkg =+  installPkg Nothing++installAvailablePackage verbosity pkgid (RepoTarballPackage repo) installPkg =+  onFailure DownloadFailed $ do+    pkgPath <- fetchPackage verbosity repo pkgid+    onFailure UnpackFailed $ do+      tmp <- getTemporaryDirectory+      withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath -> do+        info verbosity $ "Extracting " ++ pkgPath+                      ++ " to " ++ tmpDirPath ++ "..."+        let relUnpackedPath = display pkgid+            absUnpackedPath = tmpDirPath </> relUnpackedPath+            descFilePath = absUnpackedPath+                       </> display (packageName pkgid) <.> "cabal"+        extractTarGzFile tmpDirPath relUnpackedPath pkgPath+        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++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.8.2/Distribution/Client/InstallPlan.hs view
@@ -0,0 +1,495 @@+-----------------------------------------------------------------------------+-- |+-- 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.8.2/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+         ( 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.8.2/Distribution/Client/List.hs view
@@ -0,0 +1,368 @@+-----------------------------------------------------------------------------+-- |+-- 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+    Just 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+  Just 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.8.2/Distribution/Client/PackageIndex.hs view
@@ -0,0 +1,479 @@+-----------------------------------------------------------------------------+-- |+-- 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.8.2/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-install-0.8.2/Distribution/Client/Setup.hs view
@@ -0,0 +1,876 @@+-----------------------------------------------------------------------------+-- |+-- 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+    , 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 )+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]+  }++defaultGlobalFlags :: GlobalFlags+defaultGlobalFlags  = GlobalFlags {+    globalVersion        = Flag False,+    globalNumericVersion = Flag False,+    globalConfigFile     = mempty,+    globalRemoteRepos    = [],+    globalCacheDir       = mempty,+    globalLocalRepos     = 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)+      ]+  }++instance Monoid GlobalFlags where+  mempty = GlobalFlags {+    globalVersion        = mempty,+    globalNumericVersion = mempty,+    globalConfigFile     = mempty,+    globalRemoteRepos    = mempty,+    globalCacheDir       = mempty,+    globalLocalRepos     = mempty+  }+  mappend a b = GlobalFlags {+    globalVersion        = combine globalVersion,+    globalNumericVersion = combine globalNumericVersion,+    globalConfigFile     = combine globalConfigFile,+    globalRemoteRepos    = combine globalRemoteRepos,+    globalCacheDir       = combine globalCacheDir,+    globalLocalRepos     = combine globalLocalRepos+  }+    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++-- ------------------------------------------------------------+-- * Other commands+-- ------------------------------------------------------------++fetchCommand :: CommandUI (Flag Verbosity)+fetchCommand = CommandUI {+    commandName         = "fetch",+    commandSynopsis     = "Downloads packages for later installation.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "fetch",+    commandDefaultFlags = toFlag normal,+    commandOptions      = \_ -> [optionVerbosity id const]+  }++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     = "Upgrades installed packages to the latest available version",+    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,+    installOnly         :: Flag Bool,+    installRootCmd      :: Flag String,+    installSummaryFile  :: [PathTemplate],+    installLogFile      :: Flag PathTemplate,+    installBuildReports :: Flag ReportLevel,+    installSymlinkBinDir:: Flag FilePath+  }++defaultInstallFlags :: InstallFlags+defaultInstallFlags = InstallFlags {+    installDocumentation= Flag False,+    installHaddockIndex = Flag docIndexFile,+    installDryRun       = Flag False,+    installReinstall    = Flag False,+    installOnly         = Flag False,+    installRootCmd      = mempty,+    installSummaryFile  = mempty,+    installLogFile      = mempty,+    installBuildReports = Flag NoReports,+    installSymlinkBinDir= mempty+  }+  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 [] ["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))++      ] ++ 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,+    installOnly         = mempty,+    installRootCmd      = mempty,+    installSummaryFile  = mempty,+    installLogFile      = mempty,+    installBuildReports = mempty,+    installSymlinkBinDir= mempty+  }+  mappend a b = InstallFlags {+    installDocumentation= combine installDocumentation,+    installHaddockIndex = combine installHaddockIndex,+    installDryRun       = combine installDryRun,+    installReinstall    = combine installReinstall,+    installOnly         = combine installOnly,+    installRootCmd      = combine installRootCmd,+    installSummaryFile  = combine installSummaryFile,+    installLogFile      = combine installLogFile,+    installBuildReports = combine installBuildReports,+    installSymlinkBinDir= combine installSymlinkBinDir+  }+    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.8.2/Distribution/Client/SetupWrapper.hs view
@@ -0,0 +1,321 @@+-----------------------------------------------------------------------------+-- |+-- 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+         , withinRange )+import Distribution.Package+         ( PackageIdentifier(..), PackageName(..), Package(..), packageName+         , packageVersion, Dependency(..) )+import Distribution.PackageDescription+         ( GenericPackageDescription(packageDescription)+         , PackageDescription(..), 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.Monoid       ( Monoid(mempty) )+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)+                                          (descCabalVersion 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    -> fromMaybe mempty+             `fmap` 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.8.2/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-install-0.8.2/Distribution/Client/Tar.hs view
@@ -0,0 +1,870 @@+{-# 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 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 =+  unpack dir . checkTarbomb expected . read . GZip.decompress =<< 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.8.2/Distribution/Client/Types.hs view
@@ -0,0 +1,148 @@+-----------------------------------------------------------------------------+-- |+-- 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 )+import Distribution.Client.PackageIndex+         ( PackageIndex )+import Distribution.Version+         ( VersionRange )++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 =++    -- | The unpacked package in the current dir+    LocalUnpackedPackage++    -- | 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:+--  * generalise local package to any local unpacked package, not just in the+--      current dir, ie add a FilePath param+--  * 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)++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.8.2/Distribution/Client/Unpack.hs view
@@ -0,0 +1,116 @@+-----------------------------------------------------------------------------+-- |+-- 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, packageId, Dependency(..) )+import Distribution.Client.PackageIndex as PackageIndex (lookupDependency)+import Distribution.Simple.Setup(fromFlag, fromFlagOrDefault)+import Distribution.Simple.Utils+         ( notice, die )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text(display)+import Distribution.Version+         ( anyVersion, intersectVersionRanges )++import Distribution.Client.Setup(UnpackFlags(unpackVerbosity,+                                             unpackDestDir))+import Distribution.Client.Types(UnresolvedDependency(..),+                                 Repo, AvailablePackageSource(..),+                                 AvailablePackage(AvailablePackage),+                                 AvailablePackageDb(AvailablePackageDb))+import Distribution.Client.Fetch(fetchPackage)+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)+import Distribution.Client.IndexUtils as IndexUtils+    (getAvailablePackages, disambiguateDependencies)++import System.Directory+         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )+import Control.Monad+         ( unless, when )+import Data.Ord (comparing)+import Data.List(maximumBy)+import System.FilePath+         ( (</>), addTrailingPathSeparator )+import qualified Data.Map as Map++unpack :: UnpackFlags -> [Repo] -> [Dependency] -> IO ()+unpack flags repos deps +    | null deps = notice verbosity+                  "No packages requested. Nothing to do."+    | otherwise = do+  db@(AvailablePackageDb available _)+            <- getAvailablePackages verbosity repos+  deps' <- fmap (map dependency) +           . IndexUtils.disambiguateDependencies available +           . map toUnresolved $ deps++  let pkgs = resolvePackages db deps'++  unless (null prefix) $+         createDirectoryIfMissing True prefix++  flip mapM_ pkgs $ \pkg ->+      case pkg of++        Left (Dependency name ver) -> +            die $ "There is no available version of " ++ display name +                  ++ " that satisfies " ++ display ver++        Right (AvailablePackage pkgid _ (RepoTarballPackage repo)) -> do+            pkgPath <- fetchPackage verbosity repo pkgid+            unpackPackage verbosity prefix pkgid pkgPath++        Right (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+                   -> [Dependency]+                   -> [Either Dependency AvailablePackage]+resolvePackages (AvailablePackageDb available prefs) deps =+    map (\d -> best d (candidates d)) deps+    where+      candidates dep@(Dependency name ver) =+          let [x,y] = map (PackageIndex.lookupDependency available)+                      [ Dependency name+                        (maybe anyVersion id (Map.lookup name prefs)+                         `intersectVersionRanges` ver)+                      , dep ]+          in if null x then y else x+      best d [] = Left d+      best _ xs = Right $ maximumBy (comparing packageId) xs+
+ cabal-install-0.8.2/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(..), 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 qualified Codec.Compression.GZip as GZip (decompress)+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+                                              . GZip.decompress+                                            =<< 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.8.2/Distribution/Client/Upload.hs view
@@ -0,0 +1,177 @@+-- 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.8.2/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-install-0.8.2/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-install-0.8.2/Distribution/Compat/Exception.hs view
@@ -0,0 +1,56 @@+{-# 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.8.2/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-install-0.8.2/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,8,2], versionTags = []}
+ cabal-install-0.8.2/cabal-install.cabal view
@@ -0,0 +1,122 @@+Name:               cabal-install+Version:            0.8.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@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>+                    2008-2009 Duncan Coutts <duncan@haskell.org>+Category:           Distribution+Build-type:         Simple+Extra-Source-Files: README bash-completion/cabal bootstrap.sh+Cabal-Version:      >= 1.6+Tested-With:        GHC==6.6.1, GHC==6.8.2, GHC==6.10.4, GHC==6.12.1++source-repository head+  type:     darcs+  location: http://darcs.haskell.org/cabal-install/++source-repository this+  type:     darcs+  location: http://darcs.haskell.org/cabal-branches/cabal-install-0.8/+  tag: 0.8.2++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.Bogus+        Distribution.Client.Dependency.TopDown+        Distribution.Client.Dependency.TopDown.Constraints+        Distribution.Client.Dependency.TopDown.Types+        Distribution.Client.Dependency.Types+        Distribution.Client.Fetch+        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.Win32SelfUpgrade+        Distribution.Compat.Exception+        Paths_cabal_install++    build-depends: base     >= 2        && < 5,+                   Cabal    >= 1.8      && < 1.9,+                   filepath >= 1.0,+                   network  >= 1        && < 3,+                   HTTP     >= 4000.0.2 && < 4001,+                   zlib     >= 0.4      && < 0.6,+                   time     >= 1.1      && < 1.2++    if flag(old-base)+      build-depends: base < 3+    else+      build-depends: base       >= 3,+                     process    >= 1   && < 1.1,+                     directory  >= 1   && < 1.1,+                     pretty     >= 1   && < 1.1,+                     random     >= 1   && < 1.1,+                     containers >= 0.1 && < 0.4,+                     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
+ cabal2ebuild.hs view
@@ -0,0 +1,17 @@+module Main where++import System.Environment+import qualified Distribution.PackageDescription as Cabal+import Distribution.Verbosity (normal)+import Cabal2Ebuild++main :: IO ()+main = do+  args <- getArgs+  case args of+    [cabalFileName] -> do+      pkg <- Cabal.readPackageDescription normal cabalFileName+      let ebuild = cabal2ebuild (Cabal.flattenPackageDescription pkg)+      let ebuildFileName = name ebuild ++ "-" ++ version ebuild ++ ".ebuild"+      writeFile ebuildFileName (showEBuild ebuild)+    _ -> putStrLn "usage: cabal2ebuild package.cabal"
hackport.cabal view
@@ -1,6 +1,7 @@ Name:           hackport-Version:	0.2.1+Version:	0.2.6 License:	GPL+License-file:   LICENSE Author:		Henning Günther, Duncan Coutts, Lennart Kolmodin Maintainer:     Gentoo Haskell team <haskell@gentoo.org> Category:       Distribution@@ -8,57 +9,65 @@ Description:    A command line tool to manage an overlay of Gentoo ebuilds                 that are generated from a hackage repo of Cabal packages. Build-Type:     Simple-Cabal-Version:  >=1.2+Cabal-Version:  >=1.8 +source-repository head+  type: darcs+  location: http://code.haskell.org/gentoo/hackport/+ Flag split-base  Executable	hackport   Main-Is:	Main.hs+  Hs-Source-Dirs: ., cabal-install-0.8.2   Build-Depends:-    base >= 2.0,+    base >= 2.0 && < 5,     filepath,     parsec,     mtl,     network,+    pretty,     regex-compat,-    Cabal >= 1.4 && < 1.5,-    HTTP >= 3000 && < 3002,+    Cabal == 1.8.*,+    HTTP >= 4000.0.3,     zlib,-    tar+    tar,+    array,+  -- array is inherited from cabal-install +  -- tar >= 0.3.0.0 && < 0.4+    extensible-exceptions    if flag(split-base)     Build-Depends:-      base >= 3,+      base >= 3 && < 5,       directory,       containers,       process,       old-time,       bytestring   else-    Build-Depends:  base <  3+     Build-Depends: base < 3    ghc-options: -Wall   other-modules:-    Action     AnsiColor-    Bash     BlingBling     Cabal2Ebuild-    Cache     CacheFile-    Config     Diff     Error-    Fetch-    GenerateEbuild-    Index     Main     MaybeRead     Overlays     P2-    Package     Portage+    Portage.Version+    Portage.Dependency+    Portage.PackageId+    Portage.Overlay+    Portage.Resolve+    Portage.Host     Setup     Status-    Utils-    Version+    Merge+    Util
+ tests/resolveCat.hs view
@@ -0,0 +1,21 @@+import Test.HUnit++import qualified Portage.Overlay as Portage+import qualified Portage.Resolve as Portage+import qualified Portage.PackageId as Portage++import qualified Distribution.Package as Cabal++tests = TestList [ TestLabel "resolve cabal" (test_resolveCategory "dev-haskell" "cabal")+                 , TestLabel "resolve ghc" (test_resolveCategory "dev-lang" "ghc")+                 ]++test_resolveCategory :: String -> String -> Test+test_resolveCategory cat pkg = TestCase $ do+  portage <- Portage.loadLazy "/usr/portage"+  let cabal = Cabal.PackageName pkg+      hits = Portage.resolveFullPortageName portage cabal+      expected = Just (Portage.PackageName (Portage.Category cat) cabal)+  assertEqual ("expecting to find package " ++ pkg) hits expected ++main = runTestTT tests
+ unused/Fetch.hs view
@@ -0,0 +1,78 @@+-- module unused+module Fetch(downloadTarball,downloadFileVerify) where++import Prelude hiding (catch)++import Network.HTTP (ConnError(..),Request(..),simpleHTTP+                    ,Response(..),RequestMethod(..))+import Network.URI (URI,uriPath,parseURI)+import Text.Regex (Regex,mkRegex,matchRegex)+import System.GPG+import Control.Monad.Error+import System.Directory+import System.FilePath+import Data.Typeable++import Error+import Action++filenameRegex :: Regex+filenameRegex = mkRegex "^.*?/([^/]*?)"++uriToFileName :: URI -> Maybe FilePath+uriToFileName uri = maybe Nothing (\x->Just (head x)) (matchRegex filenameRegex (uriPath uri))++downloadURI :: FilePath		-- ^ a directory to store the file+            -> URI 		-- ^ the url+            -> IO FilePath	-- ^ the path of the downloaded file+downloadURI path uri = do+	fileName <- maybe (throwEx $ InvalidTarballURL (show uri) "URL doesn't contain a filename") return (uriToFileName uri)+	httpResult <- simpleHTTP request+	Response {rspCode=code,rspBody=body,rspReason=reason} <- either (\x->throwError $ DownloadFailed (show uri) "Connection failed") return httpResult+	if code==(2,0,0) then (do+		let writePath=path </> fileName+		writeFile writePath body+		return writePath) else throwEx $ DownloadFailed (show uri) ("Code "++show code++":"++reason)+	where+	request = Request+		{rqURI=uri+		,rqMethod=GET+		,rqHeaders=[]+		,rqBody=""}+++downloadFileVerify ::+	FilePath ->		-- ^ the directory to store the files+	String ->		-- ^ the url of the tarball+	String ->		-- ^ the url of the signature+	IO (FilePath,FilePath)	-- ^ the tarballs and signatures path+downloadFileVerify path url sigurl = do+	tarballPath <- downloadTarball path url+	sigPath <- downloadSig path sigurl `catchEx` \e-> do+                      removeFile tarballPath+                      throwEx x+	verified <- verifyFile stdOptions tarballPath sigPath+	if verified then return (tarballPath,sigPath) else (do+		removeFile tarballPath+		removeFile sigPath+		throwEx $ VerificationFailed url sigurl)++downloadTarball ::+	FilePath ->+	String ->+	IO FilePath+downloadTarball dir url = download dir url InvalidTarballURL++downloadSig ::+	FilePath ->+	String ->+	IO FilePath+downloadSig dir url = download dir url InvalidSignatureURL++download :: FilePath				-- ^ the folder to store the file in+	 -> String				-- ^ the url+	 -> (String -> String -> HackPortError)	-- ^ a function to construct an error+	 -> IO FilePath			-- ^ the resulting file's path+download dir url errFunc = do+	parsedURL <- maybe (throwEx $ errFunc url "Parsing failed") return (parseURI url)+	downloadURI dir parsedURL