packages feed

hackport 0.3.5 → 0.3.6

raw patch · 177 files changed

+14967/−5624 lines, 177 filesdep +old-locale

Dependencies added: old-locale

Files

Cabal2Ebuild.hs view
@@ -34,7 +34,7 @@ import qualified Distribution.Version as Cabal  (VersionRange, foldVersionRange') import Distribution.Text (display) -import Data.Char          (toLower,isUpper)+import Data.Char          (isUpper)  import Portage.Dependency import qualified Portage.Cabal as Portage@@ -48,7 +48,7 @@  cabal2ebuild :: Cabal.PackageDescription -> Portage.EBuild cabal2ebuild pkg = Portage.ebuildTemplate {-    E.name        = map toLower cabalPkgName,+    E.name        = Portage.cabal_pn_to_PN cabal_pn,     E.hackage_name= cabalPkgName,     E.version     = display (Cabal.pkgVersion (Cabal.package pkg)),     E.description = if null (Cabal.synopsis pkg) then Cabal.description pkg@@ -66,7 +66,8 @@                         ) (Cabal.library pkg) -- hscolour can't colour its own sources                    ++ (if hasTests then ["test-suite"] else [])   } where-        cabalPkgName = display $ Cabal.pkgName (Cabal.package pkg)+        cabal_pn = Cabal.pkgName $ Cabal.package pkg+        cabalPkgName = display cabal_pn         hasExe = (not . null) (Cabal.executables pkg)         hasTests = (not . null) (Cabal.testSuites pkg)         thisHomepage = if (null $ Cabal.homepage pkg)
Main.hs view
@@ -125,20 +125,24 @@  data MakeEbuildFlags = MakeEbuildFlags {     makeEbuildVerbosity :: Flag Verbosity+  , makeEbuildCabalFlags :: Flag (Maybe String)   }  instance Monoid MakeEbuildFlags where   mempty = MakeEbuildFlags {     makeEbuildVerbosity = mempty+  , makeEbuildCabalFlags = mempty   }   mappend a b = MakeEbuildFlags {     makeEbuildVerbosity = combine makeEbuildVerbosity+  , makeEbuildCabalFlags = makeEbuildCabalFlags b   }     where combine field = field a `mappend` field b  defaultMakeEbuildFlags :: MakeEbuildFlags defaultMakeEbuildFlags = MakeEbuildFlags {     makeEbuildVerbosity = Flag normal+  , makeEbuildCabalFlags = Flag Nothing   }  makeEbuildAction :: MakeEbuildFlags -> [String] -> GlobalFlags -> IO ()@@ -153,7 +157,7 @@   overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)   forM_ cabals $ \cabalFileName -> do     pkg <- Cabal.readPackageDescription normal cabalFileName-    mergeGenericPackageDescription verbosity overlayPath cat pkg False+    mergeGenericPackageDescription verbosity overlayPath cat pkg False (fromFlag $ makeEbuildCabalFlags flags)  makeEbuildCommand :: CommandUI MakeEbuildFlags makeEbuildCommand = CommandUI {@@ -165,6 +169,14 @@     commandDefaultFlags = defaultMakeEbuildFlags,     commandOptions = \_showOrParseArgs ->       [ optionVerbosity makeEbuildVerbosity (\v flags -> flags { makeEbuildVerbosity = v })++      , option "f" ["flags"]+        (unlines [ "Set cabal flags to certain state."+                 , "Example: --flags=-all_extensions"+                 ])+        makeEbuildCabalFlags+        (\cabal_flags v -> v{ makeEbuildCabalFlags = cabal_flags })+        (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))       ]   } @@ -341,24 +353,24 @@  data MergeFlags = MergeFlags {     mergeVerbosity :: Flag Verbosity-    -- , mergeServerURI :: Flag String+  , mergeCabalFlags :: Flag (Maybe String)   }  instance Monoid MergeFlags where   mempty = MergeFlags {     mergeVerbosity = mempty-    -- , mergeServerURI = mempty+  , mergeCabalFlags = mempty   }   mappend a b = MergeFlags {     mergeVerbosity = combine mergeVerbosity-    -- , mergeServerURI = combine mergeServerURI+  , mergeCabalFlags = mergeCabalFlags b   }     where combine field = field a `mappend` field b  defaultMergeFlags :: MergeFlags defaultMergeFlags = MergeFlags {     mergeVerbosity = Flag normal-    -- , mergeServerURI = Flag defaultHackageServerURI+  , mergeCabalFlags = Flag Nothing   }  mergeCommand :: CommandUI MergeFlags@@ -372,12 +384,13 @@     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")-      -}+      , option "f" ["flags"]+        (unlines [ "Set cabal flags to certain state."+                 , "Example: --flags=-all_extensions"+                 ])+        mergeCabalFlags+        (\cabal_flags v -> v{ mergeCabalFlags = cabal_flags})+        (reqArg' "cabal_flags" (Flag . Just) (\(Flag ms) -> catMaybes [ms]))       ]   } @@ -386,7 +399,7 @@   let verbosity = fromFlag (mergeVerbosity flags)   overlayPath <- getOverlayPath verbosity (fromFlag $ globalPathToOverlay globalFlags)   let repo = defaultRepo overlayPath-  merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath+  merge verbosity repo (defaultRepoURI overlayPath) extraArgs overlayPath (fromFlag $ mergeCabalFlags flags)  ----------------------------------------------------------------------- -- DistroMap
Merge.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE PatternGuards, BangPatterns #-} module Merge   ( merge   , mergeGenericPackageDescription@@ -8,11 +7,12 @@ import Control.Monad.Error import Control.Exception import qualified Data.ByteString.Lazy.Char8 as BL-import Data.Char (isSpace)+import qualified Data.Map.Strict as M import Data.Function (on) import Data.Maybe import Data.Monoid-import Data.List as L+import qualified Data.List as L+import qualified Data.Time.Clock as TC import Data.Version  -- cabal@@ -37,7 +37,6 @@  -- others import System.Directory ( getCurrentDirectory-                        , getDirectoryContents                         , setCurrentDirectory                         , createDirectoryIfMissing                         , doesFileExist@@ -45,15 +44,14 @@ import System.Cmd (system) import System.FilePath ((</>)) import System.Exit-import Text.Printf  import qualified Cabal2Ebuild as C2E import qualified Portage.EBuild as E+import qualified Portage.EMeta as EM import Error as E  import Network.URI - import qualified Portage.PackageId as Portage import qualified Portage.Version as Portage import qualified Portage.Metadata as Portage@@ -65,6 +63,8 @@  import qualified Merge.Dependencies as Merge +import qualified Util as U+ (<.>) :: String -> String -> String a <.> b = a ++ '.':b @@ -97,13 +97,13 @@ -- return the available package with that version. Latest version is chosen -- if no preference. resolveVersion :: [SourcePackage] -> Maybe Cabal.Version -> Maybe SourcePackage-resolveVersion avails Nothing = Just $ maximumBy (comparing packageInfoId) avails+resolveVersion avails Nothing = Just $ L.maximumBy (comparing packageInfoId) avails resolveVersion avails (Just ver) = listToMaybe (filter match avails)   where     match avail = ver == Cabal.pkgVersion (packageInfoId avail) -merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> IO ()-merge verbosity repo _serverURI args overlayPath = do+merge :: Verbosity -> Repo -> URI -> [String] -> FilePath -> Maybe String -> IO ()+merge verbosity repo _serverURI args overlayPath users_cabal_flags = do   (m_category, user_pName, m_version) <-     case readPackageString args of       Left err -> throwEx err@@ -160,92 +160,163 @@   let cabal_pkgId = packageInfoId selectedPkg       norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)   cat <- maybe (Portage.resolveCategory verbosity overlay norm_pkgName) return m_category-  mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True+  mergeGenericPackageDescription verbosity overlayPath cat (packageDescription selectedPkg) True users_cabal_flags -mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> IO ()-mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch = do+first_just_of :: [Maybe a] -> Maybe a+first_just_of [] = Nothing+first_just_of (m:ms) =+    case m of+        Nothing -> first_just_of ms+        Just _  -> m++mergeGenericPackageDescription :: Verbosity -> FilePath -> Portage.Category -> Cabal.GenericPackageDescription -> Bool -> Maybe String -> IO ()+mergeGenericPackageDescription verbosity overlayPath cat pkgGenericDesc fetch users_cabal_flags = do   overlay <- Overlay.loadLazy overlayPath   let merged_cabal_pkg_name = Cabal.pkgName (Cabal.package (Cabal.packageDescription pkgGenericDesc))+      merged_PN = Portage.cabal_pn_to_PN merged_cabal_pkg_name+      pkgdir    = overlayPath </> Portage.unCategory cat </> merged_PN+  existing_meta <- EM.findExistingMeta pkgdir+  let requested_cabal_flags = first_just_of [users_cabal_flags, EM.cabal_flags existing_meta] +  debug verbosity "searching for minimal suitable ghc version"   (compilerId, ghc_packages, pkgDesc0, _flags, pix) <- case GHCCore.minimumGHCVersionToBuildPackage pkgGenericDesc of               Just v  -> return v-              Nothing -> let cpn = display merged_cabal_pkg_name-                         in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ cpn+              Nothing -> let pn = display merged_cabal_pkg_name+                             cn = display cat+                         in error $ unlines [ "mergeGenericPackageDescription: failed to find suitable GHC for " ++ pn                                             , "  You can try to merge the package manually:"-                                            , "  $ cabal unpack " ++ cpn-                                            , "  $ cd " ++ cpn ++ "*/"-                                            , "  # fix " ++ cpn ++ ".cabal"-                                            , "  $ hackport make-ebuild dev-haskell " ++ cpn ++ ".cabal"+                                            , "  $ cabal unpack " ++ pn+                                            , "  $ cd " ++ pn ++ "*/"+                                            , "  # fix " ++ pn ++ ".cabal"+                                            , "  $ hackport make-ebuild " ++ cn ++ " " ++ pn ++ ".cabal"                                             ]        -- , Right (pkg_desc, picked_flags) <- return (packageBuildableWithGHCVersion gpd g)]-  let (accepted_deps, skipped_deps, dropped_deps) = genSimple (Cabal.buildDepends pkgDesc0)+  let (accepted_deps, skipped_deps, dropped_deps) = partition_depends (Cabal.buildDepends pkgDesc0)       pkgDesc = pkgDesc0 { Cabal.buildDepends = accepted_deps }-      aflags = map Cabal.flagName (Cabal.genPackageFlags pkgGenericDesc)-      lflags  :: [Cabal.Flag] -> [Cabal.FlagAssignment]-      lflags  [] = [[]]-      lflags  (x:xs) = let tp = lflags xs-                       in (map ((Cabal.flagName x,False) :) tp)-                          ++ (map ((Cabal.flagName x,True):) tp)+      cabal_flag_descs = Cabal.genPackageFlags pkgGenericDesc+      all_flags = map Cabal.flagName cabal_flag_descs+      (user_specified_fas, cf_to_iuse_rename) = read_fas requested_cabal_flags+      make_fas  :: [Cabal.Flag] -> [Cabal.FlagAssignment]+      make_fas  [] = [[]]+      make_fas  (f:rest) = [ (fn, is_enabled) : fas+                           | fas <- make_fas rest+                           , let fn = Cabal.flagName f+                                 users_choice = lookup fn user_specified_fas+                           , is_enabled <- maybe [False, True]+                                                 (\b -> [b])+                                                 users_choice+                           ]+      all_possible_flag_assignments :: [Cabal.FlagAssignment]+      all_possible_flag_assignments = make_fas cabal_flag_descs++      pp_fa :: Cabal.FlagAssignment -> String+      pp_fa fa = L.intercalate ", " [ (if b then '+' else '-') : f+                                    | (Cabal.FlagName f, b) <- fa+                                    ]++      -- accepts things, like: "cabal_flag:iuse_name", "+cabal_flag", "-cabal_flag"+      read_fas :: Maybe String -> (Cabal.FlagAssignment, [(String, String)])+      read_fas Nothing = ([], [])+      read_fas (Just user_fas_s) = (user_fas, user_renames)+          where user_fas = [ (cf, b)+                           | ((cf, _), Just b) <- cn_in_mb+                           ]+                user_renames = [ (cfn, ein)+                               | ((Cabal.FlagName cfn, ein), Nothing) <- cn_in_mb+                               ]+                cn_in_mb = map read_fa $ U.split (== ',') user_fas_s+                read_fa :: String -> ((Cabal.FlagName, String), Maybe Bool)+                read_fa [] = error $ "read_fas: empty flag?"+                read_fa (op:flag) =+                    case op of+                        '+'   -> (get_rename flag, Just True)+                        '-'   -> (get_rename flag, Just False)+                        _     -> (get_rename (op:flag), Nothing)+                  where get_rename :: String -> (Cabal.FlagName, String)+                        get_rename s =+                            case U.split (== ':') s of+                                [cabal_flag_name] -> (Cabal.FlagName cabal_flag_name, cabal_flag_name)+                                [cabal_flag_name, iuse_name] -> (Cabal.FlagName cabal_flag_name, iuse_name)+                                _                 -> error $ "get_rename: too many components" ++ show (s)++      cfn_to_iuse :: String -> String+      cfn_to_iuse cfn =+          case lookup cfn cf_to_iuse_rename of+              Nothing  -> cfn+              Just ein -> ein+       -- key idea is to generate all possible list of flags       deps1 :: [(Cabal.FlagAssignment, Merge.EDep)]-      deps1  = [ (f `updateFa` fr, genDeps pkgDesc_filtered_bdeps)-               | f <- lflags (Cabal.genPackageFlags pkgGenericDesc)+      deps1  = [ (f `updateFa` fr, cabal_to_emerge_dep pkgDesc_filtered_bdeps)+               | f <- all_possible_flag_assignments                , Right (pkgDesc1,fr) <- [GHCCore.finalizePackageDescription f                                                                   (GHCCore.dependencySatisfiable pix)-                                                                  (GHCCore.platform)+                                                                  GHCCore.platform                                                                   compilerId                                                                   []                                                                   pkgGenericDesc]                -- drop circular deps and shipped deps-               , let (ad, _sd, _rd) = genSimple (Cabal.buildDepends pkgDesc1)+               , let (ad, _sd, _rd) = partition_depends (Cabal.buildDepends pkgDesc1)+               -- TODO: drop ghc libraries from tests depends as well+               -- (see deepseq in hackport-0.3.5 as an example)                , let pkgDesc_filtered_bdeps = pkgDesc1 { Cabal.buildDepends = ad }                ]-          where +          where             updateFa :: Cabal.FlagAssignment -> Cabal.FlagAssignment -> Cabal.FlagAssignment             updateFa [] _ = []             updateFa (x:xs) y = case lookup (fst x) y of-                                  Nothing -> x:(updateFa xs y)-                                  Just y' -> (fst x,y'):(updateFa xs y)+                                  -- TODO: when does this code get triggered?+                                  Nothing ->          x : updateFa xs y+                                  Just y' -> (fst x,y') : updateFa xs y       -- then remove all flags that can't be changed-      commonFlags = foldl1 intersect $ map fst deps1-      aflags' | null commonFlags  = aflags-              | otherwise         = filter (\a -> all (a/=) $ map fst commonFlags) aflags-      aflags'' = filter (\x -> Cabal.flagName x `elem` aflags') $ Cabal.genPackageFlags pkgGenericDesc-      -- flags that are faild to build-      deadFlags = filter (\x -> all (x/=) $ map fst deps1) (lflags (Cabal.genPackageFlags pkgGenericDesc))-      -- and finaly prettify all deps:-      tdeps = (foldl (\x y -> x `mappend` (snd y)) mempty deps1){-            Merge.dep  = Portage.sortDeps . simplify $ map (\x -> (x,[])) $ map (first (filter (\x -> all (x/=) commonFlags))) $ map (second Merge.dep) deps1-          , Merge.rdep = Portage.sortDeps . simplify $ map (\x -> (x,[])) $ map (first (filter (\x -> all (x/=) commonFlags))) $ map (second Merge.rdep) deps1+      successfully_resolved_flag_assignments = map fst deps1+      common_fa = L.foldl1' L.intersect successfully_resolved_flag_assignments+      common_flags = map fst common_fa+      active_flags = all_flags L.\\ common_flags+      active_flag_descs = filter (\x -> Cabal.flagName x `elem` active_flags) cabal_flag_descs+      irresolvable_flag_assignments = all_possible_flag_assignments L.\\ successfully_resolved_flag_assignments+      -- and finally prettify all deps:+      leave_only_dynamic_fa :: Cabal.FlagAssignment -> Cabal.FlagAssignment+      leave_only_dynamic_fa fa = fa L.\\ common_fa++      optimize_fa_depends :: [([(Cabal.FlagName, Bool)], [Portage.Dependency])] -> [Portage.Dependency]+      optimize_fa_depends deps = Portage.sortDeps+                               . simplify+                               . map ( (\fdep -> (fdep, []))+                                     . first leave_only_dynamic_fa) $ deps++      tdeps :: Merge.EDep+      tdeps = (L.foldl' (\x y -> x `mappend` snd y) mempty deps1){+            Merge.dep  = optimize_fa_depends $ map (second Merge.dep) deps1+          , Merge.rdep = optimize_fa_depends $ map (second Merge.rdep) deps1           } -      common :: [FlagDepH] -> FlagDepH-      common xs = -              let n = go xs-                  k m = case m of -                         []  -> error "impossible"-                         [x] -> x-                         _   -> k (go m)-              in k n -          where -            go [] = []-            go [y] = [y]-            go (y1:y2:ys) = y1 `merge1` y2 : go ys+      pop_common_deps :: [FlagDepH] -> FlagDepH+      pop_common_deps xs =+           case pop_from_pairs xs of+                 []  -> error "impossible"+                 [x] -> x+                 r   -> pop_common_deps r+          where+            pop_from_pairs :: [FlagDepH] -> [FlagDepH]+            pop_from_pairs [] = []+            pop_from_pairs [y] = [y]+            pop_from_pairs (y1:y2:rest) = y1 `pop_from_pair` y2 : pop_from_pairs rest -            merge1 :: FlagDepH -> FlagDepH -> FlagDepH-            merge1 ((f1, d1),x1) ((f2, d2),x2) = ((f1 `intersect` f2, Portage.simplify_deps $ d1 `intersect` d2)-                                                 , (f1, filter (`notElem` d2) d1)-                                                    : (f2, filter (`notElem` d1) d2)-                                                    : x1-                                                    ++ x2-                                                    )+            pop_from_pair :: FlagDepH -> FlagDepH -> FlagDepH+            pop_from_pair ((lfa, ld), lx) ((rfa, rd), rx) = ((fa, d), x)+                where fa = lfa `L.intersect` rfa+                      d  = Portage.simplify_deps $ ld `L.intersect` rd+                      x  = (lfa, ld L.\\ rd)+                         : (rfa, rd L.\\ ld)+                         : lx ++ rx        simplify :: [FlagDepH] -> [Portage.Dependency]-      simplify xs = +      simplify fdephs =         let -- extract common part of the depends             -- filtering out empty groups-            ((fl,c), zs) = second (filter (not.null.snd)) $ common xs  +            ((common_fas, common_fdeps), all_fdeps) = second (filter (not . null . snd)) $ pop_common_deps fdephs             -- Regroup flags according to packages, i.e.             -- if 2 groups of flagged deps containg same package, then             -- extract common flags, but if common flags will be empty@@ -255,66 +326,68 @@             mergeD :: (Cabal.FlagAssignment, Portage.Dependency)                    -> [(Cabal.FlagAssignment, Portage.Dependency)]                    -> [(Cabal.FlagAssignment, Portage.Dependency)]-            mergeD x [] = [x]-            mergeD x@(f1,d1) (t@(f2,d2):ts) = -              let is = f1 `intersect` f2-              in if d1 == d2-                      then if null is -                                then ts-                                else (is,d1):ts-                      else t:mergeD x ts+            mergeD fdep [] = [fdep]+            mergeD lfdep@(lfa, ld) (rfdep@(rfa, rd):rest) =+                case (ld == rd, lfa `L.intersect` rfa) of+                    (True,  [])   -> rest+                    (True,  c_fa) -> (c_fa, ld):rest+                    (False, _)    -> rfdep:mergeD lfdep rest+             sd :: [(Cabal.FlagAssignment, [Portage.Dependency])]-            sd = foldl (\o (f,d) -> case lookup f o of-                                          Just ds -> (f,d:ds):filter ((f/=).fst) o-                                          Nothing -> (f,[d]):o-                       ) [] $ foldl (\o n -> n `mergeD` o) -                                    [] -                                    (concatMap (\(f,d) -> map ((,) f) d) zs)-            -- filter out splitted packages from common cgroup-            ys = filter (not.null.snd) $ map (second (filter (\d -> all (d/=) -                                                              (concatMap snd sd))-                                                     )) zs-            -- Now we need to find noniteracting use flags if they are then we +            sd = M.toList $!+                 L.foldl' (\fadeps (fa, new_deps) -> let push_front old_val = Just $!+                                                             case old_val of+                                                                 Nothing -> new_deps:[]+                                                                 Just ds -> new_deps:ds+                                                     in M.alter push_front fa fadeps+                       ) M.empty $ L.foldl' (\fadeps fadep -> fadep `mergeD` fadeps)+                                    []+                                    (concatMap (\(fa, deps) -> map (\one_dep -> (fa, one_dep)) deps) all_fdeps)+            -- filter out splitted packages from common group+            ys = filter (not.null.snd) $ map (second (filter (\d -> d `notElem` concatMap snd sd)+                                                     )) all_fdeps+            -- Now we need to find noniteracting use flags if they are then we             -- don't need to simplify them more, and output as-is             simplifyMore :: [(Cabal.FlagAssignment,[Portage.Dependency])] -> [Portage.Dependency]             simplifyMore [] = []-            simplifyMore ws = -                let us = getMultiFlags ws-                    (u,_) = maximumBy (compare `on` snd) $ getMultiFlags ws-                    (xs', ls) = (hasFlag u) `partition` ws-                in if null us -                      then concatMap (\(a, b) -> liftFlags a b) ws-                      else liftFlags [u] (simplify $ map (\x -> (x,[])) $ dropFlag u xs')++simplifyMore ls-        in (liftFlags fl c) ++ simplifyMore (sd ++ ys)+            simplifyMore fdeps =+                let fa_hist = get_fa_hist fdeps+                    (u,_) = L.maximumBy (compare `on` snd) fa_hist+                    (fdeps_u, fdeps_nu) = hasFlag u `L.partition` fdeps+                in if null fa_hist+                      then concatMap (\(a, b) -> liftFlags a b) fdeps+                      else liftFlags [u] (simplify $ map (\x -> (x,[])) $ dropFlag u fdeps_u) ++ simplifyMore fdeps_nu+        in liftFlags common_fas common_fdeps ++ simplifyMore (sd ++ ys) +      get_fa_hist :: [FlagDep] -> [((Cabal.FlagName,Bool),Int)]+      get_fa_hist fdeps = reverse $! L.sortBy (compare `on` snd) $!+                                     M.toList $!+                                     go M.empty (concatMap fst fdeps)+            where go hist [] = hist+                  go hist (fd:fds) = go (M.insertWith (+) fd 1 hist) fds       -- drop selected use flag from a list-      getMultiFlags :: [FlagDep] -> [((Cabal.FlagName,Bool),Int)]-      getMultiFlags ys = go [] (concatMap fst ys)-            where go a [] = a-                  go a (x:xs) = case lookup x a of-                                  Nothing -> go ((x,1):a) xs-                                  Just n  -> go ((x,n+1):filter ((x/=).fst) a) xs        dropFlag :: (Cabal.FlagName,Bool) -> [FlagDep] -> [FlagDep]       dropFlag f = map (first (filter (f /=)))       hasFlag :: (Cabal.FlagName,Bool) -> FlagDep -> Bool-      hasFlag u = any ((u ==)) . fst+      hasFlag u = elem u . fst        liftFlags :: Cabal.FlagAssignment -> [Portage.Dependency] -> [Portage.Dependency]-      liftFlags fs e = let k = foldr (\(y,b) x -> Portage.DependIfUse (Portage.DUse (b, unFlagName y)) . x)-                                      (id::Portage.Dependency->Portage.Dependency) fs+      liftFlags fs e = let k = foldr (\(y,b) x -> Portage.DependIfUse (Portage.DUse (b, cfn_to_iuse $ unFlagName y)) . x)+                                      id fs                        in Portage.simplify_deps [k $! Portage.DependAllOf e] --      genSimple =-          foldl (\(ad, sd, rd) (Cabal.Dependency pn vr) ->-                  let dep = (Cabal.Dependency pn (Cabal.simplifyVersionRange vr))+      partition_depends :: [Cabal.Dependency] -> ([Cabal.Dependency], [Cabal.Dependency], [Cabal.Dependency])+      partition_depends =+          L.foldl' (\(ad, sd, rd) (Cabal.Dependency pn vr) ->+                  let dep = Cabal.Dependency pn (Cabal.simplifyVersionRange vr)                   in case () of                         _ | pn `elem` ghc_packages      -> (    ad, dep:sd,     rd)                         _ | pn == merged_cabal_pkg_name -> (    ad,     sd, dep:rd)                         _                               -> (dep:ad,     sd,     rd)                 )                 ([],[],[])-      genDeps pkg = Merge.resolveDependencies overlay pkg (Just compilerId)+      cabal_to_emerge_dep :: Cabal.PackageDescription -> Merge.EDep+      cabal_to_emerge_dep cabal_pkg = Merge.resolveDependencies overlay cabal_pkg (Just compilerId)    debug verbosity $ "buildDepends pkgDesc0 raw: " ++ Cabal.showPackageDescription pkgDesc0   debug verbosity $ "buildDepends pkgDesc0: " ++ show (map display (Cabal.buildDepends pkgDesc0))@@ -323,16 +396,15 @@   notice verbosity $ "Accepted depends: " ++ show (map display accepted_deps)   notice verbosity $ "Skipped  depends: " ++ show (map display skipped_deps)   notice verbosity $ "Dropped  depends: " ++ show (map display dropped_deps)-  notice verbosity $ "Dead flags: " ++ show deadFlags-  notice verbosity $ "Dropped  flags: " ++ show (map (unFlagName.fst) commonFlags)+  notice verbosity $ "Dead flags: " ++ show (map pp_fa irresolvable_flag_assignments)+  notice verbosity $ "Dropped  flags: " ++ show (map (unFlagName.fst) common_fa)   -- mapM_ print tdeps    forM_ ghc_packages $       \(Cabal.PackageName name) -> info verbosity $ "Excluded packages (comes with ghc): " ++ name -  let -- p_flag (Cabal.FlagName fn, True)  =     fn-      -- p_flag (Cabal.FlagName fn, False) = '-':fn-+  let pp_fn (Cabal.FlagName fn, True)  =     fn+      pp_fn (Cabal.FlagName fn, False) = '-':fn        -- appends 's' to each line except the last one       --  handy to build multiline shell expressions@@ -340,23 +412,29 @@       icalate _s [x]    = [x]       icalate  s (x:xs) = (x ++ s) : icalate s xs -      selected_flags :: [String] -> [String]-      selected_flags [] = []-      selected_flags fs = icalate " \\" $ "haskell-cabal_src_configure"-                                        : map (\p -> "\t$(cabal_flag "++ p ++" "++ p ++")") fs+      selected_flags :: ([Cabal.FlagName], Cabal.FlagAssignment) -> [String]+      selected_flags ([], []) = []+      selected_flags (active_fns, users_fas) = icalate " \\" $ "haskell-cabal_src_configure" : map snd (L.sortBy (compare `on` fst) flag_pairs)+          where flag_pairs :: [(String, String)]+                flag_pairs = active_pairs ++ users_pairs+                active_pairs = map (\fn -> (fn,                    "\t$(cabal_flag " ++ cfn_to_iuse fn ++ " " ++ fn ++ ")")) $ map unFlagName active_fns+                users_pairs  = map (\fa -> ((unFlagName . fst) fa, "\t--flag=" ++ pp_fn fa)) users_fas       to_iuse x = let fn = unFlagName $ Cabal.flagName x                       p  = if Cabal.flagDefault x then "+" else ""-                  in p++fn+                  in p ++ cfn_to_iuse fn        ebuild =   (\e -> e { E.depend        = Merge.dep tdeps} )                . (\e -> e { E.depend_extra  = Merge.dep_e tdeps } )                . (\e -> e { E.rdepend       = Merge.rdep tdeps} )                . (\e -> e { E.rdepend_extra = Merge.rdep_e tdeps } )-               . (\e -> e { E.src_configure = selected_flags $ sort $ map unFlagName aflags' } )-               . (\e -> e { E.iuse = E.iuse e ++ map to_iuse aflags'' })+               . (\e -> e { E.src_configure = selected_flags (active_flags, user_specified_fas) } )+               . (\e -> e { E.iuse = E.iuse e ++ map to_iuse active_flag_descs })+               . ( case requested_cabal_flags of+                       Nothing  -> id+                       Just ucf -> (\e -> e { E.used_options  = E.used_options e ++ [("flags", ucf)] }))                $ C2E.cabal2ebuild pkgDesc -  mergeEbuild verbosity overlayPath (Portage.unCategory cat) ebuild+  mergeEbuild verbosity existing_meta pkgdir ebuild   when fetch $ do     let cabal_pkgId = Cabal.packageId pkgDesc         norm_pkgName = Cabal.packageName (Portage.normalizeCabalPackageId cabal_pkgId)@@ -386,56 +464,6 @@     (\_ -> setCurrentDirectory oldDir)     (\_ -> action) --- tries to extract value of variable in var="val" format--- There should be exactly one variable assignment in ebuild--- It's a bit artificial limitation, but it's common for 'if / else' blocks-extract_quoted_string :: FilePath -> String -> String -> Maybe String-extract_quoted_string ebuild_path s_ebuild var_name =-    case filter (isPrefixOf var_prefix . ltrim) $ lines s_ebuild of-        []        -> Nothing-        [kw_line] -> up_to_quote $ skip_prefix $ ltrim kw_line-        other     -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)--    where ltrim :: String -> String-          ltrim = dropWhile isSpace-          var_prefix = var_name ++ "=\""-          skip_prefix = drop (length var_prefix)-          up_to_quote l = case break (== '"') l of-                              ("", _)  -> Nothing -- empty line-                              (_, "")  -> bail_out $ printf "failed to find closing quote for '%s'" l-                              (val, _) -> Just val-          bail_out :: String -> e-          bail_out msg = error $ printf "%s:extract_quoted_string %s" ebuild_path msg--extractKeywords :: FilePath -> String -> Maybe [String]-extractKeywords ebuild_path s_ebuild =-    words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS"--extractLicense :: FilePath -> String -> Maybe String-extractLicense ebuild_path s_ebuild =-    extract_quoted_string ebuild_path s_ebuild "LICENSE"---- aggregated (best inferred) metadata for a new ebuild of package-data EMeta = EMeta { keywords :: Maybe [String]-                   , license  :: Maybe String-                   }--findExistingMeta :: FilePath -> IO EMeta-findExistingMeta edir =-    do ebuilds <- filter (isPrefixOf (reverse ".ebuild") . reverse) `fmap` getDirectoryContents edir-       -- TODO: version sort-       e_metas <- forM ebuilds $ \e ->-                      do let e_path = edir </> e-                         e_conts <- readFile e_path-                         return EMeta { keywords = extractKeywords e e_conts-                                      , license  = extractLicense  e e_conts-                                      }-       let get_latest candidates = last (Nothing : filter (/= Nothing) candidates)-           aggregated_meta = EMeta { keywords = get_latest $ map keywords e_metas-                                   , license  = get_latest $ map license e_metas-                                   }-       return $ aggregated_meta- -- "amd64" -> "~amd64" to_unstable :: String -> String to_unstable kw =@@ -444,18 +472,18 @@         '-':_ -> kw         _     -> '~':kw -mergeEbuild :: Verbosity -> FilePath -> String -> E.EBuild -> IO ()-mergeEbuild verbosity target cat ebuild = do-  let edir = target </> cat </> E.name ebuild+mergeEbuild :: Verbosity -> EM.EMeta -> FilePath -> E.EBuild -> IO ()+mergeEbuild verbosity existing_meta pkgdir ebuild = do+  let edir = pkgdir       elocal = E.name ebuild ++"-"++ E.version ebuild <.> "ebuild"       epath = edir </> elocal       emeta = "metadata.xml"       mpath = edir </> emeta       default_meta = BL.pack $ Portage.makeDefaultMetadata (E.long_desc ebuild)   createDirectoryIfMissing True edir-  existing_meta <- findExistingMeta edir+  now <- TC.getCurrentTime -  let (existing_keywords, existing_license)  = (keywords existing_meta, license existing_meta)+  let (existing_keywords, existing_license)  = (EM.keywords existing_meta, EM.license existing_meta)       new_keywords = maybe (E.keywords ebuild) (map to_unstable) existing_keywords       new_license  = either (\err -> maybe (Left err)                                            Right@@ -465,16 +493,16 @@       ebuild'      = ebuild { E.keywords = new_keywords                             , E.license = new_license                             }-      s_ebuild'    = display ebuild'+      s_ebuild'    = E.showEBuild now ebuild'    notice verbosity $ "Current keywords: " ++ show existing_keywords ++ " -> " ++ show new_keywords   notice verbosity $ "Current license:  " ++ show existing_license ++ " -> " ++ show new_license    notice verbosity $ "Writing " ++ elocal-  (length s_ebuild') `seq` BL.writeFile epath (BL.pack s_ebuild')+  length s_ebuild' `seq` BL.writeFile epath (BL.pack s_ebuild')    yet_meta <- doesFileExist mpath-  if (not yet_meta) -- TODO: add --force-meta-rewrite to opts+  if not yet_meta -- TODO: add --force-meta-rewrite to opts       then do notice verbosity $ "Writing " ++ emeta               BL.writeFile mpath default_meta       else do current_meta <- BL.readFile mpath@@ -482,9 +510,7 @@                   notice verbosity $ "Default and current " ++ emeta ++ " differ."  unFlagName :: Cabal.FlagName -> String-unFlagName f =-  let Cabal.FlagName y = f-  in y+unFlagName (Cabal.FlagName fname) = fname  type FlagDep  = (Cabal.FlagAssignment,[Portage.Dependency]) type FlagDepH = (FlagDep,[FlagDep])
Merge/Dependencies.hs view
@@ -332,6 +332,9 @@       , ("icui18n", any_c_p "dev-libs" "icu")       , ("icuuc", any_c_p "dev-libs" "icu")       , ("chipmunk", any_c_p "sci-physics" "chipmunk")+      , ("alut", any_c_p "media-libs" "freealut")+      , ("openal", any_c_p "media-libs" "openal")+      , ("iw", any_c_p "net-wireless" "wireless-tools")       ]  ---------------------------------------------------------------@@ -365,6 +368,7 @@   , ("cabal",               any_c_p "dev-haskell" "cabal-install")   , ("llvm-config",         any_c_p "sys-devel" "llvm")   , ("cpphs",               any_c_p "dev-haskell" "cpphs")+  , ("ghc",                 any_c_p "dev-lang" "ghc")   ]  -- tools that are provided by ghc or some other existing program
Portage/Cabal.hs view
@@ -23,6 +23,7 @@ convertLicense l =     case l of         --  good ones+        Cabal.AGPL mv      -> Right $ "AGPL-" ++ (maybe "3" Cabal.display mv)  -- almost certainly version 3         Cabal.GPL mv       -> Right $ "GPL-" ++ (maybe "2" Cabal.display mv)  -- almost certainly version 2         Cabal.LGPL mv      -> Right $ "LGPL-" ++ (maybe "2.1" Cabal.display mv) -- probably version 2.1         Cabal.BSD3         -> Right "BSD"
Portage/EBuild.hs view
@@ -1,20 +1,22 @@ module Portage.EBuild         ( EBuild(..)         , ebuildTemplate+        , showEBuild         , src_uri         ) where -import Distribution.Text ( Text(..) )-import qualified Text.PrettyPrint as Disp- import Portage.Dependency  import Data.String.Utils+import qualified Data.Time.Clock as TC+import qualified Data.Time.Format as TC import qualified Data.Function as F import qualified Data.List as L import Data.Version(Version(..)) import qualified Paths_hackport(version) +import qualified System.Locale as TC+ data EBuild = EBuild {     name :: String,     hackage_name :: String, -- might differ a bit (we mangle case)@@ -35,6 +37,8 @@     my_pn :: Maybe String -- ^ Just 'myOldName' if the package name contains upper characters     , src_prepare :: [String] -- ^ raw block for src_prepare() contents     , src_configure :: [String] -- ^ raw block for src_configure() contents+    , used_options :: [(String, String)] -- ^ hints to ebuild writers/readers+                                         --   on what hackport options were used to produce an ebuild   }  getHackportVersion :: Version -> String@@ -62,11 +66,9 @@     my_pn = Nothing     , src_prepare = []     , src_configure = []+    , used_options = []   } -instance Text EBuild where-  disp = Disp.text . showEBuild- -- | Given an EBuild, give the URI to the tarball of the source code. -- Assumes that the server is always hackage.haskell.org. src_uri :: EBuild -> String@@ -79,15 +81,16 @@     -- package     Just _  -> "http://hackage.haskell.org/packages/archive/${MY_PN}/${PV}/${MY_P}.tar.gz" -showEBuild :: EBuild -> String-showEBuild ebuild =-  ss "# Copyright 1999-2013 Gentoo Foundation". nl.+showEBuild :: TC.UTCTime -> EBuild -> String+showEBuild now ebuild =+  ss ("# Copyright 1999-" ++ this_year ++ " Gentoo Foundation"). nl.   ss "# Distributed under the terms of the GNU General Public License v2". nl.   ss "# $Header: $". nl.   nl.   ss "EAPI=5". nl.   nl.   ss ("# ebuild generated by hackport " ++ hackportVersion ebuild). nl.+  sconcat (map (\(k, v) -> ss "#hackport: " . ss k . ss ": " . ss v . nl) $ used_options ebuild).   nl.   ss "CABAL_FEATURES=". quote' (sepBy " " $ features ebuild). nl.   ss "inherit haskell-cabal". nl.@@ -124,6 +127,8 @@                                       , (hackage_name ebuild, "${HACKAGE_N}")                                       ]         toMirror = replace "http://hackage.haskell.org/" "mirror://hackage/"+        this_year :: String+        this_year = TC.formatTime TC.defaultTimeLocale "%Y" now  -- "+a" -> "a" -- "b"  -> "b"@@ -148,6 +153,9 @@         else pre .             (foldl (\acc v -> acc . ss "\t" . ss v . nl) id s) .             post++sconcat :: [DString] -> DString+sconcat = L.foldl' (.) id  -- takes string and substitutes tabs to spaces -- ebuild's convention is 4 spaces for one tab,
+ Portage/EMeta.hs view
@@ -0,0 +1,85 @@+module Portage.EMeta+  ( EMeta(..)+  , findExistingMeta+  ) where++import Control.Monad.Error+import Data.Char (isSpace)+import qualified Data.List as L++import System.Directory (doesDirectoryExist, getDirectoryContents)+import System.FilePath ((</>))+import Text.Printf++-- tries to extract value of variable in 'var="val"' format+-- There should be exactly one variable assignment in ebuild+-- It's a bit artificial limitation, but it's common for 'if / else' blocks+extract_quoted_string :: FilePath -> String -> String -> Maybe String+extract_quoted_string ebuild_path s_ebuild var_name =+    case filter (L.isPrefixOf var_prefix . ltrim) $ lines s_ebuild of+        []        -> Nothing+        [kw_line] -> up_to_quote $ skip_prefix $ ltrim kw_line+        other     -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)++    where ltrim :: String -> String+          ltrim = dropWhile isSpace+          var_prefix = var_name ++ "=\""+          skip_prefix = drop (length var_prefix)+          up_to_quote l = case break (== '"') l of+                              ("", _)  -> Nothing -- empty line+                              (_, "")  -> bail_out $ printf "failed to find closing quote for '%s'" l+                              (val, _) -> Just val+          bail_out :: String -> e+          bail_out msg = error $ printf "%s:extract_quoted_string %s" ebuild_path msg++-- tries to extract value of variable in '#hackport: var: val' format+-- There should be exactly one variable assignment in ebuild.+extract_hackport_var :: FilePath -> String -> String -> Maybe String+extract_hackport_var ebuild_path s_ebuild var_name =+    case filter (L.isPrefixOf var_prefix) $ lines s_ebuild of+        []         -> Nothing+        [var_line] -> Just $ skip_prefix var_line+        other      -> bail_out $ printf "strange '%s' assignmets:\n%s" var_name (unlines other)++    where var_prefix = "#hackport: " ++ var_name ++ ": "+          skip_prefix = drop (length var_prefix)+          bail_out :: String -> e+          bail_out msg = error $ printf "%s:extract_hackport_var %s" ebuild_path msg++extractKeywords :: FilePath -> String -> Maybe [String]+extractKeywords ebuild_path s_ebuild =+    words `fmap ` extract_quoted_string ebuild_path s_ebuild "KEYWORDS"++extractLicense :: FilePath -> String -> Maybe String+extractLicense ebuild_path s_ebuild =+    extract_quoted_string ebuild_path s_ebuild "LICENSE"++extractCabalFlags :: FilePath -> String -> Maybe String+extractCabalFlags ebuild_path s_ebuild =+    extract_hackport_var ebuild_path s_ebuild "flags"++-- aggregated (best inferred) metadata for a new ebuild of package+data EMeta = EMeta { keywords :: Maybe [String]+                   , license  :: Maybe String+                   , cabal_flags :: Maybe String+                   }++findExistingMeta :: FilePath -> IO EMeta+findExistingMeta pkgdir =+    do ebuilds <- filter (L.isSuffixOf ".ebuild") `fmap` do b <- doesDirectoryExist pkgdir+                                                            if b then getDirectoryContents pkgdir+                                                                 else return []+       -- TODO: version sort+       e_metas <- forM ebuilds $ \e ->+                      do let e_path = pkgdir </> e+                         e_conts <- readFile e_path+                         return EMeta { keywords = extractKeywords e e_conts+                                      , license = extractLicense  e e_conts+                                      , cabal_flags = extractCabalFlags e e_conts+                                      }+       let get_latest candidates = last (Nothing : filter (/= Nothing) candidates)+           aggregated_meta = EMeta { keywords = get_latest $ map keywords e_metas+                                   , license = get_latest $ map license e_metas+                                   , cabal_flags = get_latest $ map cabal_flags e_metas+                                   }+       return aggregated_meta
Portage/PackageId.hs view
@@ -11,9 +11,12 @@     parseFriendlyPackage,     normalizeCabalPackageName,     normalizeCabalPackageId,-    packageIdToFilePath+    packageIdToFilePath,+    cabal_pn_to_PN   ) where +import Data.Char+ import qualified Distribution.Package as Cabal import Distribution.Text (Text(..)) @@ -124,3 +127,5 @@       return (Just v)     return (mc, p, mv) +cabal_pn_to_PN :: Cabal.PackageName -> String+cabal_pn_to_PN = map toLower . display
Util.hs view
@@ -8,6 +8,7 @@  module Util     ( run_cmd -- :: String -> IO (Maybe String)+    , split -- :: (a -> Bool) -> [a] -> [[a]]     ) where  import System.IO@@ -29,3 +30,10 @@                  return $ if (output == "" || exitCode /= ExitSuccess)                           then Nothing                           else Just output++split :: Eq a => (a -> Bool) -> [a] -> [[a]]+split _ [] = []+split p xs =+    case break p xs of+        (l, [])  -> [l]+        (l, _:r) -> l: split p r
− cabal/.git 
@@ -1,1 +0,0 @@-gitdir: /home/slyfox/portage/hackport/.git/modules/cabal
cabal/.gitignore view
@@ -1,7 +1,9 @@ # trivial gitignore file-+.cabal-sandbox/+cabal.sandbox.config cabal-dev/ Cabal/dist/+Cabal/tests/Setup cabal-install/dist/ .hpc/ *.hi@@ -23,3 +25,7 @@ Cabal/dist-boot/ Cabal/dist-install/ Cabal/ghc.mk+++# TAGS files+TAGS
+ cabal/.travis.yml view
@@ -0,0 +1,44 @@+# NB: don't set `language: haskell` here++# The following enables several GHC versions to be tested; often it's enough to test only against the last release in a major GHC version. Feel free to omit lines listings versions you don't need/want testing for.+env:+ - GHCVER=7.0.4+ - GHCVER=7.4.2+ - GHCVER=7.6.3+ - GHCVER=head++# Note: the distinction between `before_install` and `install` is not important.+before_install:+ - sudo add-apt-repository -y ppa:hvr/ghc+ - sudo apt-get update+ - sudo apt-get install cabal-install-1.18 ghc-$GHCVER happy+ - export PATH=/opt/ghc/$GHCVER/bin:$PATH+ - export CABAL_TEST_RUNNING_ON_TRAVIS=1++install:+ - sudo /opt/ghc/$GHCVER/bin/ghc-pkg recache+ - cabal-1.18 update+ - cd Cabal+ - cabal-1.18 install --only-dependencies --enable-tests --enable-benchmarks++# Here starts the actual work to be performed for the package under test; any command which exits with a non-zero exit code causes the build to fail.+script:+ - cabal-1.18 configure --enable-tests --enable-benchmarks -v2  # -v2 provides useful information for debugging+ - cabal-1.18 build   # this builds all libraries and executables (including tests/benchmarks)+ - cabal-1.18 test+ - cabal-1.18 check+ - cabal-1.18 sdist   # tests that a source-distribution can be generated++# The following scriptlet checks that the resulting source distribution can be built & installed+ - export SRC_TGZ=$(cabal-1.18 info . | awk '{print $2 ".tar.gz";exit}') ;+   cd dist/;+   if [ -f "$SRC_TGZ" ]; then+      cabal-1.18 install "$SRC_TGZ";+   else+      echo "expected '$SRC_TGZ' not found";+      exit 1;+   fi++matrix:+  allow_failures:+   - env: GHCVER=head
cabal/Cabal/Cabal.cabal view
@@ -1,193 +1,289 @@-Name: Cabal-Version: 1.17.0-Copyright: 2003-2006, Isaac Jones+name: Cabal+version: 1.19.2+copyright: 2003-2006, Isaac Jones            2005-2011, Duncan Coutts-License: BSD3-License-File: LICENSE-Author: Isaac Jones <ijones@syntaxpolice.org>+license: BSD3+license-file: LICENSE+author: Isaac Jones <ijones@syntaxpolice.org>         Duncan Coutts <duncan@community.haskell.org>-Maintainer: cabal-devel@haskell.org-Homepage: http://www.haskell.org/cabal/+maintainer: cabal-devel@haskell.org+homepage: http://www.haskell.org/cabal/ bug-reports: https://github.com/haskell/cabal/issues-Synopsis: A framework for packaging Haskell software-Description:-        The Haskell Common Architecture for Building Applications and-        Libraries: a framework defining a common interface for authors to more-        easily build their Haskell applications in a portable way.-        .-        The Haskell Cabal is part of a larger infrastructure for distributing,-        organizing, and cataloging Haskell libraries and tools.-Category: Distribution+synopsis: A framework for packaging Haskell software+description:+  The Haskell Common Architecture for Building Applications and+  Libraries: a framework defining a common interface for authors to more+  easily build their Haskell applications in a portable way.+  .+  The Haskell Cabal is part of a larger infrastructure for distributing,+  organizing, and cataloging Haskell libraries and tools.+category: Distribution cabal-version: >=1.10-Build-Type: Custom+build-type: Custom -- Even though we do use the default Setup.lhs it's vital to bootstrapping -- that we build Setup.lhs using our own local Cabal source code. -Extra-Source-Files:-        README changelog+extra-source-files:+  README tests/README changelog +  -- Generated with 'misc/gen-extra-source-files.sh' & 'M-x sort-lines':+  tests/PackageTests/BenchmarkExeV10/Foo.hs+  tests/PackageTests/BenchmarkExeV10/benchmarks/bench-Foo.hs+  tests/PackageTests/BenchmarkExeV10/my.cabal+  tests/PackageTests/BenchmarkOptions/BenchmarkOptions.cabal+  tests/PackageTests/BenchmarkOptions/test-BenchmarkOptions.hs+  tests/PackageTests/BenchmarkStanza/my.cabal+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/GlobalBuildDepsNotAdditive1.cabal+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive1/MyLibrary.hs+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/GlobalBuildDepsNotAdditive2.cabal+  tests/PackageTests/BuildDeps/GlobalBuildDepsNotAdditive2/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary0/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary0/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary0/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary1/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary1/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary1/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary2/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary2/to-install/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary3/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary3/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary3/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary3/to-install/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary4/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary4/my.cabal+  tests/PackageTests/BuildDeps/InternalLibrary4/programs/lemon.hs+  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/MyLibrary.hs+  tests/PackageTests/BuildDeps/InternalLibrary4/to-install/my.cabal+  tests/PackageTests/BuildDeps/SameDepsAllRound/MyLibrary.hs+  tests/PackageTests/BuildDeps/SameDepsAllRound/SameDepsAllRound.cabal+  tests/PackageTests/BuildDeps/SameDepsAllRound/lemon.hs+  tests/PackageTests/BuildDeps/SameDepsAllRound/pineapple.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps1/MyLibrary.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps1/lemon.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps1/my.cabal+  tests/PackageTests/BuildDeps/TargetSpecificDeps2/MyLibrary.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps2/lemon.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps2/my.cabal+  tests/PackageTests/BuildDeps/TargetSpecificDeps3/MyLibrary.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps3/lemon.hs+  tests/PackageTests/BuildDeps/TargetSpecificDeps3/my.cabal+  tests/PackageTests/BuildTestSuiteDetailedV09/Dummy.hs+  tests/PackageTests/BuildTestSuiteDetailedV09/my.cabal+  tests/PackageTests/CMain/Bar.hs+  tests/PackageTests/CMain/Setup.hs+  tests/PackageTests/CMain/foo.c+  tests/PackageTests/CMain/my.cabal+  tests/PackageTests/DeterministicAr/Lib.hs+  tests/PackageTests/DeterministicAr/my.cabal+  tests/PackageTests/EmptyLib/empty/empty.cabal+  tests/PackageTests/OrderFlags/Foo.hs+  tests/PackageTests/OrderFlags/my.cabal+  tests/PackageTests/PathsModule/Executable/Main.hs+  tests/PackageTests/PathsModule/Executable/my.cabal+  tests/PackageTests/PathsModule/Library/my.cabal+  tests/PackageTests/PreProcess/Foo.hsc+  tests/PackageTests/PreProcess/Main.hs+  tests/PackageTests/PreProcess/my.cabal+  tests/PackageTests/TemplateHaskell/dynamic/Exe.hs+  tests/PackageTests/TemplateHaskell/dynamic/Lib.hs+  tests/PackageTests/TemplateHaskell/dynamic/TH.hs+  tests/PackageTests/TemplateHaskell/dynamic/my.cabal+  tests/PackageTests/TemplateHaskell/profiling/Exe.hs+  tests/PackageTests/TemplateHaskell/profiling/Lib.hs+  tests/PackageTests/TemplateHaskell/profiling/TH.hs+  tests/PackageTests/TemplateHaskell/profiling/my.cabal+  tests/PackageTests/TemplateHaskell/vanilla/Exe.hs+  tests/PackageTests/TemplateHaskell/vanilla/Lib.hs+  tests/PackageTests/TemplateHaskell/vanilla/TH.hs+  tests/PackageTests/TemplateHaskell/vanilla/my.cabal+  tests/PackageTests/TestOptions/TestOptions.cabal+  tests/PackageTests/TestOptions/test-TestOptions.hs+  tests/PackageTests/TestStanza/my.cabal+  tests/PackageTests/TestSuiteExeV10/Foo.hs+  tests/PackageTests/TestSuiteExeV10/my.cabal+  tests/PackageTests/TestSuiteExeV10/tests/test-Foo.hs+  tests/Setup.hs+  tests/hackage/check.sh+  tests/hackage/download.sh+  tests/hackage/unpack.sh+  tests/misc/ghc-supported-languages.hs+ source-repository head   type:     git   location: https://github.com/haskell/cabal/   subdir:   Cabal -Flag base4-    Description: Choose the even newer, even smaller, split-up base package.--Flag base3-    Description: Choose the new smaller, split-up base package.--Flag bytestring-in-base--Library-  build-depends:   base       >= 2   && < 5,-                   deepseq    >= 1.3 && < 1.4,-                   filepath   >= 1   && < 1.4-  if flag(base4) { build-depends: base >= 4 } else { build-depends: base < 4 }-  if flag(base3) { build-depends: base >= 3 } else { build-depends: base < 3 }-  if flag(base3)-    Build-Depends: directory  >= 1   && < 1.3,-                   process    >= 1   && < 1.2,-                   old-time   >= 1   && < 1.2,-                   containers >= 0.1 && < 0.6,-                   array      >= 0.1 && < 0.5,-                   pretty     >= 1   && < 1.2-  if flag(bytestring-in-base)-    Build-Depends: base >= 2.0 && < 2.2-  else-    Build-Depends: base < 2.0 || >= 3.0, bytestring >= 0.9+library+  build-depends:+    base       >= 4       && < 5,+    deepseq    >= 1.3     && < 1.4,+    filepath   >= 1       && < 1.4,+    directory  >= 1       && < 1.3,+    process    >= 1.0.1.1 && < 1.3,+    time       >= 1.1     && < 1.5,+    containers >= 0.1     && < 0.6,+    array      >= 0.1     && < 0.6,+    pretty     >= 1       && < 1.2,+    bytestring >= 0.9    if !os(windows)-    Build-Depends: unix       >= 2.0 && < 2.7+    build-depends:+      unix >= 2.0 && < 2.8 -  ghc-options: -Wall -fno-ignore-asserts-  if impl(ghc >= 6.8)-    ghc-options: -fwarn-tabs-  nhc98-Options: -K4M+  ghc-options: -Wall -fno-ignore-asserts -fwarn-tabs -  Exposed-Modules:-        Distribution.Compiler,-        Distribution.InstalledPackageInfo,-        Distribution.License,-        Distribution.Make,-        Distribution.ModuleName,-        Distribution.Package,-        Distribution.PackageDescription,-        Distribution.PackageDescription.Configuration,-        Distribution.PackageDescription.Parse,-        Distribution.PackageDescription.Check,-        Distribution.PackageDescription.PrettyPrint,-        Distribution.ParseUtils,-        Distribution.ReadE,-        Distribution.Simple,-        Distribution.Simple.Build,-        Distribution.Simple.Build.Macros,-        Distribution.Simple.Build.PathsModule,-        Distribution.Simple.BuildPaths,-        Distribution.Simple.Bench,-        Distribution.Simple.Command,-        Distribution.Simple.Compiler,-        Distribution.Simple.Configure,-        Distribution.Simple.GHC,-        Distribution.Simple.LHC,-        Distribution.Simple.Haddock,-        Distribution.Simple.Hpc,-        Distribution.Simple.Hugs,-        Distribution.Simple.Install,-        Distribution.Simple.InstallDirs,-        Distribution.Simple.JHC,-        Distribution.Simple.LocalBuildInfo,-        Distribution.Simple.NHC,-        Distribution.Simple.PackageIndex,-        Distribution.Simple.PreProcess,-        Distribution.Simple.PreProcess.Unlit,-        Distribution.Simple.Program,-        Distribution.Simple.Program.Ar,-        Distribution.Simple.Program.Builtin,-        Distribution.Simple.Program.Db,-        Distribution.Simple.Program.GHC,-        Distribution.Simple.Program.HcPkg,-        Distribution.Simple.Program.Hpc,-        Distribution.Simple.Program.Ld,-        Distribution.Simple.Program.Run,-        Distribution.Simple.Program.Script,-        Distribution.Simple.Program.Types,-        Distribution.Simple.Register,-        Distribution.Simple.Setup,-        Distribution.Simple.SrcDist,-        Distribution.Simple.Test,-        Distribution.Simple.UHC,-        Distribution.Simple.UserHooks,-        Distribution.Simple.Utils,-        Distribution.System,-        Distribution.TestSuite,-        Distribution.Text,-        Distribution.Verbosity,-        Distribution.Version,-        Distribution.Compat.ReadP,-        Language.Haskell.Extension+  exposed-modules:+    Distribution.Compat.Environment+    Distribution.Compat.Exception+    Distribution.Compat.ReadP+    Distribution.Compiler+    Distribution.InstalledPackageInfo+    Distribution.License+    Distribution.Make+    Distribution.ModuleName+    Distribution.Package+    Distribution.PackageDescription+    Distribution.PackageDescription.Check+    Distribution.PackageDescription.Configuration+    Distribution.PackageDescription.Parse+    Distribution.PackageDescription.PrettyPrint+    Distribution.PackageDescription.Utils+    Distribution.ParseUtils+    Distribution.ReadE+    Distribution.Simple+    Distribution.Simple.Bench+    Distribution.Simple.Build+    Distribution.Simple.Build.Macros+    Distribution.Simple.Build.PathsModule+    Distribution.Simple.BuildPaths+    Distribution.Simple.BuildTarget+    Distribution.Simple.CCompiler+    Distribution.Simple.Command+    Distribution.Simple.Compiler+    Distribution.Simple.Configure+    Distribution.Simple.GHC+    Distribution.Simple.Haddock+    Distribution.Simple.HaskellSuite+    Distribution.Simple.Hpc+    Distribution.Simple.Hugs+    Distribution.Simple.Install+    Distribution.Simple.InstallDirs+    Distribution.Simple.JHC+    Distribution.Simple.LHC+    Distribution.Simple.LocalBuildInfo+    Distribution.Simple.NHC+    Distribution.Simple.PackageIndex+    Distribution.Simple.PreProcess+    Distribution.Simple.PreProcess.Unlit+    Distribution.Simple.Program+    Distribution.Simple.Program.Ar+    Distribution.Simple.Program.Builtin+    Distribution.Simple.Program.Db+    Distribution.Simple.Program.Find+    Distribution.Simple.Program.GHC+    Distribution.Simple.Program.HcPkg+    Distribution.Simple.Program.Hpc+    Distribution.Simple.Program.Ld+    Distribution.Simple.Program.Run+    Distribution.Simple.Program.Script+    Distribution.Simple.Program.Strip+    Distribution.Simple.Program.Types+    Distribution.Simple.Register+    Distribution.Simple.Setup+    Distribution.Simple.SrcDist+    Distribution.Simple.Test+    Distribution.Simple.UHC+    Distribution.Simple.UserHooks+    Distribution.Simple.Utils+    Distribution.System+    Distribution.TestSuite+    Distribution.Text+    Distribution.Verbosity+    Distribution.Version+    Language.Haskell.Extension -  Other-Modules:-        Distribution.GetOpt,-        Distribution.Compat.Exception,-        Distribution.Compat.CopyFile,-        Distribution.Compat.TempFile,-        Distribution.Simple.GHC.IPI641,-        Distribution.Simple.GHC.IPI642,-        Paths_Cabal+  other-modules:+    Distribution.Compat.CopyFile+    Distribution.Compat.TempFile+    Distribution.GetOpt+    Distribution.Simple.GHC.IPI641+    Distribution.Simple.GHC.IPI642+    Paths_Cabal -  Default-Language: Haskell98-  Default-Extensions: CPP+  default-language: Haskell98+  default-extensions: CPP  -- Small, fast running tests. test-suite unit-tests   type: exitcode-stdio-1.0-  main-is: UnitTests.hs   hs-source-dirs: tests+  other-modules: UnitTests.Distribution.Compat.ReadP+  main-is: UnitTests.hs   build-depends:-        base,-        test-framework,-        test-framework-hunit,-        test-framework-quickcheck2,-        HUnit,-        QuickCheck,-        Cabal-  Default-Language: Haskell98+    base,+    test-framework,+    test-framework-hunit,+    test-framework-quickcheck2,+    HUnit,+    QuickCheck,+    Cabal+  ghc-options: -Wall+  default-language: Haskell98  -- Large, system tests that build packages. test-suite package-tests   type: exitcode-stdio-1.0   main-is: PackageTests.hs-  other-modules: PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check,-                 PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check,-                 PackageTests.BuildDeps.InternalLibrary0.Check,-                 PackageTests.BuildDeps.InternalLibrary1.Check,-                 PackageTests.BuildDeps.InternalLibrary2.Check,-                 PackageTests.BuildDeps.InternalLibrary3.Check,-                 PackageTests.BuildDeps.InternalLibrary4.Check,-                 PackageTests.BuildDeps.TargetSpecificDeps1.Check,-                 PackageTests.BuildDeps.TargetSpecificDeps2.Check,-                 PackageTests.BuildDeps.TargetSpecificDeps3.Check,-                 PackageTests.BuildDeps.SameDepsAllRound.Check,-                 PackageTests.TestOptions.Check,-                 PackageTests.TestStanza.Check,-                 PackageTests.TestSuiteExeV10.Check,-                 PackageTests.BenchmarkStanza.Check,-                 PackageTests.TemplateHaskell.Check,-                 PackageTests.PackageTester+  other-modules:+    Distribution.Compat.CreatePipe+    PackageTests.BenchmarkExeV10.Check+    PackageTests.BenchmarkOptions.Check+    PackageTests.BenchmarkStanza.Check+    PackageTests.BuildDeps.GlobalBuildDepsNotAdditive1.Check+    PackageTests.BuildDeps.GlobalBuildDepsNotAdditive2.Check+    PackageTests.BuildDeps.InternalLibrary0.Check+    PackageTests.BuildDeps.InternalLibrary1.Check+    PackageTests.BuildDeps.InternalLibrary2.Check+    PackageTests.BuildDeps.InternalLibrary3.Check+    PackageTests.BuildDeps.InternalLibrary4.Check+    PackageTests.BuildDeps.SameDepsAllRound.Check+    PackageTests.BuildDeps.TargetSpecificDeps1.Check+    PackageTests.BuildDeps.TargetSpecificDeps2.Check+    PackageTests.BuildDeps.TargetSpecificDeps3.Check+    PackageTests.BuildTestSuiteDetailedV09.Check+    PackageTests.CMain.Check+    PackageTests.DeterministicAr.Check+    PackageTests.EmptyLib.Check+    PackageTests.OrderFlags.Check+    PackageTests.PackageTester+    PackageTests.PathsModule.Executable.Check+    PackageTests.PathsModule.Library.Check+    PackageTests.PreProcess.Check+    PackageTests.TemplateHaskell.Check+    PackageTests.TestOptions.Check+    PackageTests.TestStanza.Check+    PackageTests.TestSuiteExeV10.Check   hs-source-dirs: tests   build-depends:-        base,-        test-framework,-        test-framework-quickcheck2 >= 0.2.12,-        test-framework-hunit,-        HUnit,-        QuickCheck >= 2.1.0.1,-        Cabal,-        process,-        directory,-        filepath,-        extensible-exceptions,-        bytestring,-        unix-  Default-Language: Haskell98+    base,+    test-framework,+    test-framework-quickcheck2 >= 0.2.12,+    test-framework-hunit,+    HUnit,+    QuickCheck >= 2.1.0.1,+    Cabal,+    process,+    directory,+    filepath,+    extensible-exceptions,+    bytestring,+    regex-posix+  if !os(windows)+    build-depends: unix+  ghc-options: -Wall+  default-extensions: CPP+  default-language: Haskell98
− cabal/Cabal/DefaultSetup.hs 
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
cabal/Cabal/Distribution/Compat/CopyFile.hs view
@@ -1,12 +1,9 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--- #hide+{-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.CopyFile (   copyFile,+  copyFileChanged,+  filesEqual,   copyOrdinaryFile,   copyExecutableFile,   setFileOrdinary,@@ -14,49 +11,36 @@   setDirOrdinary,   ) where -#ifdef __GLASGOW_HASKELL__  import Control.Monad-         ( when )+         ( when, unless ) import Control.Exception-         ( bracket, bracketOnError )+         ( bracket, bracketOnError, throwIO )+import qualified Data.ByteString.Lazy as BSL import Distribution.Compat.Exception          ( catchIO )-#if __GLASGOW_HASKELL__ >= 608-import Distribution.Compat.Exception-         ( throwIOIO ) import System.IO.Error          ( ioeSetLocation )-#endif import System.Directory-         ( renameFile, removeFile )+         ( doesFileExist, renameFile, removeFile ) import Distribution.Compat.TempFile          ( openBinaryTempFile ) import System.FilePath          ( takeDirectory ) import System.IO-         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf )+         ( openBinaryFile, IOMode(ReadMode), hClose, hGetBuf, hPutBuf+         , withBinaryFile ) import Foreign          ( allocaBytes )-#endif /* __GLASGOW_HASKELL__ */  #ifndef mingw32_HOST_OS-#if __GLASGOW_HASKELL__ >= 611 import System.Posix.Internals (withFilePath)-#else-import Foreign.C              (withCString)-#endif import System.Posix.Types          ( FileMode ) import System.Posix.Internals          ( c_chmod )-#if __GLASGOW_HASKELL__ >= 608 import Foreign.C          ( throwErrnoPathIfMinus1_ )-#else-import Foreign.C-         ( throwErrnoIfMinus1_ )-#endif #endif /* mingw32_HOST_OS */  copyOrdinaryFile, copyExecutableFile :: FilePath -> FilePath -> IO ()@@ -70,30 +54,21 @@  setFileMode :: FilePath -> FileMode -> IO () setFileMode name m =-#if __GLASGOW_HASKELL__ >= 611   withFilePath name $ \s -> do-#else-  withCString name $ \s -> do-#endif-#if __GLASGOW_HASKELL__ >= 608     throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m) #else-    throwErrnoIfMinus1_                   name (c_chmod s m)-#endif-#else setFileOrdinary   _ = return () setFileExecutable _ = return () #endif -- This happens to be true on Unix and currently on Windows too: setDirOrdinary = setFileExecutable +-- | Copies a file to a new destination.+-- Often you should use `copyFileChanged` instead. copyFile :: FilePath -> FilePath -> IO ()-#ifdef __GLASGOW_HASKELL__ copyFile fromFPath toFPath =   copy-#if __GLASGOW_HASKELL__ >= 608-    `catchIO` (\ioe -> throwIOIO (ioeSetLocation ioe "copyFile"))-#endif+    `catchIO` (\ioe -> throwIO (ioeSetLocation ioe "copyFile"))     where copy = bracket (openBinaryFile fromFPath ReadMode) hClose $ \hFrom ->                  bracketOnError openTmp cleanTmp $ \(tmpFPath, hTmp) ->                  do allocaBytes bufferSize $ copyContents hFrom hTmp@@ -110,6 +85,25 @@                   when (count > 0) $ do                           hPutBuf hTo buffer count                           copyContents hFrom hTo buffer-#else-copyFile fromFPath toFPath = readFile fromFPath >>= writeFile toFPath-#endif++-- | Like `copyFile`, but does not touch the target if source and destination+-- are already byte-identical. This is recommended as it is useful for+-- time-stamp based recompilation avoidance.+copyFileChanged :: FilePath -> FilePath -> IO ()+copyFileChanged src dest = do+  equal <- filesEqual src dest+  unless equal $ copyFile src dest++-- | Checks if two files are byte-identical.+-- Returns False if either of the files do not exist.+filesEqual :: FilePath -> FilePath -> IO Bool+filesEqual f1 f2 = do+  ex1 <- doesFileExist f1+  ex2 <- doesFileExist f2+  if not (ex1 && ex2) then return False else do++    withBinaryFile f1 ReadMode $ \h1 ->+      withBinaryFile f2 ReadMode $ \h2 -> do+        c1 <- BSL.hGetContents h1+        c2 <- BSL.hGetContents h2+        return $! c1 == c2
+ cabal/Cabal/Distribution/Compat/Environment.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}++module Distribution.Compat.Environment (getEnvironment)+       where++import qualified System.Environment as System++#ifdef mingw32_HOST_OS+import qualified Data.Char as Char (toUpper)+#endif++getEnvironment :: IO [(String, String)]+#ifdef mingw32_HOST_OS+-- On Windows, the names of environment variables are case-insensitive, but are+-- often given in mixed-case (e.g. "PATH" is "Path"), so we have to normalise+-- them.+getEnvironment = fmap upcaseVars System.getEnvironment+  where+    upcaseVars = map upcaseVar+    upcaseVar (var, val) = (map Char.toUpper var, val)+#else+getEnvironment = System.getEnvironment+#endif
cabal/Cabal/Distribution/Compat/Exception.hs view
@@ -1,61 +1,17 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 610))-#define NEW_EXCEPTION-#endif- module Distribution.Compat.Exception (-     Exception.IOException,-     onException,-     catchIO,-     catchExit,-     throwIOIO,-     tryIO,+  catchIO,+  catchExit,+  tryIO,   ) where  import System.Exit import qualified Control.Exception as Exception -onException :: IO a -> IO b -> IO a-#ifdef NEW_EXCEPTION-onException = Exception.onException-#else-onException io what = io `Exception.catch` \e -> do what-                                                    Exception.throw e-#endif--throwIOIO :: Exception.IOException -> IO a-#ifdef NEW_EXCEPTION-throwIOIO = Exception.throwIO-#else-throwIOIO = Exception.throwIO . Exception.IOException-#endif- tryIO :: IO a -> IO (Either Exception.IOException a)-#ifdef NEW_EXCEPTION tryIO = Exception.try-#else-tryIO = Exception.tryJust Exception.ioErrors-#endif  catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#ifdef NEW_EXCEPTION catchIO = Exception.catch-#else-catchIO = Exception.catchJust Exception.ioErrors-#endif  catchExit :: IO a -> (ExitCode -> IO a) -> IO a-#ifdef NEW_EXCEPTION catchExit = Exception.catch-#else-catchExit = Exception.catchJust exitExceptions-    where exitExceptions (Exception.ExitException ee) = Just ee-          exitExceptions _                            = Nothing-#endif-
cabal/Cabal/Distribution/Compat/ReadP.hs view
@@ -69,8 +69,9 @@   )  where -import Control.Monad( MonadPlus(..), liftM2 )+import Control.Monad( MonadPlus(..), liftM, liftM2, ap ) import Data.Char (isSpace)+import Control.Applicative (Applicative(..), Alternative(empty, (<|>)))  infixr 5 +++, <++ @@ -87,6 +88,13 @@  -- Monad, MonadPlus +instance Functor (P s) where+  fmap = liftM++instance Applicative (P s) where+  pure = return+  (<*>) = ap+ instance Monad (P s) where   return x = Result x Fail @@ -98,6 +106,10 @@    fail _ = Fail +instance Alternative (P s) where+      empty = mzero+      (<|>) = mplus+ instance MonadPlus (P s) where   mzero = Fail @@ -138,6 +150,10 @@ instance Functor (Parser r s) where   fmap h (R f) = R (\k -> f (k . h)) +instance Applicative (Parser r s) where+  pure = return+  (<*>) = ap+ instance Monad (Parser r s) where   return x  = R (\k -> k x)   fail _    = R (\_ -> Fail)@@ -376,6 +392,3 @@ --   parser, and therefore a possible inefficiency. readS_to_P r =   R (\k -> Look (\s -> final [bs'' | (a,s') <- r s, bs'' <- run (k a) s']))---
cabal/Cabal/Distribution/Compat/TempFile.hs view
@@ -1,10 +1,5 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first {-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--- #hide+{-# OPTIONS_HADDOCK hide #-} module Distribution.Compat.TempFile (   openTempFile,   openBinaryTempFile,@@ -16,39 +11,19 @@ import System.FilePath        ((</>)) import Foreign.C              (eEXIST) -#if __NHC__ || __HUGS__-import System.IO              (openFile, openBinaryFile,-                               Handle, IOMode(ReadWriteMode))-import System.Directory       (doesFileExist)-import System.FilePath        ((<.>), splitExtension)-import System.IO.Error        (try, isAlreadyExistsError)-#else import System.IO              (Handle, openTempFile, openBinaryTempFile) import Data.Bits              ((.|.)) import System.Posix.Internals (c_open, c_close, o_CREAT, o_EXCL, o_RDWR,                                o_BINARY, o_NONBLOCK, o_NOCTTY) import System.IO.Error        (isAlreadyExistsError)-#if __GLASGOW_HASKELL__ >= 611 import System.Posix.Internals (withFilePath)-#else-import Foreign.C              (withCString)-#endif import Foreign.C              (CInt)-#if __GLASGOW_HASKELL__ >= 611 import GHC.IO.Handle.FD       (fdToHandle)-#else-import GHC.Handle             (fdToHandle)-#endif-import Distribution.Compat.Exception (onException, tryIO)-#endif+import Distribution.Compat.Exception (tryIO)+import Control.Exception      (onException) import Foreign.C              (getErrno, errnoToIOError) -#if __NHC__-import System.Posix.Types     (CPid(..))-foreign import ccall unsafe "getpid" c_getpid :: IO CPid-#else import System.Posix.Internals (c_getpid)-#endif  #ifdef mingw32_HOST_OS import System.Directory       ( createDirectory )@@ -64,43 +39,6 @@ -- System.IO.openTempFile. This includes nhc-1.20, hugs-2006.9. -- TODO: Not sure about jhc -#if __NHC__ || __HUGS__--- use a temporary filename that doesn't already exist.--- NB. *not* secure (we don't atomically lock the tmp file we get)-openTempFile :: FilePath -> String -> IO (FilePath, Handle)-openTempFile tmp_dir template-  = do x <- getProcessID-       findTempName x-  where-    (templateBase, templateExt) = splitExtension template-    findTempName :: Int -> IO (FilePath, Handle)-    findTempName x-      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt-           b  <- doesFileExist path-           if b then findTempName (x+1)-                else do hnd <- openFile path ReadWriteMode-                        return (path, hnd)--openBinaryTempFile :: FilePath -> String -> IO (FilePath, Handle)-openBinaryTempFile tmp_dir template-  = do x <- getProcessID-       findTempName x-  where-    (templateBase, templateExt) = splitExtension template-    findTempName :: Int -> IO (FilePath, Handle)-    findTempName x-      = do let path = tmp_dir </> (templateBase ++ "-" ++ show x) <.> templateExt-           b  <- doesFileExist path-           if b then findTempName (x+1)-                else do hnd <- openBinaryFile path ReadWriteMode-                        return (path, hnd)--openNewBinaryFile :: FilePath -> String -> IO (FilePath, Handle)-openNewBinaryFile = openBinaryTempFile--getProcessID :: IO Int-getProcessID = fmap fromIntegral c_getpid-#else -- This is a copy/paste of the openBinaryTempFile definition, but -- if uses 666 rather than 600 for the permissions. The base library -- needs to be changed to make this better.@@ -128,10 +66,6 @@      oflags = rw_flags .|. o_EXCL .|. o_BINARY -#if __GLASGOW_HASKELL__ < 611-    withFilePath = withCString-#endif-     findTempName x = do       fd <- withFilePath filepath $ \ f ->               c_open f oflags 0o666@@ -145,17 +79,7 @@          -- TODO: We want to tell fdToHandle what the filepath is,          -- as any exceptions etc will only be able to report the          -- fd currently-         h <--#if __GLASGOW_HASKELL__ >= 609-              fdToHandle fd-#elif __GLASGOW_HASKELL__ <= 606 && defined(mingw32_HOST_OS)-              -- fdToHandle is borked on Windows with ghc-6.6.x-              openFd (fromIntegral fd) Nothing False filepath-                                       ReadWriteMode True-#else-              fdToHandle (fromIntegral fd)-#endif-              `onException` c_close fd+         h <- fdToHandle fd `onException` c_close fd          return (filepath, h)       where         filename        = prefix ++ show x ++ suffix@@ -181,7 +105,6 @@ std_flags    = o_NONBLOCK   .|. o_NOCTTY output_flags = std_flags    .|. o_CREAT rw_flags     = output_flags .|. o_RDWR-#endif  createTempDirectory :: FilePath -> String -> IO FilePath createTempDirectory dir template = do
cabal/Cabal/Distribution/Compiler.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Compiler@@ -19,7 +20,7 @@ -- Unfortunately we cannot make this change yet without breaking the -- 'UserHooks' api, which would break all custom @Setup.hs@ files, so for the -- moment we just have to live with this deficiency. If you're interested, see--- ticket #50.+-- ticket #57.  {- All rights reserved. @@ -54,6 +55,7 @@ module Distribution.Compiler (   -- * Compiler flavor   CompilerFlavor(..),+  buildCompilerId,   buildCompilerFlavor,   defaultCompilerFlavor,   parseCompilerFlavorCompat,@@ -62,9 +64,12 @@   CompilerId(..),   ) where +import Data.Data (Data)+import Data.Typeable (Typeable)+import Data.Maybe (fromMaybe) import Distribution.Version (Version(..)) -import qualified System.Info (compilerName)+import qualified System.Info (compilerName, compilerVersion) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp@@ -74,14 +79,16 @@ import Control.Monad (when)  data CompilerFlavor = GHC | NHC | YHC | Hugs | HBC | Helium | JHC | LHC | UHC+                    | HaskellSuite String -- string is the id of the actual compiler                     | OtherCompiler String-  deriving (Show, Read, Eq, Ord)+  deriving (Show, Read, Eq, Ord, Typeable, Data)  knownCompilerFlavors :: [CompilerFlavor] knownCompilerFlavors = [GHC, NHC, YHC, Hugs, HBC, Helium, JHC, LHC, UHC]  instance Text CompilerFlavor where   disp (OtherCompiler name) = Disp.text name+  disp (HaskellSuite name)  = Disp.text name   disp NHC                  = Disp.text "nhc98"   disp other                = Disp.text (lowercase (show other)) @@ -92,9 +99,7 @@  classifyCompilerFlavor :: String -> CompilerFlavor classifyCompilerFlavor s =-  case lookup (lowercase s) compilerMap of-    Just compiler -> compiler-    Nothing       -> OtherCompiler s+  fromMaybe (OtherCompiler s) $ lookup (lowercase s) compilerMap   where     compilerMap = [ (display compiler, compiler)                   | compiler <- knownCompilerFlavors ]@@ -126,6 +131,12 @@  buildCompilerFlavor :: CompilerFlavor buildCompilerFlavor = classifyCompilerFlavor System.Info.compilerName++buildCompilerVersion :: Version+buildCompilerVersion = System.Info.compilerVersion++buildCompilerId :: CompilerId+buildCompilerId = CompilerId buildCompilerFlavor buildCompilerVersion  -- | The default compiler flavour to pick when compiling stuff. This defaults -- to the compiler used to build the Cabal lib.
cabal/Cabal/Distribution/GetOpt.hs view
@@ -36,7 +36,7 @@ :-) -} --- #hide+{-# OPTIONS_HADDOCK hide #-} module Distribution.GetOpt (    -- * GetOpt    getOpt, getOpt',@@ -50,7 +50,8 @@    -- $example ) where -import Data.List ( isPrefixOf, intersperse, find )+import Data.List ( isPrefixOf, intercalate, find )+import Data.Maybe ( isJust )  -- |What to do with options following non-options data ArgOrder a@@ -98,7 +99,7 @@           -> [OptDescr a]              -- option descriptors           -> String                    -- nicely formatted decription of options usageInfo header optDescr = unlines (header:table)-   where (ss,ls,ds) = unzip3 [ (sepBy ", " (map (fmtShort ad) sos)+   where (ss,ls,ds) = unzip3 [ (intercalate ", " (map (fmtShort ad) sos)                                ,concatMap (fmtLong  ad) (take 1 los)                                ,d)                              | Option sos los ad d <- optDescr ]@@ -111,7 +112,6 @@                       | (so,lo,d) <- zip3 ss ls ds                       , (so',lo',d') <- fmtOpt dsWidth so lo d ]          padTo n x  = take n (x ++ repeat ' ')-         sepBy s    = concat . intersperse s  fmtOpt :: Int -> String -> String -> String -> [(String, String, String)] fmtOpt descrWidth so lo descr =@@ -201,11 +201,11 @@ longOpt ls rs optDescr = long ads arg rs    where (opt,arg) = break (=='=') ls          getWith p = [ o  | o@(Option _ xs _ _) <- optDescr-                          , find (p opt) xs /= Nothing]+                          , isJust (find (p opt) xs)]          exact     = getWith (==)          options   = if null exact then getWith isPrefixOf else exact          ads       = [ ad | Option _ _ ad _ <- options ]-         optStr    = ("--"++opt)+         optStr    = "--" ++ opt           long (_:_:_)      _        rest     = (errAmbig options optStr,rest)          long [NoArg  a  ] []       rest     = (Opt a,rest)
cabal/Cabal/Distribution/InstalledPackageInfo.hs view
@@ -61,19 +61,22 @@         parseInstalledPackageInfo,         showInstalledPackageInfo,         showInstalledPackageInfoField,+        showSimpleInstalledPackageInfoField,         fieldsInstalledPackageInfo,   ) where  import Distribution.ParseUtils          ( FieldDescr(..), ParseResult(..), PError(..), PWarning          , simpleField, listField, parseLicenseQ-         , showFields, showSingleNamedField, parseFieldsFlat+         , showFields, showSingleNamedField, showSimpleSingleNamedField+         , parseFieldsFlat          , parseFilePathQ, parseTokenQ, parseModuleNameQ, parsePackageNameQ          , showFilePath, showToken, boolField, parseOptVersion          , parseFreeText, showFreeText ) import Distribution.License     ( License(..) ) import Distribution.Package-         ( PackageName(..), PackageIdentifier(..), PackageId, InstalledPackageId(..)+         ( PackageName(..), PackageIdentifier(..)+         , PackageId, InstalledPackageId(..)          , packageName, packageVersion ) import qualified Distribution.Package as Package          ( Package(..) )@@ -184,6 +187,9 @@  showInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String) showInstalledPackageInfoField = showSingleNamedField fieldsInstalledPackageInfo++showSimpleInstalledPackageInfoField :: String -> Maybe (InstalledPackageInfo -> String)+showSimpleInstalledPackageInfoField = showSimpleSingleNamedField fieldsInstalledPackageInfo  -- ----------------------------------------------------------------------------- -- Description of the fields, for parsing/printing
cabal/Cabal/Distribution/License.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.License@@ -15,7 +16,7 @@ -- and it's useful if we can automatically recognise that (eg so we can display -- it on the hackage web pages). So you can also specify the license itself in -- the @.cabal@ file from a short enumeration defined in this module. It--- includes 'GPL', 'LGPL' and 'BSD3' licenses.+-- includes 'GPL', 'AGPL', 'LGPL', 'Apache 2.0', 'MIT' and 'BSD3' licenses.  {- All rights reserved. @@ -59,6 +60,8 @@ import qualified Text.PrettyPrint as Disp import Text.PrettyPrint ((<>)) import qualified Data.Char as Char (isAlphaNum)+import Data.Data (Data)+import Data.Typeable (Typeable)  -- |This datatype indicates the license under which your package is -- released.  It is also wise to add your license to each source file@@ -76,6 +79,9 @@     -- | GNU Public License. Source code must accompany alterations.     GPL (Maybe Version) +    -- | GNU Affero General Public License+  | AGPL (Maybe Version)+     -- | Lesser GPL, Less restrictive than GPL, useful for libraries.   | LGPL (Maybe Version) @@ -106,11 +112,12 @@     -- | Not a recognised license.     -- Allows us to deal with future extensions more gracefully.   | UnknownLicense String-  deriving (Read, Show, Eq)+  deriving (Read, Show, Eq, Typeable, Data)  knownLicenses :: [License] knownLicenses = [ GPL  unversioned, GPL  (version [2]),   GPL  (version [3])                 , LGPL unversioned, LGPL (version [2,1]), LGPL (version [3])+                , AGPL unversioned,                       AGPL (version [3])                 , BSD3, MIT                 , Apache unversioned, Apache (version [2, 0])                 , PublicDomain, AllRightsReserved, OtherLicense]@@ -121,6 +128,7 @@ instance Text License where   disp (GPL  version)         = Disp.text "GPL"  <> dispOptVersion version   disp (LGPL version)         = Disp.text "LGPL" <> dispOptVersion version+  disp (AGPL version)         = Disp.text "AGPL" <> dispOptVersion version   disp (Apache version)       = Disp.text "Apache" <> dispOptVersion version   disp (UnknownLicense other) = Disp.text other   disp other                  = Disp.text (show other)@@ -131,6 +139,7 @@     return $! case (name, version :: Maybe Version) of       ("GPL",               _      ) -> GPL  version       ("LGPL",              _      ) -> LGPL version+      ("AGPL",              _      ) -> AGPL version       ("BSD3",              Nothing) -> BSD3       ("BSD4",              Nothing) -> BSD4       ("MIT",               Nothing) -> MIT
cabal/Cabal/Distribution/Make.hs view
@@ -106,7 +106,7 @@          ( display )  import System.Environment (getArgs, getProgName)-import Data.List  (intersperse)+import Data.List  (intercalate) import System.Exit  defaultMain :: IO ()@@ -138,7 +138,7 @@     printHelp help = getProgName >>= putStr . help     printOptionsList = putStr . unlines     printErrors errs = do-      putStr (concat (intersperse "\n" errs))+      putStr (intercalate "\n" errs)       exitWith (ExitFailure 1)     printNumericVersion = putStrLn $ display cabalVersion     printVersion        = putStrLn $ "Cabal library version "
cabal/Cabal/Distribution/ModuleName.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.ModuleName@@ -50,6 +51,8 @@ import Distribution.Text          ( Text(..) ) +import Data.Data (Data)+import Data.Typeable (Typeable) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char@@ -57,12 +60,12 @@ import System.FilePath          ( pathSeparator ) import Data.List-         ( intersperse )+         ( intercalate, intersperse )  -- | A valid Haskell module name. -- newtype ModuleName = ModuleName [String]-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Ord, Read, Show, Typeable, Data)  instance Text ModuleName where   disp (ModuleName ms) =@@ -127,4 +130,4 @@ -- > toFilePath (fromString "A.B.C") = "A/B/C" -- toFilePath :: ModuleName -> FilePath-toFilePath = concat . intersperse [pathSeparator] . components+toFilePath = intercalate [pathSeparator] . components
cabal/Cabal/Distribution/Package.hs view
@@ -73,17 +73,18 @@ import Text.PrettyPrint ((<>), (<+>), text) import Control.DeepSeq (NFData(..)) import qualified Data.Char as Char ( isDigit, isAlphaNum )-import Data.List ( intersperse )+import Data.List ( intercalate )+import Data.Data ( Data ) import Data.Typeable ( Typeable )  newtype PackageName = PackageName String-    deriving (Read, Show, Eq, Ord, Typeable)+    deriving (Read, Show, Eq, Ord, Typeable, Data)  instance Text PackageName where   disp (PackageName n) = Disp.text n   parse = do     ns <- Parse.sepBy1 component (Parse.char '-')-    return (PackageName (concat (intersperse "-" ns)))+    return (PackageName (intercalate "-" ns))     where       component = do         cs <- Parse.munch1 Char.isAlphaNum@@ -103,7 +104,7 @@         pkgName    :: PackageName, -- ^The name of this package, eg. foo         pkgVersion :: Version -- ^the version of this package, eg 1.2      }-     deriving (Read, Show, Eq, Ord, Typeable)+     deriving (Read, Show, Eq, Ord, Typeable, Data)  instance Text PackageIdentifier where   disp (PackageIdentifier n v) = case v of@@ -122,12 +123,12 @@ -- * Installed Package Ids -- ------------------------------------------------------------ --- | An InstalledPackageId uniquely identifies an instance of an installed package.--- There can be at most one package with a given 'InstalledPackageId'+-- | An InstalledPackageId uniquely identifies an instance of an installed+-- package.  There can be at most one package with a given 'InstalledPackageId' -- in a package database, or overlay of databases. -- newtype InstalledPackageId = InstalledPackageId String- deriving (Read,Show,Eq,Ord)+ deriving (Read,Show,Eq,Ord,Typeable,Data)  instance Text InstalledPackageId where   disp (InstalledPackageId str) = text str@@ -142,7 +143,7 @@ -- | Describes a dependency on a source package (API) -- data Dependency = Dependency PackageName VersionRange-                  deriving (Read, Show, Eq)+                  deriving (Read, Show, Eq, Typeable, Data)  instance Text Dependency where   disp (Dependency name ver) =
cabal/Cabal/Distribution/PackageDescription.hs view
@@ -124,8 +124,9 @@         knownRepoTypes,   ) where -import Data.List   (nub, intersperse)-import Data.Maybe  (maybeToList)+import Data.Data   (Data)+import Data.List   (nub, intercalate)+import Data.Maybe  (fromMaybe, maybeToList) import Data.Monoid (Monoid(mempty, mappend)) import Data.Typeable ( Typeable ) import Control.Monad (MonadPlus(mplus))@@ -193,9 +194,10 @@         dataFiles      :: [FilePath],         dataDir        :: FilePath,         extraSrcFiles  :: [FilePath],-        extraTmpFiles  :: [FilePath]+        extraTmpFiles  :: [FilePath],+        extraDocFiles  :: [FilePath]     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  instance Package PackageDescription where   packageId = package@@ -256,7 +258,8 @@                       dataFiles    = [],                       dataDir      = "",                       extraSrcFiles = [],-                      extraTmpFiles = []+                      extraTmpFiles = [],+                      extraDocFiles = []                      }  -- | The type of build system used by this package.@@ -272,7 +275,7 @@                 --   be built. Doing it this way rather than just giving a                 --   parse error means we get better error messages and allows                 --   you to inspect the rest of the package description.-                deriving (Show, Read, Eq)+                deriving (Show, Read, Eq, Typeable, Data)  knownBuildTypes :: [BuildType] knownBuildTypes = [Simple, Configure, Make, Custom]@@ -298,7 +301,7 @@         libExposed        :: Bool, -- ^ Is the lib to be exposed by default?         libBuildInfo      :: BuildInfo     }-    deriving (Show, Eq, Read)+    deriving (Show, Eq, Read, Typeable, Data)  instance Monoid Library where   mempty = Library {@@ -346,7 +349,7 @@         modulePath :: FilePath,         buildInfo  :: BuildInfo     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  instance Monoid Executable where   mempty = Executable {@@ -400,7 +403,7 @@         -- a better solution is waiting on the next overhaul to the         -- GenericPackageDescription -> PackageDescription resolution process.     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  -- | The test suite interfaces that are currently defined. Each test suite must -- specify which interface it supports.@@ -426,7 +429,7 @@      -- the given reason (e.g. unknown test type).      --    | TestSuiteUnsupported TestType-   deriving (Eq, Read, Show)+   deriving (Eq, Read, Show, Typeable, Data)  instance Monoid TestSuite where     mempty = TestSuite {@@ -440,7 +443,7 @@         testName      = combine' testName,         testInterface = combine  testInterface,         testBuildInfo = combine  testBuildInfo,-        testEnabled   = if testEnabled a then True else testEnabled b+        testEnabled   = testEnabled a || testEnabled b     }         where combine   field = field a `mappend` field b               combine' f = case (f a, f b) of@@ -482,33 +485,36 @@ data TestType = TestTypeExe Version     -- ^ \"type: exitcode-stdio-x.y\"               | TestTypeLib Version     -- ^ \"type: detailed-x.y\"               | TestTypeUnknown String Version -- ^ Some unknown test type e.g. \"type: foo\"-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  knownTestTypes :: [TestType] knownTestTypes = [ TestTypeExe (Version [1,0] [])                  , TestTypeLib (Version [0,9] []) ] +stdParse :: Text ver => (ver -> String -> res) -> Parse.ReadP r res+stdParse f = do+  cs   <- Parse.sepBy1 component (Parse.char '-')+  _    <- Parse.char '-'+  ver  <- parse+  let name = intercalate "-" cs+  return $! f ver (lowercase name)+  where+    component = do+      cs <- Parse.munch1 Char.isAlphaNum+      if all Char.isDigit cs then Parse.pfail else return cs+      -- each component must contain an alphabetic character, to avoid+      -- ambiguity in identifiers like foo-1 (the 1 is the version number).+ instance Text TestType where   disp (TestTypeExe ver)          = text "exitcode-stdio-" <> disp ver   disp (TestTypeLib ver)          = text "detailed-"       <> disp ver   disp (TestTypeUnknown name ver) = text name <> char '-' <> disp ver -  parse = do-    cs   <- Parse.sepBy1 component (Parse.char '-')-    _    <- Parse.char '-'-    ver  <- parse-    let name = concat (intersperse "-" cs)-    return $! case lowercase name of-      "exitcode-stdio" -> TestTypeExe ver-      "detailed"       -> TestTypeLib ver-      _                -> TestTypeUnknown name ver+  parse = stdParse $ \ver name -> case name of+    "exitcode-stdio" -> TestTypeExe ver+    "detailed"       -> TestTypeLib ver+    _                -> TestTypeUnknown name ver -    where-      component = do-        cs <- Parse.munch1 Char.isAlphaNum-        if all Char.isDigit cs then Parse.pfail else return cs-        -- each component must contain an alphabetic character, to avoid-        -- ambiguity in identifiers like foo-1 (the 1 is the version number).  testType :: TestSuite -> TestType testType test = case testInterface test of@@ -528,7 +534,7 @@         benchmarkEnabled   :: Bool         -- TODO: See TODO for 'testEnabled'.     }-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  -- | The benchmark interfaces that are currently defined. Each -- benchmark must specify which interface it supports.@@ -550,7 +556,7 @@      -- interfaces for the given reason (e.g. unknown benchmark type).      --    | BenchmarkUnsupported BenchmarkType-   deriving (Eq, Read, Show)+   deriving (Eq, Read, Show, Typeable, Data)  instance Monoid Benchmark where     mempty = Benchmark {@@ -564,8 +570,7 @@         benchmarkName      = combine' benchmarkName,         benchmarkInterface = combine  benchmarkInterface,         benchmarkBuildInfo = combine  benchmarkBuildInfo,-        benchmarkEnabled   = if benchmarkEnabled a then True-                             else benchmarkEnabled b+        benchmarkEnabled   = benchmarkEnabled a || benchmarkEnabled b     }         where combine   field = field a `mappend` field b               combine' f = case (f a, f b) of@@ -605,7 +610,7 @@                      -- ^ \"type: exitcode-stdio-x.y\"                    | BenchmarkTypeUnknown String Version                      -- ^ Some unknown benchmark type e.g. \"type: foo\"-    deriving (Show, Read, Eq)+    deriving (Show, Read, Eq, Typeable, Data)  knownBenchmarkTypes :: [BenchmarkType] knownBenchmarkTypes = [ BenchmarkTypeExe (Version [1,0] []) ]@@ -614,21 +619,10 @@   disp (BenchmarkTypeExe ver)          = text "exitcode-stdio-" <> disp ver   disp (BenchmarkTypeUnknown name ver) = text name <> char '-' <> disp ver -  parse = do-    cs   <- Parse.sepBy1 component (Parse.char '-')-    _    <- Parse.char '-'-    ver  <- parse-    let name = concat (intersperse "-" cs)-    return $! case lowercase name of-      "exitcode-stdio" -> BenchmarkTypeExe ver-      _                -> BenchmarkTypeUnknown name ver+  parse = stdParse $ \ver name -> case name of+    "exitcode-stdio" -> BenchmarkTypeExe ver+    _                -> BenchmarkTypeUnknown name ver -    where-      component = do-        cs <- Parse.munch1 Char.isAlphaNum-        if all Char.isDigit cs then Parse.pfail else return cs-        -- each component must contain an alphabetic character, to avoid-        -- ambiguity in identifiers like foo-1 (the 1 is the version number).  benchmarkType :: Benchmark -> BenchmarkType benchmarkType benchmark = case benchmarkInterface benchmark of@@ -670,7 +664,7 @@                                                 -- simple assoc-list.         targetBuildDepends :: [Dependency] -- ^ Dependencies specific to a library or executable target     }-    deriving (Show,Read,Eq)+    deriving (Show,Read,Eq,Typeable,Data)  instance Monoid BuildInfo where   mempty = BuildInfo {@@ -844,7 +838,7 @@   -- given the default is \".\" ie no subdirectory.   repoSubdir   :: Maybe FilePath }-  deriving (Eq, Read, Show)+  deriving (Eq, Read, Show, Typeable, Data)  -- | What this repo info is for, what it represents. --@@ -860,7 +854,7 @@   | RepoThis    | RepoKindUnknown String-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Ord, Read, Show, Typeable, Data)  -- | An enumeration of common source control systems. The fields used in the -- 'SourceRepo' depend on the type of repo. The tools and methods used to@@ -869,7 +863,7 @@ data RepoType = Darcs | Git | SVN | CVS               | Mercurial | GnuArch | Bazaar | Monotone               | OtherRepoType String-  deriving (Eq, Ord, Read, Show)+  deriving (Eq, Ord, Read, Show, Typeable, Data)  knownRepoTypes :: [RepoType] knownRepoTypes = [Darcs, Git, SVN, CVS@@ -900,9 +894,7 @@  classifyRepoType :: String -> RepoType classifyRepoType s =-  case lookup (lowercase s) repoTypeMap of-    Just repoType' -> repoType'-    Nothing        -> OtherRepoType s+  fromMaybe (OtherRepoType s) $ lookup (lowercase s) repoTypeMap   where     repoTypeMap = [ (name, repoType')                   | repoType' <- knownRepoTypes@@ -954,7 +946,7 @@         condTestSuites     :: [(String, CondTree ConfVar [Dependency] TestSuite)],         condBenchmarks     :: [(String, CondTree ConfVar [Dependency] Benchmark)]       }-    deriving (Show, Eq, Typeable)+    deriving (Show, Eq, Typeable, Data)  instance Package GenericPackageDescription where   packageId = packageId . packageDescription@@ -969,11 +961,11 @@     , flagDefault     :: Bool     , flagManual      :: Bool     }-    deriving (Show, Eq)+    deriving (Show, Eq, Typeable, Data)  -- | A 'FlagName' is the name of a user-defined configuration flag newtype FlagName = FlagName String-    deriving (Eq, Ord, Show, Read)+    deriving (Eq, Ord, Show, Read, Typeable, Data)  -- | A 'FlagAssignment' is a total or partial mapping of 'FlagName's to -- 'Bool' flag values. It represents the flags chosen by the user or@@ -987,7 +979,7 @@              | Arch Arch              | Flag FlagName              | Impl CompilerFlavor VersionRange-    deriving (Eq, Show)+    deriving (Eq, Show, Typeable, Data)  --instance Text ConfVar where --    disp (OS os) = "os(" ++ display os ++ ")"@@ -1002,7 +994,7 @@                  | CNot (Condition c)                  | COr (Condition c) (Condition c)                  | CAnd (Condition c) (Condition c)-    deriving (Show, Eq)+    deriving (Show, Eq, Typeable, Data)  --instance Text c => Text (Condition c) where --  disp (Var x) = text (show x)@@ -1018,7 +1010,7 @@                               , CondTree v c a                               , Maybe (CondTree v c a))]     }-    deriving (Show, Eq)+    deriving (Show, Eq, Typeable, Data)  --instance (Text v, Text c) => Text (CondTree v c a) where --  disp (CondNode _dat cs ifs) =
cabal/Cabal/Distribution/PackageDescription/Check.hs view
@@ -70,7 +70,6 @@ import qualified System.Directory as System          ( doesFileExist, doesDirectoryExist ) -import Distribution.Package ( pkgName ) import Distribution.PackageDescription import Distribution.PackageDescription.Configuration          ( flattenPackageDescription, finalizePackageDescription )@@ -80,6 +79,8 @@          ( OS(..), Arch(..), buildPlatform ) import Distribution.License          ( License(..), knownLicenses )+import Distribution.Simple.CCompiler+         ( filenameCDialect ) import Distribution.Simple.Utils          ( cabalVersion, intercalate, parseFileGlob, FileGlob(..), lowercase ) @@ -92,7 +93,7 @@          , asVersionIntervals, UpperBound(..), isNoVersion ) import Distribution.Package          ( PackageName(PackageName), packageName, packageVersion-         , Dependency(..) )+         , Dependency(..), pkgName )  import Distribution.Text          ( display, disp )@@ -138,6 +139,7 @@        -- quite legitimately refuse to publicly distribute packages with these        -- problems.      | PackageDistInexcusable { explanation :: String }+  deriving (Eq)  instance Show PackageCheck where     show notice = explanation notice@@ -146,6 +148,12 @@ check False _  = Nothing check True  pc = Just pc +checkSpecVersion :: PackageDescription -> [Int] -> Bool -> PackageCheck -> Maybe PackageCheck+checkSpecVersion pkg specver cond pc+  | specVersion pkg >= Version specver [] = Nothing+  | otherwise                             = check cond pc++ -- ------------------------------------------------------------ -- * Standard checks -- ------------------------------------------------------------@@ -171,7 +179,7 @@     pkg = fromMaybe (flattenPackageDescription gpkg) mpkg  --TODO: make this variant go away---      we should alwaws know the GenericPackageDescription+--      we should always know the GenericPackageDescription checkConfiguredPackage :: PackageDescription -> [PackageCheck] checkConfiguredPackage pkg =     checkSanity pkg@@ -212,10 +220,10 @@   ]   --TODO: check for name clashes case insensitively: windows file systems cannot cope. -  ++ maybe []  checkLibrary    (library pkg)-  ++ concatMap checkExecutable (executables pkg)-  ++ concatMap (checkTestSuite pkg) (testSuites pkg)-  ++ concatMap (checkBenchmark pkg) (benchmarks pkg)+  ++ maybe []  (checkLibrary    pkg) (library pkg)+  ++ concatMap (checkExecutable pkg) (executables pkg)+  ++ concatMap (checkTestSuite  pkg) (testSuites pkg)+  ++ concatMap (checkBenchmark  pkg) (benchmarks pkg)    ++ catMaybes [ @@ -231,12 +239,12 @@     bmNames = map benchmarkName $ benchmarks pkg     duplicateNames = dups $ exeNames ++ testNames ++ bmNames -checkLibrary :: Library -> [PackageCheck]-checkLibrary lib =+checkLibrary :: PackageDescription -> Library -> [PackageCheck]+checkLibrary _pkg lib =   catMaybes [      check (not (null moduleDuplicates)) $-       PackageBuildWarning $+       PackageBuildImpossible $             "Duplicate modules in library: "          ++ commaSep (map display moduleDuplicates)   ]@@ -244,22 +252,30 @@   where     moduleDuplicates = dups (libModules lib) -checkExecutable :: Executable -> [PackageCheck]-checkExecutable exe =+checkExecutable :: PackageDescription -> Executable -> [PackageCheck]+checkExecutable pkg exe =   catMaybes [      check (null (modulePath exe)) $       PackageBuildImpossible $-        "No 'Main-Is' field found for executable " ++ exeName exe+        "No 'main-is' field found for executable " ++ exeName exe    , check (not (null (modulePath exe))-       && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $+       && (not $ fileExtensionSupportedLanguage $ modulePath exe)) $       PackageBuildImpossible $-           "The 'Main-Is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."+           "The 'main-is' field must specify a '.hs' or '.lhs' file "+        ++ "(even if it is generated by a preprocessor), "+        ++ "or it may specify a C/C++/obj-C source file." +  , checkSpecVersion pkg [1,17]+          (fileExtensionSupportedLanguage (modulePath exe)+        && takeExtension (modulePath exe) `notElem` [".hs", ".lhs"]) $+      PackageDistInexcusable $+           "The package uses a C/C++/obj-C source file for the 'main-is' field. "+        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."+   , check (not (null moduleDuplicates)) $-       PackageBuildWarning $+       PackageBuildImpossible $             "Duplicate modules in executable '" ++ exeName exe ++ "': "          ++ commaSep (map display moduleDuplicates)   ]@@ -285,15 +301,21 @@       _ -> Nothing    , check (not $ null moduleDuplicates) $-      PackageBuildWarning $+      PackageBuildImpossible $            "Duplicate modules in test suite '" ++ testName test ++ "': "         ++ commaSep (map display moduleDuplicates)    , check mainIsWrongExt $       PackageBuildImpossible $            "The 'main-is' field must specify a '.hs' or '.lhs' file "-        ++ "(even if it is generated by a preprocessor)."+        ++ "(even if it is generated by a preprocessor), "+        ++ "or it may specify a C/C++/obj-C source file." +  , checkSpecVersion pkg [1,17] (mainIsNotHsExt && not mainIsWrongExt) $+      PackageDistInexcusable $+           "The package uses a C/C++/obj-C source file for the 'main-is' field. "+        ++ "To use this feature you must specify 'cabal-version: >= 1.18'."+     -- Test suites might be built as (internal) libraries named after     -- the test suite and thus their names must not clash with the     -- name of the package.@@ -306,6 +328,10 @@     moduleDuplicates = dups $ testModules test      mainIsWrongExt = case testInterface test of+      TestSuiteExeV10 _ f -> not $ fileExtensionSupportedLanguage f+      _                   -> False++    mainIsNotHsExt = case testInterface test of       TestSuiteExeV10 _ f -> takeExtension f `notElem` [".hs", ".lhs"]       _                   -> False @@ -333,7 +359,7 @@       _ -> Nothing    , check (not $ null moduleDuplicates) $-      PackageBuildWarning $+      PackageBuildImpossible $            "Duplicate modules in benchmark '" ++ benchmarkName bm ++ "': "         ++ commaSep (map display moduleDuplicates) @@ -412,7 +438,7 @@       PackageDistSuspicious $            "Deprecated extensions: "         ++ commaSep (map (quote . display . fst) deprecatedExtensions)-        ++ ". " ++ intercalate " "+        ++ ". " ++ unwords              [ "Instead of '" ++ display ext             ++ "' use '" ++ display replacement ++ "'."              | (ext, Just replacement) <- deprecatedExtensions ]@@ -424,7 +450,7 @@       PackageDistSuspicious "No 'maintainer' field."    , check (null (synopsis pkg) && null (description pkg)) $-      PackageDistInexcusable $ "No 'synopsis' or 'description' field."+      PackageDistInexcusable "No 'synopsis' or 'description' field."    , check (null (description pkg) && not (null (synopsis pkg))) $       PackageDistSuspicious "No 'description' field."@@ -517,6 +543,9 @@     unknownLicenseVersion (LGPL (Just v))       | v `notElem` knownVersions = Just knownVersions       where knownVersions = [ v' | LGPL (Just v') <- knownLicenses ]+    unknownLicenseVersion (AGPL (Just v))+      | v `notElem` knownVersions = Just knownVersions+      where knownVersions = [ v' | AGPL (Just v') <- knownLicenses ]     unknownLicenseVersion (Apache  (Just v))       | v `notElem` knownVersions = Just knownVersions       where knownVersions = [ v' | Apache  (Just v') <- knownLicenses ]@@ -532,19 +561,19 @@                    ++ "The repo kind is usually 'head' or 'this'"       _ -> Nothing -  , check (repoType repo == Nothing) $+  , check (isNothing (repoType repo)) $       PackageDistInexcusable         "The source-repository 'type' is a required field." -  , check (repoLocation repo == Nothing) $+  , check (isNothing (repoLocation repo)) $       PackageDistInexcusable         "The source-repository 'location' is a required field." -  , check (repoType repo == Just CVS && repoModule repo == Nothing) $+  , check (repoType repo == Just CVS && isNothing (repoModule repo)) $       PackageDistInexcusable         "For a CVS source-repository, the 'module' is a required field." -  , check (repoKind repo == RepoThis && repoTag repo == Nothing) $+  , check (repoKind repo == RepoThis && isNothing (repoTag repo)) $       PackageDistInexcusable $            "For the 'this' kind of source-repository, the 'tag' is a required "         ++ "field. It should specify the tag corresponding to this version "@@ -825,6 +854,7 @@     relPaths =          [ (path, "extra-src-files") | path <- extraSrcFiles pkg ]       ++ [ (path, "extra-tmp-files") | path <- extraTmpFiles pkg ]+      ++ [ (path, "extra-doc-files") | path <- extraDocFiles pkg ]       ++ [ (path, "data-files")      | path <- dataFiles     pkg ]       ++ [ (path, "data-dir")        | path <- [dataDir      pkg]]       ++ concat@@ -1092,7 +1122,7 @@         (\v v' -> intersectVersionRanges (orLaterVersion v) (earlierVersion v'))         intersectVersionRanges unionVersionRanges id -    compatLicenses = [ GPL Nothing, LGPL Nothing, BSD3, BSD4+    compatLicenses = [ GPL Nothing, LGPL Nothing, AGPL Nothing, BSD3, BSD4                      , PublicDomain, AllRightsReserved, OtherLicense ]      mentionedExtensions = [ ext | bi <- allBuildInfo pkg@@ -1199,7 +1229,7 @@   ]   where     -- TODO: What we really want to do is test if there exists any-    -- configuration in which the base version is unboudned above.+    -- configuration in which the base version is unbounded above.     -- However that's a bit tricky because there are many possible     -- configurations. As a cheap easy and safe approximation we will     -- pick a single "typical" configuration and check if that has an@@ -1493,3 +1523,11 @@  dups :: Ord a => [a] -> [a] dups xs = [ x | (x:_:_) <- group (sort xs) ]++fileExtensionSupportedLanguage :: FilePath -> Bool+fileExtensionSupportedLanguage path =+    isHaskell || isC+  where+    extension = takeExtension path+    isHaskell = extension `elem` [".hs", ".lhs"]+    isC       = isJust (filenameCDialect extension)
cabal/Cabal/Distribution/PackageDescription/Configuration.hs view
@@ -1,13 +1,8 @@-{-# OPTIONS -cpp #-}--- OPTIONS required for ghc-6.4.x compat, and must appear first-{-# LANGUAGE CPP #-} -- -fno-warn-deprecations for use of Map.foldWithKey-{-# OPTIONS_GHC -cpp -fno-warn-deprecations #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}+{-# OPTIONS_GHC -fno-warn-deprecations #-} ----------------------------------------------------------------------------- -- |--- Module      :  Distribution.Configuration+-- Module      :  Distribution.PackageDescription.Configuration -- Copyright   :  Thomas Schilling, 2007 -- -- Maintainer  :  cabal-devel@haskell.org@@ -70,6 +65,8 @@          , Flag(..), FlagName(..), FlagAssignment          , Benchmark(..), CondTree(..), ConfVar(..), Condition(..)          , TestSuite(..) )+import Distribution.PackageDescription.Utils+         ( cabalBug, userBug ) import Distribution.Version          ( VersionRange, anyVersion, intersectVersionRanges, withinRange ) import Distribution.Compiler@@ -91,11 +88,6 @@ import qualified Data.Map as Map import Data.Monoid -#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ < 606)-import qualified Text.Read as R-import qualified Text.Read.Lex as L-#endif- ------------------------------------------------------------------------------  -- | Simplify the condition and return its free variables.@@ -220,7 +212,7 @@ data BT a = BTN a | BTB (BT a) (BT a)  -- very simple binary tree  --- | Try to find a flag assignment that satisfies the constaints of all trees.+-- | Try to find a flag assignment that satisfies the constraints of all trees. -- -- Returns either the missing dependencies, or a tuple containing the -- resulting data, the associated dependencies, and the chosen flag@@ -315,35 +307,8 @@ -- | A map of dependencies.  Newtyped since the default monoid instance is not --   appropriate.  The monoid instance uses 'intersectVersionRanges'. newtype DependencyMap = DependencyMap { unDependencyMap :: Map PackageName VersionRange }-#if !defined(__GLASGOW_HASKELL__) || (__GLASGOW_HASKELL__ >= 606)   deriving (Show, Read)-#else--- The Show/Read instance for Data.Map in ghc-6.4 is useless--- so we have to re-implement it here:-instance Show DependencyMap where-  showsPrec d (DependencyMap m) =-      showParen (d > 10) (showString "DependencyMap" . shows (M.toList m)) -instance Read DependencyMap where-  readPrec = parens $ R.prec 10 $ do-    R.Ident "DependencyMap" <- R.lexP-    xs <- R.readPrec-    return (DependencyMap (M.fromList xs))-      where parens :: R.ReadPrec a -> R.ReadPrec a-            parens p = optional-             where-               optional  = p R.+++ mandatory-               mandatory = paren optional--            paren :: R.ReadPrec a -> R.ReadPrec a-            paren p = do L.Punc "(" <- R.lexP-                         x          <- R.reset p-                         L.Punc ")" <- R.lexP-                         return x--  readListPrec = R.readListPrecDefault-#endif- instance Monoid DependencyMap where     mempty = DependencyMap Map.empty     (DependencyMap a) `mappend` (DependencyMap b) =@@ -361,7 +326,7 @@                  -> CondTree v d a                  -> (d, a) simplifyCondTree env (CondNode a d ifs) =-    foldr mappend (d, a) $ catMaybes $ map simplifyIf ifs+    mconcat $ (d, a) : catMaybes (map simplifyIf ifs)   where     simplifyIf (cnd, t, me) =         case simplifyCondition cnd env of@@ -431,7 +396,7 @@         , [(String, Benchmark)]) flattenTaggedTargets (TargetSet targets) = foldr untag (Nothing, [], [], []) targets   where-    untag (_, Lib _) (Just _, _, _, _) = bug "Only one library expected"+    untag (_, Lib _) (Just _, _, _, _) = userBug "Only one library expected"     untag (deps, Lib l) (Nothing, exes, tests, bms) =         (Just l', exes, tests, bms)       where@@ -439,29 +404,38 @@                 libBuildInfo = (libBuildInfo l) { targetBuildDepends = fromDepMap deps }             }     untag (deps, Exe n e) (mlib, exes, tests, bms)-        | any ((== n) . fst) exes = bug "Exe with same name found"-        | any ((== n) . fst) tests = bug "Test sharing name of exe found"-        | any ((== n) . fst) bms = bug "Benchmark sharing name of exe found"-        | otherwise = (mlib, exes ++ [(n, e')], tests, bms)+        | any ((== n) . fst) exes =+          userBug $ "There exist several exes with the same name: '" ++ n ++ "'"+        | any ((== n) . fst) tests =+          userBug $ "There exists a test with the same name as an exe: '" ++ n ++ "'"+        | any ((== n) . fst) bms =+          userBug $ "There exists a benchmark with the same name as an exe: '" ++ n ++ "'"+        | otherwise = (mlib, (n, e'):exes, tests, bms)       where         e' = e {                 buildInfo = (buildInfo e) { targetBuildDepends = fromDepMap deps }             }     untag (deps, Test n t) (mlib, exes, tests, bms)-        | any ((== n) . fst) tests = bug "Test with same name found"-        | any ((== n) . fst) exes = bug "Test sharing name of exe found"-        | any ((== n) . fst) bms = bug "Test sharing name of benchmark found"-        | otherwise = (mlib, exes, tests ++ [(n, t')], bms)+        | any ((== n) . fst) tests =+          userBug $ "There exist several tests with the same name: '" ++ n ++ "'"+        | any ((== n) . fst) exes =+          userBug $ "There exists an exe with the same name as the test: '" ++ n ++ "'"+        | any ((== n) . fst) bms =+          userBug $ "There exists a benchmark with the same name as the test: '" ++ n ++ "'"+        | otherwise = (mlib, exes, (n, t'):tests, bms)       where         t' = t {             testBuildInfo = (testBuildInfo t)                 { targetBuildDepends = fromDepMap deps }             }     untag (deps, Bench n b) (mlib, exes, tests, bms)-        | any ((== n) . fst) bms = bug "Benchmark with same name found"-        | any ((== n) . fst) exes = bug "Benchmark sharing name of exe found"-        | any ((== n) . fst) tests = bug "Benchmark sharing name of test found"-        | otherwise = (mlib, exes, tests, bms ++ [(n, b')])+        | any ((== n) . fst) bms =+          userBug $ "There exist several benchmarks with the same name: '" ++ n ++ "'"+        | any ((== n) . fst) exes =+          userBug $ "There exists an exe with the same name as the benchmark: '" ++ n ++ "'"+        | any ((== n) . fst) tests =+          userBug $ "There exists a test with the same name as the benchmark: '" ++ n ++ "'"+        | otherwise = (mlib, exes, tests, (n, b'):bms)       where         b' = b {             benchmarkBuildInfo = (benchmarkBuildInfo b)@@ -489,7 +463,7 @@     Exe n e `mappend` Exe n' e' | n == n' = Exe n (e `mappend` e')     Test n t `mappend` Test n' t' | n == n' = Test n (t `mappend` t')     Bench n b `mappend` Bench n' b' | n == n' = Bench n (b `mappend` b')-    _ `mappend` _ = bug "Cannot combine incompatible tags"+    _ `mappend` _ = cabalBug "Cannot combine incompatible tags"  -- | Create a package description with all configurations resolved. --@@ -514,8 +488,9 @@ -- finalizePackageDescription ::      FlagAssignment  -- ^ Explicitly specified flag assignments-  -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of available packages?-                          -- If this is unknown then use True.+  -> (Dependency -> Bool) -- ^ Is a given depenency satisfiable from the set of+                          -- available packages?  If this is unknown then use+                          -- True.   -> Platform      -- ^ The 'Arch' and 'OS'   -> CompilerId    -- ^ Compiler + Version   -> [Dependency]  -- ^ Additional constraints@@ -524,7 +499,8 @@             (PackageDescription, FlagAssignment)              -- ^ Either missing dependencies or the resolved package              -- description along with the flag assignments chosen.-finalizePackageDescription userflags satisfyDep (Platform arch os) impl constraints+finalizePackageDescription userflags satisfyDep+        (Platform arch os) impl constraints         (GenericPackageDescription pkg flags mlib0 exes0 tests0 bms0) =     case resolveFlags of       Right ((mlib, exes', tests', bms'), targetSet, flagVals) ->@@ -566,9 +542,10 @@                       | manual -> [b]                       | otherwise -> [b, not b]     --flagDefaults = map (\(n,x:_) -> (n,x)) flagChoices-    check ds     = if all satisfyDep ds-                   then DepOk-                   else MissingDeps $ filter (not . satisfyDep) ds+    check ds     = let missingDeps = filter (not . satisfyDep) ds+                   in if null missingDeps+                      then DepOk+                      else MissingDeps missingDeps  {- let tst_p = (CondNode [1::Int] [Distribution.Package.Dependency "a" AnyVersion] [])@@ -647,6 +624,3 @@     if null (hsSourceDirs bi)     then bi { hsSourceDirs = [currentDir] }     else bi--bug :: String -> a-bug msg = error $ msg ++ ". Consider this a bug."
cabal/Cabal/Distribution/PackageDescription/Parse.hs view
@@ -72,7 +72,9 @@ import Data.Maybe (listToMaybe, isJust) import Data.Monoid ( Monoid(..) ) import Data.List  (nub, unfoldr, partition, (\\))-import Control.Monad (liftM, foldM, when, unless)+import Control.Monad (liftM, foldM, when, unless, ap)+import Control.Applicative (Applicative(..))+import Control.Arrow (first) import System.Directory (doesFileExist) import qualified Data.ByteString.Lazy.Char8 as BS.Char8 @@ -84,6 +86,8 @@  import Distribution.ParseUtils hiding (parseFields) import Distribution.PackageDescription+import Distribution.PackageDescription.Utils+         ( cabalBug, userBug ) import Distribution.Package          ( PackageIdentifier(..), Dependency(..), packageName, packageVersion ) import Distribution.ModuleName ( ModuleName )@@ -170,13 +174,17 @@  , listField "extra-tmp-files"            showFilePath       parseFilePathQ            extraTmpFiles          (\val pkg -> pkg{extraTmpFiles=val})+ , listField "extra-doc-files"+           showFilePath    parseFilePathQ+           extraDocFiles          (\val pkg -> pkg{extraDocFiles=val})  ]  -- | Store any fields beginning with "x-" in the customFields field of --   a PackageDescription.  All other fields will generate a warning. storeXFieldsPD :: UnrecFieldParser PackageDescription-storeXFieldsPD (f@('x':'-':_),val) pkg = Just pkg{ customFieldsPD =-                                                        (customFieldsPD pkg) ++ [(f,val)]}+storeXFieldsPD (f@('x':'-':_),val) pkg =+  Just pkg{ customFieldsPD =+               customFieldsPD pkg ++ [(f,val)]} storeXFieldsPD _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -194,7 +202,8 @@  storeXFieldsLib :: UnrecFieldParser Library storeXFieldsLib (f@('x':'-':_), val) l@(Library { libBuildInfo = bi }) =-    Just $ l {libBuildInfo = bi{ customFieldsBI = (customFieldsBI bi) ++ [(f,val)]}}+    Just $ l {libBuildInfo =+                 bi{ customFieldsBI = customFieldsBI bi ++ [(f,val)]}} storeXFieldsLib _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -217,7 +226,7 @@  storeXFieldsExe :: UnrecFieldParser Executable storeXFieldsExe (f@('x':'-':_), val) e@(Executable { buildInfo = bi }) =-    Just $ e {buildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+    Just $ e {buildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsExe _ _ = Nothing  -- ---------------------------------------------------------------------------@@ -254,7 +263,7 @@  storeXFieldsTest :: UnrecFieldParser TestSuiteStanza storeXFieldsTest (f@('x':'-':_), val) t@(TestSuiteStanza { testStanzaBuildInfo = bi }) =-    Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+    Just $ t {testStanzaBuildInfo = bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsTest _ _ = Nothing  validateTestSuite :: LineNo -> TestSuiteStanza -> ParseResult TestSuite@@ -340,7 +349,7 @@ storeXFieldsBenchmark (f@('x':'-':_), val)     t@(BenchmarkStanza { benchmarkStanzaBuildInfo = bi }) =         Just $ t {benchmarkStanzaBuildInfo =-                       bi{ customFieldsBI = (f,val):(customFieldsBI bi)}}+                       bi{ customFieldsBI = (f,val):customFieldsBI bi}} storeXFieldsBenchmark _ _ = Nothing  validateBenchmark :: LineNo -> BenchmarkStanza -> ParseResult Benchmark@@ -463,7 +472,7 @@  ]  storeXFieldsBI :: UnrecFieldParser BuildInfo-storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):(customFieldsBI bi) }+storeXFieldsBI (f@('x':'-':_),val) bi = Just bi{ customFieldsBI = (f,val):customFieldsBI bi } storeXFieldsBI _ _ = Nothing  ------------------------------------------------------------------------------@@ -514,7 +523,8 @@                  -> FilePath -> IO a readAndParseFile withFileContents' parser verbosity fpath = do   exists <- doesFileExist fpath-  when (not exists) (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")+  unless exists+    (die $ "Error Parsing: file \"" ++ fpath ++ "\" doesn't exist. Cannot continue.")   withFileContents' fpath $ \str -> case parser str of     ParseFailed e -> do         let (line, message) = locatedErrorMsg e@@ -547,9 +557,9 @@  mapSimpleFields :: (Field -> ParseResult Field) -> [Field]                 -> ParseResult [Field]-mapSimpleFields f fs = mapM walk fs+mapSimpleFields f = mapM walk   where-    walk fld@(F _ _ _) = f fld+    walk fld@F{} = f fld     walk (IfBlock l c fs1 fs2) = do       fs1' <- mapM walk fs1       fs2' <- mapM walk fs2@@ -572,7 +582,7 @@ parseConstraint :: Field -> ParseResult [Dependency] parseConstraint (F l n v)     | n == "build-depends" = runP l n (parseCommaList parse) v-parseConstraint f = bug $ "Constraint was expected (got: " ++ show f ++ ")"+parseConstraint f = userBug $ "Constraint was expected (got: " ++ show f ++ ")"  {- headerFieldNames :: [String]@@ -596,6 +606,13 @@ -- on the 'mtl' package. newtype StT s m a = StT { runStT :: s -> m (a,s) } +instance Functor f => Functor (StT s f) where+    fmap g (StT f) = StT $ fmap (first g)  . f++instance (Monad m, Functor m) => Applicative (StT s m) where+    pure = return+    (<*>) = ap+ instance Monad m => Monad (StT s m) where     return a = StT (\s -> return (a,s))     StT f >>= g = StT $ \s -> do@@ -612,7 +629,7 @@ lift m = StT $ \s -> m >>= \a -> return (a,s)  evalStT :: Monad m => StT s m a -> s -> m a-evalStT st s = runStT st s >>= return . fst+evalStT st s = liftM fst $ runStT st s  -- Our monad for parsing a list/tree of fields. --@@ -623,7 +640,7 @@  -- return look-ahead field or nothing if we're at the end of the file peekField :: PM (Maybe Field)-peekField = get >>= return . listToMaybe+peekField = liftM listToMaybe get  -- Unconditionally discard the first field in our state.  Will error when it -- reaches end of file.  (Yes, that's evil.)@@ -711,7 +728,7 @@                    flags mlib exes tests bms    where-    oldSyntax flds = all isSimpleField flds+    oldSyntax = all isSimpleField     reportTabsError tabs =         syntaxError (fst (head tabs)) $           "Do not use tabs for indentation (use spaces instead)\n"@@ -781,7 +798,7 @@               | e == "executable" =                   let (efs, r') = break ((=="executable") . fName) r                   in Just (Section l "executable" n (deps ++ efs), r')-            toExe _ = bug "unexpeced input to 'toExe'"+            toExe _ = cabalBug "unexpected input to 'toExe'"           in             hdr ++            (if null libfs then []@@ -789,7 +806,7 @@             ++ exes       | otherwise = fs -    isSimpleField (F _ _ _) = True+    isSimpleField F{} = True     isSimpleField _ = False      -- warn if there's something at the end of the file@@ -804,7 +821,7 @@     -- fields     getHeader :: [Field] -> PM [Field]     getHeader acc = peekField >>= \mf -> case mf of-        Just f@(F _ _ _) -> skipField >> getHeader (f:acc)+        Just f@F{} -> skipField >> getHeader (f:acc)         _ -> return (reverse acc)      --@@ -863,7 +880,7 @@                     -- only one need one to specify a type because the                     -- configure step uses 'mappend' to join together the                     -- results of flag resolution.-                    in hasTestType || (any checkComponent components)+                    in hasTestType || any checkComponent components             if checkTestType emptyTestSuite flds                 then do                     skipField@@ -911,7 +928,7 @@                     -- only one need one to specify a type because the                     -- configure step uses 'mappend' to join together the                     -- results of flag resolution.-                    in hasBenchmarkType || (any checkComponent components)+                    in hasBenchmarkType || any checkComponent components             if checkBenchmarkType emptyBenchmark flds                 then do                     skipField@@ -925,7 +942,7 @@                       ++ intercalate ", " (map display knownBenchmarkTypes)          | sec_type == "library" -> do-            when (not (null sec_label)) $ lift $+            unless (null sec_label) $ lift $               syntaxError line_no "'library' expects no argument"             flds <- collectFields parseLibFields sec_fields             skipField@@ -957,7 +974,7 @@             repo <- lift $ parseFields                     sourceRepoFieldDescrs                     warnUnrec-                    (SourceRepo {+                    SourceRepo {                       repoKind     = kind,                       repoType     = Nothing,                       repoLocation = Nothing,@@ -965,7 +982,7 @@                       repoBranch   = Nothing,                       repoTag      = Nothing,                       repoSubdir   = Nothing-                    })+                    }                     sec_fields             skipField             (repos, flags, lib, exes, tests, bms) <- getBody@@ -975,11 +992,16 @@             lift $ warning $ "Ignoring unknown section type: " ++ sec_type             skipField             getBody-      Just f -> do+      Just f@(F {}) -> do             _ <- lift $ syntaxError (lineNo f) $-              "Construct not supported at this position: " ++ show f+              "Plain fields are not allowed in between stanzas: " ++ show f             skipField             getBody+      Just f@(IfBlock {}) -> do+            _ <- lift $ syntaxError (lineNo f) $+              "If-blocks are not allowed in between stanzas: " ++ show f+            skipField+            getBody       Nothing -> return ([], [], Nothing, [], [], [])      -- Extracts all fields in a block and returns a 'CondTree'.@@ -991,7 +1013,7 @@     collectFields parser allflds = do          let simplFlds = [ F l n v | F l n v <- allflds ]-            condFlds = [ f | f@(IfBlock _ _ _ _) <- allflds ]+            condFlds = [ f | f@IfBlock{} <- allflds ]          let (depFlds, dataFlds) = partition isConstraint simplFlds @@ -1013,14 +1035,15 @@                    es -> do fs <- collectFields parser es                             return (Just fs)             return (cnd, t', e')-        processIfs _ = bug "processIfs called with wrong field type"+        processIfs _ = cabalBug "processIfs called with wrong field type"      parseLibFields :: [Field] -> PM Library     parseLibFields = lift . parseFields libFieldDescrs storeXFieldsLib emptyLibrary      -- Note: we don't parse the "executable" field here, hence the tail hack.     parseExeFields :: [Field] -> PM Executable-    parseExeFields = lift . parseFields (tail executableFieldDescrs) storeXFieldsExe emptyExecutable+    parseExeFields = lift . parseFields (tail executableFieldDescrs)+                                        storeXFieldsExe emptyExecutable      parseTestFields :: LineNo -> [Field] -> PM TestSuite     parseTestFields line fields = do@@ -1049,7 +1072,7 @@     checkCondTreeFlags :: [FlagName] -> CondTree ConfVar c a -> PM ()     checkCondTreeFlags definedFlags ct = do         let fv = nub $ freeVars ct-        when (not . all (`elem` definedFlags) $ fv) $+        unless (all (`elem` definedFlags) fv) $             fail $ "These flags are used without having been defined: "                 ++ intercalate ", " [ n | FlagName n <- fv \\ definedFlags ] @@ -1067,14 +1090,13 @@             -> ParseResult a parseFields descrs unrec ini fields =     do (a, unknowns) <- foldM (parseField descrs unrec) (ini, []) fields-       when (not (null unknowns)) $ do-         warning $ render $-           text "Unknown fields:" <+>-                commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")-                              (reverse unknowns))-           $+$-           text "Fields allowed in this section:" $$-             nest 4 (commaSep $ map fieldName descrs)+       unless (null unknowns) $ warning $ render $+         text "Unknown fields:" <+>+              commaSep (map (\(l,u) -> u ++ " (line " ++ show l ++ ")")+                            (reverse unknowns))+         $+$+         text "Fields allowed in this section:" $$+           nest 4 (commaSep $ map fieldName descrs)        return a   where     commaSep = fsep . punctuate comma . map text@@ -1085,14 +1107,14 @@            -> (a,[(Int,String)]) -- ^ accumulated result and warnings            -> Field              -- ^ the field to be parsed            -> ParseResult (a, [(Int,String)])-parseField ((FieldDescr name _ parser):fields) unrec (a, us) (F line f val)+parseField (FieldDescr name _ parser : fields) unrec (a, us) (F line f val)   | name == f = parser line val a >>= \a' -> return (a',us)   | otherwise = parseField fields unrec (a,us) (F line f val) parseField [] unrec (a,us) (F l f val) = return $   case unrec (f,val) a of        -- no fields matched, see if the 'unrec'     Just a' -> (a',us)           -- function wants to do anything with it-    Nothing -> (a, ((l,f):us))-parseField _ _ _ _ = bug "'parseField' called on a non-field"+    Nothing -> (a, (l,f):us)+parseField _ _ _ _ = cabalBug "'parseField' called on a non-field"  deprecatedFields :: [(String,String)] deprecatedFields =@@ -1114,7 +1136,7 @@                       ++ "\" is deprecated, please use \"" ++ newName ++ "\""               return newName   return (F line fld' val)-deprecField _ = bug "'deprecField' called on a non-field"+deprecField _ = cabalBug "'deprecField' called on a non-field"   parseHookedBuildInfo :: String -> ParseResult HookedBuildInfo@@ -1126,17 +1148,17 @@   return (mLib, biExes)   where     parseLib :: [Field] -> ParseResult (Maybe BuildInfo)-    parseLib (bi@((F _ inFieldName _):_))+    parseLib (bi@(F _ inFieldName _:_))         | lowercase inFieldName /= "executable" = liftM Just (parseBI bi)     parseLib _ = return Nothing      parseExe :: [Field] -> ParseResult (String, BuildInfo)-    parseExe ((F line inFieldName mName):bi)+    parseExe (F line inFieldName mName:bi)         | lowercase inFieldName == "executable"             = do bis <- parseBI bi                  return (mName, bis)         | otherwise = syntaxError line "expecting 'executable' at top of stanza"-    parseExe (_:_) = bug "`parseExe' called on a non-field"+    parseExe (_:_) = cabalBug "`parseExe' called on a non-field"     parseExe [] = syntaxError 0 "error in parsing buildinfo file. Expected executable stanza"      parseBI st = parseFields binfoFieldDescrs storeXFieldsBI emptyBuildInfo st@@ -1200,6 +1222,3 @@  --test_findIndentTabs = findIndentTabs $ unlines $ --    [ "foo", "  bar", " \t baz", "\t  biz\t", "\t\t \t mib" ]--bug :: String -> a-bug msg = error $ msg ++ ". Consider this a bug."
cabal/Cabal/Distribution/PackageDescription/PrettyPrint.hs view
@@ -46,8 +46,10 @@     showGenericPackageDescription, ) where +import Data.Monoid (Monoid(mempty)) import Distribution.PackageDescription-       ( TestSuite(..), TestSuiteInterface(..), testType+       ( Benchmark(..), BenchmarkInterface(..), benchmarkType+       , TestSuite(..), TestSuiteInterface(..), testType        , SourceRepo(..),         customFieldsBI, CondTree(..), Condition(..),         FlagName(..), ConfVar(..), Executable(..), Library(..),@@ -86,6 +88,7 @@         $+$ ppLibrary (condLibrary gpd)         $+$ ppExecutables (condExecutables gpd)         $+$ ppTestSuites (condTestSuites gpd)+        $+$ ppBenchmarks (condBenchmarks gpd)  ppPackageDescription :: PackageDescription -> Doc ppPackageDescription pd                  =      ppFields pkgDescrFieldDescrs pd@@ -169,13 +172,17 @@                      | (n,condTree) <- suites]   where     ppTestSuite testsuite Nothing =-                text "type:" <+> disp (testType testsuite)+                maybe empty (\t -> text "type:"        <+> disp t)+                            maybeTestType             $+$ maybe empty (\f -> text "main-is:"     <+> text f)                             (testSuiteMainIs testsuite)             $+$ maybe empty (\m -> text "test-module:" <+> disp m)                             (testSuiteModule testsuite)             $+$ ppFields binfoFieldDescrs (testBuildInfo testsuite)             $+$ ppCustomFields (customFieldsBI (testBuildInfo testsuite))+      where+        maybeTestType | testInterface testsuite == mempty = Nothing+                      | otherwise = Just (testType testsuite)      ppTestSuite (TestSuite _ _ buildInfo' _)                     (Just (TestSuite _ _ buildInfo2 _)) =@@ -188,6 +195,32 @@      testSuiteModule test = case testInterface test of       TestSuiteLibV09 _ m -> Just m+      _                   -> Nothing++ppBenchmarks :: [(String, CondTree ConfVar [Dependency] Benchmark)] -> Doc+ppBenchmarks suites =+    emptyLine $ vcat [     text ("benchmark " ++ n)+                       $+$ nest indentWith (ppCondTree condTree Nothing ppBenchmark)+                     | (n,condTree) <- suites]+  where+    ppBenchmark benchmark Nothing =+                maybe empty (\t -> text "type:"        <+> disp t)+                            maybeBenchmarkType+            $+$ maybe empty (\f -> text "main-is:"     <+> text f)+                            (benchmarkMainIs benchmark)+            $+$ ppFields binfoFieldDescrs (benchmarkBuildInfo benchmark)+            $+$ ppCustomFields (customFieldsBI (benchmarkBuildInfo benchmark))+      where+        maybeBenchmarkType | benchmarkInterface benchmark == mempty = Nothing+                           | otherwise = Just (benchmarkType benchmark)++    ppBenchmark (Benchmark _ _ buildInfo' _)+                    (Just (Benchmark _ _ buildInfo2 _)) =+            ppDiffFields binfoFieldDescrs buildInfo' buildInfo2+            $+$ ppCustomFields (customFieldsBI buildInfo')++    benchmarkMainIs benchmark = case benchmarkInterface benchmark of+      BenchmarkExeV10 _ f -> Just f       _                   -> Nothing  ppCondition :: Condition ConfVar -> Doc
+ cabal/Cabal/Distribution/PackageDescription/Utils.hs view
@@ -0,0 +1,23 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.PackageDescription.Utils+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Common utils used by modules under Distribution.PackageDescription.*.++module Distribution.PackageDescription.Utils (+  cabalBug, userBug+  ) where++-- ----------------------------------------------------------------------------+-- Exception and logging utils++userBug :: String -> a+userBug msg = error $ msg ++ ". This is a bug in your .cabal file."++cabalBug :: String -> a+cabalBug msg = error $ msg ++ ". This is possibly a bug in Cabal.\n"+               ++ "Please report it to the developers: "+               ++ "https://github.com/haskell/cabal/issues/new"
cabal/Cabal/Distribution/ParseUtils.hs view
@@ -47,13 +47,14 @@  -- This module is meant to be local-only to Distribution... --- #hide+{-# OPTIONS_HADDOCK hide #-} module Distribution.ParseUtils (         LineNo, PError(..), PWarning(..), locatedErrorMsg, syntaxError, warning,         runP, runE, ParseResult(..), catchParseError, parseFail, showPWarning,         Field(..), fName, lineNo,         FieldDescr(..), ppField, ppFields, readFields, readFieldsFlat,-        showFields, showSingleNamedField, parseFields, parseFieldsFlat,+        showFields, showSingleNamedField, showSimpleSingleNamedField,+        parseFields, parseFieldsFlat,         parseFilePathQ, parseTokenQ, parseTokenQ',         parseModuleNameQ, parseBuildTool, parsePkgconfigDependency,         parseOptVersion, parsePackageNameQ, parseVersionRangeQ,@@ -86,7 +87,8 @@ import Data.Maybe       (fromMaybe) import Data.Tree as Tree (Tree(..), flatten) import qualified Data.Map as Map-import Control.Monad (foldM)+import Control.Monad (foldM, ap)+import Control.Applicative (Applicative(..)) import System.FilePath (normalise) import Data.List (sortBy) @@ -94,15 +96,15 @@  type LineNo = Int -data PError = AmbigousParse String LineNo+data PError = AmbiguousParse String LineNo             | NoParse String LineNo             | TabsError LineNo             | FromString String (Maybe LineNo)-        deriving Show+        deriving (Eq, Show)  data PWarning = PWarning String               | UTFWarning LineNo String-        deriving Show+        deriving (Eq, Show)  showPWarning :: FilePath -> PWarning -> String showPWarning fpath (PWarning msg) =@@ -114,8 +116,17 @@ data ParseResult a = ParseFailed PError | ParseOk [PWarning] a         deriving Show +instance Functor ParseResult where+        fmap _ (ParseFailed err) = ParseFailed err+        fmap f (ParseOk ws x) = ParseOk ws $ f x++instance Applicative ParseResult where+        pure = return+        (<*>) = ap++ instance Monad ParseResult where-        return x = ParseOk [] x+        return = ParseOk []         ParseFailed err >>= _ = ParseFailed err         ParseOk ws x >>= f = case f x of                                ParseFailed err -> ParseFailed err@@ -139,8 +150,8 @@     []  -> case [ x | (x,ys) <- results, all isSpace ys ] of              [a] -> ParseOk (utf8Warnings line fieldname s) a              []  -> ParseFailed (NoParse fieldname line)-             _   -> ParseFailed (AmbigousParse fieldname line)-    _   -> ParseFailed (AmbigousParse fieldname line)+             _   -> ParseFailed (AmbiguousParse fieldname line)+    _   -> ParseFailed (AmbiguousParse fieldname line)   where results = readP_to_S p s  runE :: LineNo -> String -> ReadE a -> String -> ParseResult a@@ -157,10 +168,12 @@          , '\xfffd' `elem` l ]  locatedErrorMsg :: PError -> (Maybe LineNo, String)-locatedErrorMsg (AmbigousParse f n) = (Just n, "Ambiguous parse in field '"++f++"'.")-locatedErrorMsg (NoParse f n)       = (Just n, "Parse of field '"++f++"' failed.")-locatedErrorMsg (TabsError n)       = (Just n, "Tab used as indentation.")-locatedErrorMsg (FromString s n)    = (n, s)+locatedErrorMsg (AmbiguousParse f n) = (Just n,+                                        "Ambiguous parse in field '"++f++"'.")+locatedErrorMsg (NoParse f n)        = (Just n,+                                        "Parse of field '"++f++"' failed.")+locatedErrorMsg (TabsError n)        = (Just n, "Tab used as indentation.")+locatedErrorMsg (FromString s n)     = (n, s)  syntaxError :: LineNo -> String -> ParseResult a syntaxError n s = ParseFailed $ FromString s (Just n)@@ -183,7 +196,7 @@         -- successful.  Otherwise, reports an error on line number @n@.       } -field :: String -> (a -> Doc) -> (ReadP a a) -> FieldDescr a+field :: String -> (a -> Doc) -> ReadP a a -> FieldDescr a field name showF readF =   FieldDescr name showF (\line val _st -> runP line name readF val) @@ -191,7 +204,7 @@ -- into a 'b'. liftField :: (b -> a) -> (a -> b -> b) -> FieldDescr a -> FieldDescr b liftField get set (FieldDescr name showF parseF)- = FieldDescr name (\b -> showF (get b))+ = FieldDescr name (showF . get)         (\line str b -> do             a <- parseF line str (get b)             return (set a b))@@ -199,12 +212,12 @@ -- Parser combinator for simple fields.  Takes a field name, a pretty printer, -- a parser function, an accessor, and a setter, returns a FieldDescr over the -- compoid structure.-simpleField :: String -> (a -> Doc) -> (ReadP a a)+simpleField :: String -> (a -> Doc) -> ReadP a a             -> (b -> a) -> (a -> b -> b) -> FieldDescr b simpleField name showF readF get set   = liftField get set $ field name showF readF -commaListField :: String -> (a -> Doc) -> (ReadP [a] a)+commaListField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b commaListField name showF readF get set =   liftField get set' $@@ -212,7 +225,7 @@   where     set' xs b = set (get b ++ xs) b -spaceListField :: String -> (a -> Doc) -> (ReadP [a] a)+spaceListField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b spaceListField name showF readF get set =   liftField get set' $@@ -220,7 +233,7 @@   where     set' xs b = set (get b ++ xs) b -listField :: String -> (a -> Doc) -> (ReadP [a] a)+listField :: String -> (a -> Doc) -> ReadP [a] a                  -> (b -> [a]) -> ([a] -> b -> b) -> FieldDescr b listField name showF readF get set =   liftField get set' $@@ -228,7 +241,8 @@   where     set' xs b = set (get b ++ xs) b -optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])]) -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b+optsField :: String -> CompilerFlavor -> (b -> [(CompilerFlavor,[String])])+             -> ([(CompilerFlavor,[String])] -> b -> b) -> FieldDescr b optsField name flavor get set =    liftField (fromMaybe [] . lookup flavor . get)              (\opts b -> set (reorder (update flavor opts (get b))) b) $@@ -244,7 +258,7 @@  -- TODO: this is a bit smelly hack. It's because we want to parse bool fields --       liberally but not accept new parses. We cannot do that with ReadP---       because it does not support warnings. We need a new parser framwork!+--       because it does not support warnings. We need a new parser framework! boolField :: String -> (b -> Bool) -> (Bool -> b -> b) -> FieldDescr b boolField name get set = liftField get set (FieldDescr name showF readF)   where@@ -276,12 +290,19 @@     []      -> Nothing     (get:_) -> Just (render . ppField f . get) +showSimpleSingleNamedField :: [FieldDescr a] -> String -> Maybe (a -> String)+showSimpleSingleNamedField fields f =+  case [ get | (FieldDescr f' get _) <- fields, f' == f ] of+    []      -> Nothing+    (get:_) -> Just (renderStyle myStyle . get)+ where myStyle = style { mode = LeftMode }+ parseFields :: [FieldDescr a] -> a -> String -> ParseResult a-parseFields fields initial = \str ->+parseFields fields initial str =   readFields str >>= accumFields fields initial  parseFieldsFlat :: [FieldDescr a] -> a -> String -> ParseResult a-parseFieldsFlat fields initial = \str ->+parseFieldsFlat fields initial str =   readFieldsFlat str >>= accumFields fields initial  accumFields :: [FieldDescr a] -> a -> [Field] -> ParseResult a@@ -314,7 +335,7 @@ --   warnings will be generated) ignores unrecognized fields, by --   returning the structure being built unmodified. ignoreUnrec :: UnrecFieldParser a-ignoreUnrec _ x = Just x+ignoreUnrec _ = Just  ------------------------------------------------------------------------------ @@ -370,7 +391,7 @@  -- attach line number and determine indentation trimLines :: [String] -> [(LineNo, Indent, HasTabs, String)]-trimLines ls = [ (lineno, indent, hastabs, (trimTrailing l'))+trimLines ls = [ (lineno, indent, hastabs, trimTrailing l')                | (lineno, l) <- zip [1..] ls                , let (sps, l') = span isSpace l                      indent    = length sps@@ -492,7 +513,7 @@         ([], _)   -> layout i (Node (n,t,l) [] :a) ss         (ts, ss') -> layout i (Node (n,t,l) ts :a) ss' -layout _ _ (   OpenBracket  n :_)  = syntaxError n $ "unexpected '{'"+layout _ _ (   OpenBracket  n :_)  = syntaxError n "unexpected '{'" layout _ a (s@(CloseBracket _):ss) = return (reverse a, s:ss) layout _ _ (   Span n l       : _) = syntaxError n $ "unexpected span: "                                                   ++ show l@@ -567,7 +588,8 @@        | otherwise     = do tp  <- ifelse thenpart                             fs' <- ifelse fs                             return (IfBlock n cond tp []:fs')-ifelse (Section n "else" _ _:_) = syntaxError n "stray 'else' with no preceding 'if'"+ifelse (Section n "else" _ _:_) = syntaxError n+                                  "stray 'else' with no preceding 'if'" ifelse (Section n s a fs':fs) = do fs''  <- ifelse fs'                                    fs''' <- ifelse fs                                    return (Section n s a fs'' : fs''')@@ -585,11 +607,16 @@   -- removed until normalise is no longer broken, was:   --   liftM normalise parseTokenQ +betweenSpaces :: ReadP r a -> ReadP r a+betweenSpaces act = do skipSpaces+                       res <- act+                       skipSpaces+                       return res+ parseBuildTool :: ReadP r Dependency parseBuildTool = do name <- parseBuildToolNameQ-                    skipSpaces-                    ver <- parseVersionRangeQ <++ return anyVersion-                    skipSpaces+                    ver <- betweenSpaces $+                           parseVersionRangeQ <++ return anyVersion                     return $ Dependency name ver  parseBuildToolNameQ :: ReadP r PackageName@@ -607,10 +634,10 @@ -- eg "gtk+-2.0" is a valid pkg-config package _name_. -- It then has a package version number like 2.10.13 parsePkgconfigDependency :: ReadP r Dependency-parsePkgconfigDependency = do name <- munch1 (\c -> isAlphaNum c || c `elem` "+-._")-                              skipSpaces-                              ver <- parseVersionRangeQ <++ return anyVersion-                              skipSpaces+parsePkgconfigDependency = do name <- munch1+                                      (\c -> isAlphaNum c || c `elem` "+-._")+                              ver <- betweenSpaces $+                                     parseVersionRangeQ <++ return anyVersion                               return $ Dependency (PackageName name) ver  parsePackageNameQ :: ReadP r PackageName@@ -630,9 +657,7 @@   where     tw :: ReadP r (CompilerFlavor,VersionRange)     tw = do compiler <- parseCompilerFlavorCompat-            skipSpaces-            version <- parse <++ return anyVersion-            skipSpaces+            version <- betweenSpaces $ parse <++ return anyVersion             return (compiler,version)  parseLicenseQ :: ReadP r License@@ -656,13 +681,13 @@ parseTokenQ = parseHaskellString <++ munch1 (\x -> not (isSpace x) && x /= ',')  parseTokenQ' :: ReadP r String-parseTokenQ' = parseHaskellString <++ munch1 (\x -> not (isSpace x))+parseTokenQ' = parseHaskellString <++ munch1 (not . isSpace)  parseSepList :: ReadP r b              -> ReadP r a -- ^The parser for the stuff between commas              -> ReadP r [a] parseSepList sepr p = sepBy p separator-    where separator = skipSpaces >> sepr >> skipSpaces+    where separator = betweenSpaces sepr  parseSpaceList :: ReadP r a -- ^The parser for the stuff between commas                -> ReadP r [a]@@ -677,7 +702,7 @@ parseOptCommaList = parseSepList (optional (ReadP.char ','))  parseQuoted :: ReadP r a -> ReadP r a-parseQuoted p = between (ReadP.char '"') (ReadP.char '"') p+parseQuoted = between (ReadP.char '"') (ReadP.char '"')  parseFreeText :: ReadP.ReadP s String parseFreeText = ReadP.munch (const True)
cabal/Cabal/Distribution/ReadE.hs view
@@ -63,14 +63,14 @@ succeedReadE f = ReadE (Right . f)  failReadE :: ErrorMsg -> ReadE a-failReadE = ReadE . const Left+failReadE = ReadE . const . Left  parseReadE :: ReadE a -> ReadP r a parseReadE (ReadE p) = do   txt <- look   either fail return (p txt) -readEOrFail :: ReadE a -> (String -> a)+readEOrFail :: ReadE a -> String -> a readEOrFail r = either error id . runReadE r  readP_to_E :: (String -> ErrorMsg) -> ReadP a a -> ReadE a
cabal/Cabal/Distribution/Simple.hs view
@@ -101,7 +101,7 @@ import Distribution.Simple.Setup import Distribution.Simple.Command -import Distribution.Simple.Build        ( build )+import Distribution.Simple.Build        ( build, repl ) import Distribution.Simple.SrcDist      ( sdist ) import Distribution.Simple.Register          ( register, unregister )@@ -131,15 +131,17 @@          ( display )  -- Base-import System.Environment(getArgs, getProgName, getEnvironment)+import System.Environment(getArgs, getProgName) import System.Directory(removeFile, doesFileExist,                         doesDirectoryExist, removeDirectoryRecursive) import System.Exit import System.IO.Error   (isDoesNotExistError)-import Distribution.Compat.Exception (catchIO, throwIOIO)+import Control.Exception (throwIO)+import Distribution.Compat.Environment (getEnvironment)+import Distribution.Compat.Exception (catchIO)  import Control.Monad   (when)-import Data.List       (intersperse, unionBy, nub, (\\))+import Data.List       (intercalate, unionBy, nub, (\\))  -- | A simple implementation of @main@ for a Cabal setup script. -- It reads the package description file using IO, and performs the@@ -187,7 +189,7 @@     printHelp help = getProgName >>= putStr . help     printOptionsList = putStr . unlines     printErrors errs = do-      putStr (concat (intersperse "\n" errs))+      putStr (intercalate "\n" errs)       exitWith (ExitFailure 1)     printNumericVersion = putStrLn $ display cabalVersion     printVersion        = putStrLn $ "Cabal library version "@@ -198,6 +200,7 @@       [configureCommand progs `commandAddAction` \fs as ->                                                  configureAction    hooks fs as >> return ()       ,buildCommand     progs `commandAddAction` buildAction        hooks+      ,replCommand      progs `commandAddAction` replAction         hooks       ,installCommand         `commandAddAction` installAction      hooks       ,copyCommand            `commandAddAction` copyAction         hooks       ,haddockCommand         `commandAddAction` haddockAction      hooks@@ -272,8 +275,26 @@    hookedAction preBuild buildHook postBuild                (return lbi { withPrograms = progs })-               hooks flags args+               hooks flags { buildArgs = args } args +replAction :: UserHooks -> ReplFlags -> Args -> IO ()+replAction hooks flags args = do+  let distPref  = fromFlag $ replDistPref flags+      verbosity = fromFlag $ replVerbosity flags++  lbi <- getBuildConfig hooks verbosity distPref+  progs <- reconfigurePrograms verbosity+             (replProgramPaths flags)+             (replProgramArgs flags)+             (withPrograms lbi)++  pbi <- preRepl hooks args flags+  let lbi' = lbi { withPrograms = progs }+      pkg_descr0 = localPkgDescr lbi'+      pkg_descr = updatePackageDescription pbi pkg_descr0+  replHook hooks pkg_descr lbi' hooks flags args+  postRepl hooks args flags pkg_descr lbi'+ hscolourAction :: UserHooks -> HscolourFlags -> Args -> IO () hscolourAction hooks flags args     = do let distPref  = fromFlag $ hscolourDistPref flags@@ -455,7 +476,7 @@     reconfigure :: FilePath -> LocalBuildInfo -> IO LocalBuildInfo     reconfigure pkg_descr_file lbi = do       notice verbosity $ pkg_descr_file ++ " has been changed. "-                      ++ "Re-configuring with most recently used options. " +                      ++ "Re-configuring with most recently used options. "                       ++ "If this fails, please run configure manually.\n"       let cFlags = configFlags lbi       let cFlags' = cFlags {@@ -502,8 +523,7 @@             isDir <- doesDirectoryExist fname             isFile <- doesFileExist fname             if isDir then removeDirectoryRecursive fname-              else if isFile then removeFile fname-              else return ()+              else when isFile $ removeFile fname         verbosity = fromFlag (cleanVerbosity flags)  -- --------------------------------------------------------------------------@@ -517,6 +537,7 @@        confHook  = configure,        postConf  = finalChecks,        buildHook = defaultBuildHook,+       replHook  = defaultReplHook,        copyHook  = \desc lbi _ f -> install desc lbi f, -- has correct 'copy' behavior with params        testHook = defaultTestHook,        benchHook = defaultBenchHook,@@ -551,14 +572,14 @@ defaultUserHooks = autoconfUserHooks {           confHook = \pkg flags -> do                        let verbosity = fromFlag (configVerbosity flags)-                       warn verbosity $+                       warn verbosity                          "defaultUserHooks in Setup script is deprecated."                        confHook autoconfUserHooks pkg flags,           postConf = oldCompatPostConf     }     -- This is the annoying old version that only runs configure if it exists.     -- It's here for compatibility with existing Setup.hs scripts. See:-    -- http://hackage.haskell.org/trac/hackage/ticket/165+    -- https://github.com/haskell/cabal/issues/158     where oldCompatPostConf args flags pkg_descr lbi               = do let verbosity = fromFlag (configVerbosity flags)                    noExtraFlags args@@ -632,7 +653,7 @@     rawSystemExitWithEnv verbosity "sh" args' env'    where-    args = "configure" : configureArgs backwardsCompatHack flags+    args = "./configure" : configureArgs backwardsCompatHack flags      appendToEnvironment (key, val) [] = [(key, val)]     appendToEnvironment (key, val) (kv@(k, v) : rest)@@ -647,7 +668,7 @@       = action           `catchIO` \ioe -> if isDoesNotExistError ioe                               then die notFoundMsg-                              else throwIOIO ioe+                              else throwIO ioe      notFoundMsg = "The package has a './configure' script. This requires a "                ++ "Unix compatibility toolchain such as MinGW+MSYS or Cygwin."@@ -692,6 +713,11 @@         -> UserHooks -> BuildFlags -> IO () defaultBuildHook pkg_descr localbuildinfo hooks flags =   build pkg_descr localbuildinfo flags (allSuffixHandlers hooks)++defaultReplHook :: PackageDescription -> LocalBuildInfo+        -> UserHooks -> ReplFlags -> [String] -> IO ()+defaultReplHook pkg_descr localbuildinfo hooks flags args =+  repl pkg_descr localbuildinfo flags (allSuffixHandlers hooks) args  defaultRegHook :: PackageDescription -> LocalBuildInfo         -> UserHooks -> RegisterFlags -> IO ()
cabal/Cabal/Distribution/Simple/Bench.hs view
@@ -152,5 +152,6 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) +++          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+          (LBI.hostPlatform lbi) ++           [(BenchmarkNameVar, toPathTemplate $ PD.benchmarkName bm)]
cabal/Cabal/Distribution/Simple/Build.hs view
@@ -3,7 +3,7 @@ -- Module      :  Distribution.Simple.Build -- Copyright   :  Isaac Jones 2003-2005, --                Ross Paterson 2006,---                Duncan Coutts 2007-2008+--                Duncan Coutts 2007-2008, 2012 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -46,7 +46,8 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}  module Distribution.Simple.Build (-    build,+    build, repl,+    startInterpreter,      initialBuildSteps,     writeAutogenFiles,@@ -58,6 +59,7 @@ import qualified Distribution.Simple.NHC  as NHC import qualified Distribution.Simple.Hugs as Hugs import qualified Distribution.Simple.UHC  as UHC+import qualified Distribution.Simple.HaskellSuite as HaskellSuite  import qualified Distribution.Simple.Build.Macros      as Build.Macros import qualified Distribution.Simple.Build.PathsModule as Build.PathsModule@@ -66,22 +68,30 @@          ( Package(..), PackageName(..), PackageIdentifier(..)          , Dependency(..), thisPackageVersion ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..), compilerFlavor, PackageDB(..) )+         ( Compiler, CompilerFlavor(..), compilerFlavor+         , PackageDB(..), PackageDBStack ) import Distribution.PackageDescription          ( PackageDescription(..), BuildInfo(..), Library(..), Executable(..)          , TestSuite(..), TestSuiteInterface(..), Benchmark(..)          , BenchmarkInterface(..) ) import qualified Distribution.InstalledPackageInfo as IPI import qualified Distribution.ModuleName as ModuleName+import Distribution.ModuleName (ModuleName)  import Distribution.Simple.Setup-         ( BuildFlags(..), fromFlag )+         ( Flag(..), BuildFlags(..), ReplFlags(..), fromFlag )+import Distribution.Simple.BuildTarget+         ( BuildTarget(..), readBuildTargets ) import Distribution.Simple.PreProcess          ( preprocessComponent, PPSuffixHandler ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(compiler, buildDir, withPackageDB, withPrograms)-         , Component(..), ComponentLocalBuildInfo(..), withComponentsLBI-         , componentBuildInfo, inplacePackageId )+         , Component(..), componentName, getComponent, componentBuildInfo+         , ComponentLocalBuildInfo(..), pkgEnabledComponents+         , withComponentsInBuildOrder, componentsInBuildOrder+         , ComponentName(..), showComponentName+         , ComponentDisabledReason(..), componentDisabledReason+         , inplacePackageId, LibraryName(..) ) import Distribution.Simple.Program.Types import Distribution.Simple.Program.Db import Distribution.Simple.BuildPaths@@ -91,7 +101,7 @@ import Distribution.Simple.Test ( stubFilePath, stubName ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, rewriteFile-         , die, info, setupMessage )+         , die, info, debug, warn, setupMessage )  import Distribution.Verbosity          ( Verbosity )@@ -100,10 +110,12 @@  import Data.Maybe          ( maybeToList )+import Data.Either+         ( partitionEithers ) import Data.List-         ( intersect )+         ( intersect, intercalate ) import Control.Monad-         ( unless )+         ( when, unless, forM_ ) import System.FilePath          ( (</>), (<.>) ) import System.Directory@@ -120,22 +132,87 @@ build pkg_descr lbi flags suffixes = do   let distPref  = fromFlag (buildDistPref flags)       verbosity = fromFlag (buildVerbosity flags)++  targets  <- readBuildTargets pkg_descr (buildArgs flags)+  targets' <- checkBuildTargets verbosity pkg_descr targets+  let componentsToBuild = map fst (componentsInBuildOrder lbi (map fst targets'))+  info verbosity $ "Component build order: "+                ++ intercalate ", " (map showComponentName componentsToBuild)+   initialBuildSteps distPref pkg_descr lbi verbosity-  setupMessage verbosity "Building" (packageId pkg_descr)+  when (null targets) $+    -- Only bother with this message if we're building the whole package+    setupMessage verbosity "Building" (packageId pkg_descr)    internalPackageDB <- createInternalPackageDB distPref -  withComponentsLBI pkg_descr lbi $ \comp clbi ->+  withComponentsInBuildOrder pkg_descr lbi componentsToBuild $ \comp clbi ->     let bi     = componentBuildInfo comp         progs' = addInternalBuildTools pkg_descr lbi bi (withPrograms lbi)         lbi'   = lbi {                    withPrograms  = progs',                    withPackageDB = withPackageDB lbi ++ [internalPackageDB]                  }-    in buildComponent verbosity pkg_descr lbi' suffixes comp clbi distPref+    in buildComponent verbosity (buildNumJobs flags) pkg_descr+                      lbi' suffixes comp clbi distPref  +repl     :: PackageDescription  -- ^ Mostly information from the .cabal file+         -> LocalBuildInfo      -- ^ Configuration information+         -> ReplFlags           -- ^ Flags that the user passed to build+         -> [ PPSuffixHandler ] -- ^ preprocessors to run before compiling+         -> [String]+         -> IO ()+repl pkg_descr lbi flags suffixes args = do+  let distPref  = fromFlag (replDistPref flags)+      verbosity = fromFlag (replVerbosity flags)++  targets  <- readBuildTargets pkg_descr args+  targets' <- case targets of+    []       -> return $ take 1 [ componentName c+                                | c <- pkgEnabledComponents pkg_descr ]+    [target] -> fmap (map fst) (checkBuildTargets verbosity pkg_descr [target])+    _        -> die $ "The 'repl' command does not support multiple targets at once."+  let componentsToBuild = componentsInBuildOrder lbi targets'+      componentForRepl  = last componentsToBuild+  debug verbosity $ "Component build order: "+                 ++ intercalate ", "+                      [ showComponentName c | (c,_) <- componentsToBuild ]++  initialBuildSteps distPref pkg_descr lbi verbosity++  internalPackageDB <- createInternalPackageDB distPref+  let lbiForComponent comp lbi' =+        lbi' {+          withPackageDB = withPackageDB lbi ++ [internalPackageDB],+          withPrograms  = addInternalBuildTools pkg_descr lbi'+                            (componentBuildInfo comp) (withPrograms lbi')+        }++  -- build any dependent components+  sequence_+    [ let comp = getComponent pkg_descr cname+          lbi' = lbiForComponent comp lbi+       in buildComponent verbosity NoFlag+                         pkg_descr lbi' suffixes comp clbi distPref+    | (cname, clbi) <- init componentsToBuild ]++  -- repl for target components+  let (cname, clbi) = componentForRepl+      comp = getComponent pkg_descr cname+      lbi' = lbiForComponent comp lbi+   in replComponent verbosity pkg_descr lbi' suffixes comp clbi distPref+++-- | Start an interpreter without loading any package files.+startInterpreter :: Verbosity -> ProgramDb -> Compiler -> PackageDBStack -> IO ()+startInterpreter verbosity programDb comp packageDBs =+  case compilerFlavor comp of+    GHC -> GHC.startInterpreter verbosity programDb comp packageDBs+    _   -> die "A REPL is not supported with this compiler."+ buildComponent :: Verbosity+               -> Flag (Maybe Int)                -> PackageDescription                -> LocalBuildInfo                -> [PPSuffixHandler]@@ -143,11 +220,11 @@                -> ComponentLocalBuildInfo                -> FilePath                -> IO ()-buildComponent verbosity pkg_descr lbi suffixes+buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CLib lib) clbi distPref = do     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity "Building library..."-    buildLib verbosity pkg_descr lbi lib clbi+    buildLib verbosity numJobs pkg_descr lbi lib clbi      -- Register the library in-place, so exes can depend     -- on internally defined libraries.@@ -163,106 +240,212 @@       (withPackageDB lbi)  -buildComponent verbosity pkg_descr lbi suffixes+buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CExe exe) clbi _ = do     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity $ "Building executable " ++ exeName exe ++ "..."-    buildExe verbosity pkg_descr lbi exe clbi+    buildExe verbosity numJobs pkg_descr lbi exe clbi  -buildComponent verbosity pkg_descr lbi suffixes-               comp@(CTest-                 test@TestSuite { testInterface = TestSuiteExeV10 _ f })+buildComponent verbosity numJobs pkg_descr lbi suffixes+               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })                clbi _distPref = do-    let bi  = testBuildInfo test-        exe = Executable {-                exeName    = testName test,-                modulePath = f,-                buildInfo  = bi-              }+    let exe = testSuiteExeV10AsExe test     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity $ "Building test suite " ++ testName test ++ "..."-    buildExe verbosity pkg_descr lbi exe clbi+    buildExe verbosity numJobs pkg_descr lbi exe clbi  -buildComponent verbosity pkg_descr lbi suffixes+buildComponent verbosity numJobs pkg_descr lbi suffixes                comp@(CTest-                 test@TestSuite { testInterface = TestSuiteLibV09 _ m })-               clbi distPref = do+                 test@TestSuite { testInterface = TestSuiteLibV09{} })+               clbi -- This ComponentLocalBuildInfo corresponds to a detailed+                    -- test suite and not a real component. It should not+                    -- be used, except to construct the CLBIs for the+                    -- library and stub executable that will actually be+                    -- built.+               distPref = do     pwd <- getCurrentDirectory-    let bi  = testBuildInfo test-        lib = Library {-                exposedModules = [ m ],-                libExposed     = True,-                libBuildInfo   = bi-              }-        pkg = pkg_descr {-                package      = (package pkg_descr) {-                                 pkgName = PackageName (testName test)-                               }-              , buildDepends = targetBuildDepends $ testBuildInfo test-              , executables  = []-              , testSuites   = []-              , library      = Just lib-              }-        ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi clbi) {-                IPI.installedPackageId = inplacePackageId $ packageId ipi-              }-        testDir = buildDir lbi </> stubName test-              </> stubName test ++ "-tmp"-        testLibDep = thisPackageVersion $ package pkg-        exe = Executable {-                exeName    = stubName test,-                modulePath = stubFilePath test,-                buildInfo  = (testBuildInfo test) {-                               hsSourceDirs       = [ testDir ],-                               targetBuildDepends = testLibDep-                                 : (targetBuildDepends $ testBuildInfo test)-                             }-              }-        -- | The stub executable needs a new 'ComponentLocalBuildInfo'-        -- that exposes the relevant test suite library.-        exeClbi = clbi {-                    componentPackageDeps =-                        (IPI.installedPackageId ipi, packageId ipi)-                      : (filter (\(_, x) -> let PackageName name = pkgName x-                                            in name == "Cabal" || name == "base")-                                (componentPackageDeps clbi))-                  }+    let (pkg, lib, libClbi, ipi, exe, exeClbi) =+          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity $ "Building test suite " ++ testName test ++ "..."-    buildLib verbosity pkg lbi lib clbi+    buildLib verbosity numJobs pkg lbi lib libClbi     registerPackage verbosity ipi pkg lbi True $ withPackageDB lbi-    buildExe verbosity pkg_descr lbi exe exeClbi+    buildExe verbosity numJobs pkg_descr lbi exe exeClbi  -buildComponent _ _ _ _+buildComponent _ _ _ _ _                (CTest TestSuite { testInterface = TestSuiteUnsupported tt })                _ _ =     die $ "No support for building test suite type " ++ display tt  -buildComponent verbosity pkg_descr lbi suffixes-               comp@(CBench-                 bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f })+buildComponent verbosity numJobs pkg_descr lbi suffixes+               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })                clbi _ = do-    let bi  = benchmarkBuildInfo bm-        exe = Executable-            { exeName = benchmarkName bm-            , modulePath = f-            , buildInfo  = bi-            }+    let (exe, exeClbi) = benchmarkExeV10asExe bm clbi     preprocessComponent pkg_descr comp lbi False verbosity suffixes     info verbosity $ "Building benchmark " ++ benchmarkName bm ++ "..."-    buildExe verbosity pkg_descr lbi exe clbi+    buildExe verbosity numJobs pkg_descr lbi exe exeClbi  -buildComponent _ _ _ _+buildComponent _ _ _ _ _                (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })                _ _ =     die $ "No support for building benchmark type " ++ display tt  +replComponent :: Verbosity+              -> PackageDescription+              -> LocalBuildInfo+              -> [PPSuffixHandler]+              -> Component+              -> ComponentLocalBuildInfo+              -> FilePath+              -> IO ()+replComponent verbosity pkg_descr lbi suffixes+               comp@(CLib lib) clbi _ = do+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replLib verbosity pkg_descr lbi lib clbi++replComponent verbosity pkg_descr lbi suffixes+               comp@(CExe exe) clbi _ = do+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replExe verbosity pkg_descr lbi exe clbi+++replComponent verbosity pkg_descr lbi suffixes+               comp@(CTest test@TestSuite { testInterface = TestSuiteExeV10{} })+               clbi _distPref = do+    let exe = testSuiteExeV10AsExe test+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replExe verbosity pkg_descr lbi exe clbi+++replComponent verbosity pkg_descr lbi suffixes+               comp@(CTest+                 test@TestSuite { testInterface = TestSuiteLibV09{} })+               clbi distPref = do+    pwd <- getCurrentDirectory+    let (pkg, lib, libClbi, _, _, _) =+          testSuiteLibV09AsLibAndExe pkg_descr lbi test clbi distPref pwd+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replLib verbosity pkg lbi lib libClbi+++replComponent _ _ _ _+              (CTest TestSuite { testInterface = TestSuiteUnsupported tt })+              _ _ =+    die $ "No support for building test suite type " ++ display tt+++replComponent verbosity pkg_descr lbi suffixes+               comp@(CBench bm@Benchmark { benchmarkInterface = BenchmarkExeV10 {} })+               clbi _ = do+    let (exe, exeClbi) = benchmarkExeV10asExe bm clbi+    preprocessComponent pkg_descr comp lbi False verbosity suffixes+    replExe verbosity pkg_descr lbi exe exeClbi+++replComponent _ _ _ _+              (CBench Benchmark { benchmarkInterface = BenchmarkUnsupported tt })+              _ _ =+    die $ "No support for building benchmark type " ++ display tt++----------------------------------------------------+-- Shared code for buildComponent and replComponent+--++-- | Translate a exe-style 'TestSuite' component into an exe for building+testSuiteExeV10AsExe :: TestSuite -> Executable+testSuiteExeV10AsExe test@TestSuite { testInterface = TestSuiteExeV10 _ mainFile } =+    Executable {+      exeName    = testName test,+      modulePath = mainFile,+      buildInfo  = testBuildInfo test+    }+testSuiteExeV10AsExe TestSuite{} = error "testSuiteExeV10AsExe: wrong kind"++-- | Translate a lib-style 'TestSuite' component into a lib + exe for building+testSuiteLibV09AsLibAndExe :: PackageDescription+                           -> LocalBuildInfo+                           -> TestSuite+                           -> ComponentLocalBuildInfo+                           -> FilePath+                           -> FilePath+                           -> (PackageDescription,+                               Library, ComponentLocalBuildInfo,+                               IPI.InstalledPackageInfo_ ModuleName,+                               Executable, ComponentLocalBuildInfo)+testSuiteLibV09AsLibAndExe pkg_descr lbi+                     test@TestSuite { testInterface = TestSuiteLibV09 _ m }+                     clbi distPref pwd =+    (pkg, lib, libClbi, ipi, exe, exeClbi)+  where+    bi  = testBuildInfo test+    lib = Library {+            exposedModules = [ m ],+            libExposed     = True,+            libBuildInfo   = bi+          }+    libClbi = LibComponentLocalBuildInfo+                { componentPackageDeps = componentPackageDeps clbi+                , componentLibraries = [LibraryName (testName test)]+                }+    pkg = pkg_descr {+            package      = (package pkg_descr) {+                             pkgName = PackageName (testName test)+                           }+          , buildDepends = targetBuildDepends $ testBuildInfo test+          , executables  = []+          , testSuites   = []+          , library      = Just lib+          }+    ipi = (inplaceInstalledPackageInfo pwd distPref pkg lib lbi libClbi) {+            IPI.installedPackageId = inplacePackageId $ packageId ipi+          }+    testDir = buildDir lbi </> stubName test+          </> stubName test ++ "-tmp"+    testLibDep = thisPackageVersion $ package pkg+    exe = Executable {+            exeName    = stubName test,+            modulePath = stubFilePath test,+            buildInfo  = (testBuildInfo test) {+                           hsSourceDirs       = [ testDir ],+                           targetBuildDepends = testLibDep+                             : (targetBuildDepends $ testBuildInfo test)+                         }+          }+    -- | The stub executable needs a new 'ComponentLocalBuildInfo'+    -- that exposes the relevant test suite library.+    exeClbi = ExeComponentLocalBuildInfo {+                componentPackageDeps =+                    (IPI.installedPackageId ipi, packageId ipi)+                  : (filter (\(_, x) -> let PackageName name = pkgName x+                                        in name == "Cabal" || name == "base")+                            (componentPackageDeps clbi))+              }+testSuiteLibV09AsLibAndExe _ _ TestSuite{} _ _ _ = error "testSuiteLibV09AsLibAndExe: wrong kind"+++-- | Translate a exe-style 'Benchmark' component into an exe for building+benchmarkExeV10asExe :: Benchmark -> ComponentLocalBuildInfo+                     -> (Executable, ComponentLocalBuildInfo)+benchmarkExeV10asExe bm@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f }+                     clbi =+    (exe, exeClbi)+  where+    exe = Executable {+            exeName    = benchmarkName bm,+            modulePath = f,+            buildInfo  = benchmarkBuildInfo bm+          }+    exeClbi = ExeComponentLocalBuildInfo {+                componentPackageDeps = componentPackageDeps clbi+              }+benchmarkExeV10asExe Benchmark{} _ = error "benchmarkExeV10asExe: wrong kind"+ -- | Initialize a new package db file for libraries defined -- internally to the package. createInternalPackageDB :: FilePath -> IO PackageDB@@ -290,30 +473,51 @@  -- TODO: build separate libs in separate dirs so that we can build -- multiple libs, e.g. for 'LibTest' library-style testsuites-buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo+buildLib :: Verbosity -> Flag (Maybe Int)+                      -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi =+buildLib verbosity numJobs pkg_descr lbi lib clbi =   case compilerFlavor (compiler lbi) of-    GHC  -> GHC.buildLib  verbosity pkg_descr lbi lib clbi-    JHC  -> JHC.buildLib  verbosity pkg_descr lbi lib clbi-    LHC  -> LHC.buildLib  verbosity pkg_descr lbi lib clbi-    Hugs -> Hugs.buildLib verbosity pkg_descr lbi lib clbi-    NHC  -> NHC.buildLib  verbosity pkg_descr lbi lib clbi-    UHC  -> UHC.buildLib  verbosity pkg_descr lbi lib clbi+    GHC  -> GHC.buildLib  verbosity numJobs pkg_descr lbi lib clbi+    JHC  -> JHC.buildLib  verbosity         pkg_descr lbi lib clbi+    LHC  -> LHC.buildLib  verbosity         pkg_descr lbi lib clbi+    Hugs -> Hugs.buildLib verbosity         pkg_descr lbi lib clbi+    NHC  -> NHC.buildLib  verbosity         pkg_descr lbi lib clbi+    UHC  -> UHC.buildLib  verbosity         pkg_descr lbi lib clbi+    HaskellSuite {} -> HaskellSuite.buildLib verbosity pkg_descr lbi lib clbi     _    -> die "Building is not supported with this compiler." -buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo+buildExe :: Verbosity -> Flag (Maybe Int)+                      -> PackageDescription -> LocalBuildInfo                       -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity pkg_descr lbi exe clbi =+buildExe verbosity numJobs pkg_descr lbi exe clbi =   case compilerFlavor (compiler lbi) of-    GHC  -> GHC.buildExe  verbosity pkg_descr lbi exe clbi-    JHC  -> JHC.buildExe  verbosity pkg_descr lbi exe clbi-    LHC  -> LHC.buildExe  verbosity pkg_descr lbi exe clbi-    Hugs -> Hugs.buildExe verbosity pkg_descr lbi exe clbi-    NHC  -> NHC.buildExe  verbosity pkg_descr lbi exe clbi-    UHC  -> UHC.buildExe  verbosity pkg_descr lbi exe clbi+    GHC  -> GHC.buildExe  verbosity numJobs pkg_descr lbi exe clbi+    JHC  -> JHC.buildExe  verbosity         pkg_descr lbi exe clbi+    LHC  -> LHC.buildExe  verbosity         pkg_descr lbi exe clbi+    Hugs -> Hugs.buildExe verbosity         pkg_descr lbi exe clbi+    NHC  -> NHC.buildExe  verbosity         pkg_descr lbi exe clbi+    UHC  -> UHC.buildExe  verbosity         pkg_descr lbi exe clbi     _    -> die "Building is not supported with this compiler." ++replLib :: Verbosity -> PackageDescription -> LocalBuildInfo+                     -> Library            -> ComponentLocalBuildInfo -> IO ()+replLib verbosity pkg_descr lbi lib clbi =+  case compilerFlavor (compiler lbi) of+    -- 'cabal repl' doesn't need to support 'ghc --make -j', so we just pass+    -- NoFlag as the numJobs parameter.+    GHC  -> GHC.replLib verbosity NoFlag pkg_descr lbi lib clbi+    _    -> die "A REPL is not supported for this compiler."++replExe :: Verbosity -> PackageDescription -> LocalBuildInfo+                     -> Executable         -> ComponentLocalBuildInfo -> IO ()+replExe verbosity pkg_descr lbi exe clbi =+  case compilerFlavor (compiler lbi) of+    GHC  -> GHC.replExe verbosity NoFlag pkg_descr lbi exe clbi+    _    -> die "A REPL is not supported for this compiler."++ initialBuildSteps :: FilePath -- ^"dist" prefix                   -> PackageDescription  -- ^mostly information from the .cabal file                   -> LocalBuildInfo -- ^Configuration information@@ -347,3 +551,48 @@    let cppHeaderPath = autogenModulesDir lbi </> cppHeaderName   rewriteFile cppHeaderPath (Build.Macros.generate pkg lbi)++-- | Check that the given build targets are valid in the current context.+--+-- Also swizzle into a more convenient form.+--+checkBuildTargets :: Verbosity -> PackageDescription -> [BuildTarget]+                  -> IO [(ComponentName, Maybe (Either ModuleName FilePath))]+checkBuildTargets _ pkg []      =+    return [ (componentName c, Nothing) | c <- pkgEnabledComponents pkg ]++checkBuildTargets verbosity pkg targets = do++    let (enabled, disabled) =+          partitionEithers+            [ case componentDisabledReason (getComponent pkg cname) of+                Nothing     -> Left  target'+                Just reason -> Right (cname, reason)+            | target <- targets+            , let target'@(cname,_) = swizzleTarget target ]++    case disabled of+      []                 -> return ()+      ((cname,reason):_) -> die $ formatReason (showComponentName cname) reason++    forM_ [ (c, t) | (c, Just t) <- enabled ] $ \(c, t) ->+      warn verbosity $ "Ignoring '" ++ either display id t ++ ". The whole "+                    ++ showComponentName c ++ " will be built. (Support for "+                    ++ "module and file targets has not been implemented yet.)"++    return enabled++  where+    swizzleTarget (BuildTargetComponent c)   = (c, Nothing)+    swizzleTarget (BuildTargetModule    c m) = (c, Just (Left  m))+    swizzleTarget (BuildTargetFile      c f) = (c, Just (Right f))++    formatReason cn DisabledComponent =+        "Cannot build the " ++ cn ++ " because the component is marked "+     ++ "as disabled in the .cabal file."+    formatReason cn DisabledAllTests =+        "Cannot build the " ++ cn ++ " because test suites are not "+     ++ "enabled. Run configure with the flag --enable-tests"+    formatReason cn DisabledAllBenchmarks =+        "Cannot build the " ++ cn ++ " because benchmarks are not "+     ++ "enabled. Re-run configure with the flag --enable-benchmarks"
cabal/Cabal/Distribution/Simple/Build/Macros.hs view
@@ -18,9 +18,12 @@ -- numbers. -- module Distribution.Simple.Build.Macros (-    generate+    generate,+    generatePackageVersionMacros,   ) where +import Data.Maybe+         ( isJust ) import Distribution.Package          ( PackageIdentifier(PackageIdentifier) ) import Distribution.Version@@ -28,7 +31,11 @@ import Distribution.PackageDescription          ( PackageDescription ) import Distribution.Simple.LocalBuildInfo-        ( LocalBuildInfo, externalPackageDeps )+         ( LocalBuildInfo(withPrograms), externalPackageDeps )+import Distribution.Simple.Program.Db+         ( configuredPrograms )+import Distribution.Simple.Program.Types+         ( ConfiguredProgram(programId, programVersion) ) import Distribution.Text          ( display ) @@ -36,22 +43,56 @@ -- * Generate cabal_macros.h -- ------------------------------------------------------------ +-- | The contents of the @cabal_macros.h@ for the given configured package.+-- generate :: PackageDescription -> LocalBuildInfo -> String-generate _pkg_descr lbi = concat $-  "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" :-  [ concat-    ["/* package ",display pkgid," */\n"-    ,"#define VERSION_",pkgname," ",show (display version),"\n"-    ,"#define MIN_VERSION_",pkgname,"(major1,major2,minor) (\\\n"-    ,"  (major1) <  ",major1," || \\\n"-    ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"-    ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"-    ,"\n\n"-    ]-  | (_, pkgid@(PackageIdentifier name version)) <- externalPackageDeps lbi-  , let (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)-        pkgname = map fixchar (display name)+generate _pkg_descr lbi =+  "/* DO NOT EDIT: This file is automatically generated by Cabal */\n\n" +++  generatePackageVersionMacros (map snd (externalPackageDeps lbi)) +++  generateToolVersionMacros (configuredPrograms . withPrograms $ lbi)++-- | Helper function that generates just the @VERSION_pkg@ and @MIN_VERSION_pkg@+-- macros for a list of package ids (usually used with the specific deps of+-- a configured package).+--+generatePackageVersionMacros :: [PackageIdentifier] -> String+generatePackageVersionMacros pkgids = concat+  [ "/* package " ++ display pkgid ++ " */\n"+  ++ generateMacros "" pkgname version+  | pkgid@(PackageIdentifier name version) <- pkgids+  , let pkgname = map fixchar (display name)   ]-  where fixchar '-' = '_'-        fixchar c   = c +-- | Helper function that generates just the @TOOL_VERSION_pkg@ and+-- @MIN_TOOL_VERSION_pkg@ macros for a list of configured programs.+--+generateToolVersionMacros :: [ConfiguredProgram] -> String+generateToolVersionMacros progs = concat+  [ "/* tool " ++ progid ++ " */\n"+  ++ generateMacros "TOOL_" progname version+  | prog <- progs+  , isJust . programVersion $ prog+  , let progid       = programId prog ++ "-" ++ display version+        progname     = map fixchar (programId prog)+        Just version = programVersion prog+  ]++-- | Common implementation of 'generatePackageVersionMacros' and+-- 'generateToolVersionMacros'.+--+generateMacros :: String -> String -> Version -> String+generateMacros prefix name version =+  concat+  ["#define ", prefix, "VERSION_",name," ",show (display version),"\n"+  ,"#define MIN_", prefix, "VERSION_",name,"(major1,major2,minor) (\\\n"+  ,"  (major1) <  ",major1," || \\\n"+  ,"  (major1) == ",major1," && (major2) <  ",major2," || \\\n"+  ,"  (major1) == ",major1," && (major2) == ",major2," && (minor) <= ",minor,")"+  ,"\n\n"+  ]+  where+    (major1:major2:minor:_) = map show (versionBranch version ++ repeat 0)++fixchar :: Char -> Char+fixchar '-' = '_'+fixchar c   = c
cabal/Cabal/Distribution/Simple/Build/PathsModule.hs view
@@ -68,7 +68,7 @@         "module " ++ display paths_modulename ++ " (\n"++         "    version,\n"++         "    getBinDir, getLibDir, getDataDir, getLibexecDir,\n"++-        "    getDataFileName\n"+++        "    getDataFileName, getSysconfDir\n"++         "  ) where\n"++         "\n"++         foreign_imports++@@ -85,17 +85,19 @@         body         | absolute =-          "\nbindir, libdir, datadir, libexecdir :: FilePath\n"+++          "\nbindir, libdir, datadir, libexecdir, sysconfdir :: FilePath\n"++           "\nbindir     = " ++ show flat_bindir ++           "\nlibdir     = " ++ show flat_libdir ++           "\ndatadir    = " ++ show flat_datadir ++           "\nlibexecdir = " ++ show flat_libexecdir +++          "\nsysconfdir = " ++ show flat_sysconfdir ++           "\n"++-          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir :: IO FilePath\n"+++          "\ngetBinDir, getLibDir, getDataDir, getLibexecDir, getSysconfDir :: IO FilePath\n"++           "getBinDir = "++mkGetEnvOr "bindir" "return bindir"++"\n"++           "getLibDir = "++mkGetEnvOr "libdir" "return libdir"++"\n"++           "getDataDir = "++mkGetEnvOr "datadir" "return datadir"++"\n"++           "getLibexecDir = "++mkGetEnvOr "libexecdir" "return libexecdir"++"\n"+++          "getSysconfDir = "++mkGetEnvOr "sysconfdir" "return sysconfdir"++"\n"++           "\n"++           "getDataFileName :: FilePath -> IO FilePath\n"++           "getDataFileName name = do\n"++@@ -115,6 +117,8 @@                               (mkGetDir flat_datadir flat_datadirrel)++"\n\n"++           "getLibexecDir :: IO FilePath\n"++           "getLibexecDir = "++mkGetDir flat_libexecdir flat_libexecdirrel++"\n\n"+++          "getSysconfDir :: IO FilePath\n"+++          "getSysconfDir = "++mkGetDir flat_sysconfdir flat_sysconfdirrel++"\n\n"++           "getDataFileName :: FilePath -> IO FilePath\n"++           "getDataFileName name = do\n"++           "  dir <- getDataDir\n"++@@ -131,13 +135,15 @@           bindir     = flat_bindir,           libdir     = flat_libdir,           datadir    = flat_datadir,-          libexecdir = flat_libexecdir+          libexecdir = flat_libexecdir,+          sysconfdir = flat_sysconfdir         } = absoluteInstallDirs pkg_descr lbi NoCopyDest         InstallDirs {           bindir     = flat_bindirrel,           libdir     = flat_libdirrel,           datadir    = flat_datadirrel,           libexecdir = flat_libexecdirrel,+          sysconfdir = flat_sysconfdirrel,           progdir    = flat_progdirrel         } = prefixRelativeInstallDirs (packageId pkg_descr) lbi @@ -181,7 +187,7 @@ -- component of interest. pkgPathEnvVar :: PackageDescription               -> String     -- ^ path component; one of \"bindir\", \"libdir\",-                            -- \"datadir\" or \"libexecdir\"+                            -- \"datadir\", \"libexecdir\", or \"sysconfdir\"               -> String     -- ^ environment variable name pkgPathEnvVar pkg_descr var =     showPkgName (packageName pkg_descr) ++ "_" ++ var@@ -210,7 +216,7 @@     where cconv = case arch of                   I386 -> "stdcall"                   X86_64 -> "ccall"-+                  _ -> error "win32 supported only with I386, X86_64"  get_prefix_hugs :: String get_prefix_hugs =
cabal/Cabal/Distribution/Simple/BuildPaths.hs view
@@ -63,13 +63,14 @@ import System.FilePath ((</>), (<.>))  import Distribution.Package-         ( PackageIdentifier, packageName )+         ( packageName ) import Distribution.ModuleName (ModuleName) import qualified Distribution.ModuleName as ModuleName import Distribution.Compiler          ( CompilerId(..) ) import Distribution.PackageDescription (PackageDescription)-import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(buildDir))+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(buildDir), LibraryName(..) ) import Distribution.Simple.Setup (defaultDistPref) import Distribution.Text          ( display )@@ -109,18 +110,18 @@ -- --------------------------------------------------------------------------- -- Library file names -mkLibName :: PackageIdentifier -> String-mkLibName lib = "libHS" ++ display lib <.> "a"+mkLibName :: LibraryName -> String+mkLibName (LibraryName lib) = "lib" ++ lib <.> "a" -mkProfLibName :: PackageIdentifier -> String-mkProfLibName lib =  "libHS" ++ display lib ++ "_p" <.> "a"+mkProfLibName :: LibraryName -> String+mkProfLibName (LibraryName lib) =  "lib" ++ lib ++ "_p" <.> "a"  -- Implement proper name mangling for dynamical shared objects -- libHS<packagename>-<compilerFlavour><compilerVersion> -- e.g. libHSbase-2.1-ghc6.6.1.so-mkSharedLibName :: PackageIdentifier -> CompilerId -> String-mkSharedLibName lib (CompilerId compilerFlavor compilerVersion)-  = "libHS" ++ display lib ++ "-" ++ comp <.> dllExtension+mkSharedLibName :: CompilerId -> LibraryName -> String+mkSharedLibName (CompilerId compilerFlavor compilerVersion) (LibraryName lib)+  = "lib" ++ lib ++ "-" ++ comp <.> dllExtension   where comp = display compilerFlavor ++ display compilerVersion  -- ------------------------------------------------------------
+ cabal/Cabal/Distribution/Simple/BuildTarget.hs view
@@ -0,0 +1,931 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.BuildTargets+-- Copyright   :  (c) Duncan Coutts 2012+-- License     :  BSD-like+--+-- Maintainer  :  duncan@community.haskell.org+--+-- Handling for user-specified build targets+-----------------------------------------------------------------------------+module Distribution.Simple.BuildTarget (++    -- * Build targets+    BuildTarget(..),+    readBuildTargets,++    -- * Parsing user build targets+    UserBuildTarget,+    readUserBuildTargets,+    UserBuildTargetProblem(..),+    reportUserBuildTargetProblems,++    -- * Resolving build targets+    resolveBuildTargets,+    BuildTargetProblem(..),+    reportBuildTargetProblems,+  ) where++import Distribution.Package+         ( Package(..), PackageId, packageName )++import Distribution.PackageDescription+         ( PackageDescription+         , Executable(..)+         , TestSuite(..), TestSuiteInterface(..), testModules+         , Benchmark(..), BenchmarkInterface(..), benchmarkModules+         , BuildInfo(..), libModules, exeModules )+import Distribution.ModuleName+         ( ModuleName, toFilePath )+import Distribution.Simple.LocalBuildInfo+         ( Component(..), ComponentName(..)+         , pkgComponents, componentName, componentBuildInfo )++import Distribution.Text+         ( display )+import Distribution.Simple.Utils+         ( die, lowercase, equating )++import Data.List+         ( nub, stripPrefix, sortBy, groupBy, partition, intercalate )+import Data.Ord+import Data.Maybe+         ( listToMaybe, catMaybes )+import Data.Either+         ( partitionEithers )+import qualified Data.Map as Map+import Control.Monad+import Control.Applicative (Applicative(..), Alternative(..))+import qualified Distribution.Compat.ReadP as Parse+import Distribution.Compat.ReadP+         ( (+++), (<++) )+import Data.Char+         ( isSpace, isAlphaNum )+import System.FilePath as FilePath+         ( dropExtension, normalise, splitDirectories, joinPath, splitPath+         , hasTrailingPathSeparator )+import System.Directory+         ( doesFileExist, doesDirectoryExist )++-- ------------------------------------------------------------+-- * User build targets+-- ------------------------------------------------------------++-- | Various ways that a user may specify a build target.+--+data UserBuildTarget =++     -- | A target specified by a single name. This could be a component+     -- module or file.+     --+     -- > cabal build foo+     -- > cabal build Data.Foo+     -- > cabal build Data/Foo.hs  Data/Foo.hsc+     --+     UserBuildTargetSingle String++     -- | A target specified by a qualifier and name. This could be a component+     -- name qualified by the component namespace kind, or a module or file+     -- qualified by the component name.+     --+     -- > cabal build lib:foo exe:foo+     -- > cabal build foo:Data.Foo+     -- > cabal build foo:Data/Foo.hs+     --+   | UserBuildTargetDouble String String++     -- A fully qualified target, either a module or file qualified by a+     -- component name with the component namespace kind.+     --+     -- > cabal build lib:foo:Data/Foo.hs exe:foo:Data/Foo.hs+     -- > cabal build lib:foo:Data.Foo exe:foo:Data.Foo+     --+   | UserBuildTargetTriple String String String+  deriving (Show, Eq, Ord)+++-- ------------------------------------------------------------+-- * Resolved build targets+-- ------------------------------------------------------------++-- | A fully resolved build target.+--+data BuildTarget =++     -- | A specific component+     --+     BuildTargetComponent ComponentName++     -- | A specific module within a specific component.+     --+   | BuildTargetModule ComponentName ModuleName++     -- | A specific file within a specific component.+     --+   | BuildTargetFile ComponentName FilePath+  deriving (Show,Eq)+++-- ------------------------------------------------------------+-- * Do everything+-- ------------------------------------------------------------++readBuildTargets :: PackageDescription -> [String] -> IO [BuildTarget]+readBuildTargets pkg targetStrs = do+    let (uproblems, utargets) = readUserBuildTargets targetStrs+    reportUserBuildTargetProblems uproblems++    utargets' <- mapM checkTargetExistsAsFile utargets++    let (bproblems, btargets) = resolveBuildTargets pkg utargets'+    reportBuildTargetProblems bproblems++    return btargets++checkTargetExistsAsFile :: UserBuildTarget -> IO (UserBuildTarget, Bool)+checkTargetExistsAsFile t = do+    fexists <- existsAsFile (fileComponentOfTarget t)+    return (t, fexists)++  where+    existsAsFile f = do+      exists <- doesFileExist f+      case splitPath f of+        (d:_)   | hasTrailingPathSeparator d -> doesDirectoryExist d+        (d:_:_) | not exists                 -> doesDirectoryExist d+        _                                    -> return exists++    fileComponentOfTarget (UserBuildTargetSingle     s1) = s1+    fileComponentOfTarget (UserBuildTargetDouble _   s2) = s2+    fileComponentOfTarget (UserBuildTargetTriple _ _ s3) = s3+++-- ------------------------------------------------------------+-- * Parsing user targets+-- ------------------------------------------------------------++readUserBuildTargets :: [String] -> ([UserBuildTargetProblem]+                                    ,[UserBuildTarget])+readUserBuildTargets = partitionEithers . map readUserBuildTarget++readUserBuildTarget :: String -> Either UserBuildTargetProblem+                                        UserBuildTarget+readUserBuildTarget targetstr =+    case readPToMaybe parseTargetApprox targetstr of+      Nothing  -> Left  (UserBuildTargetUnrecognised targetstr)+      Just tgt -> Right tgt++  where+    parseTargetApprox :: Parse.ReadP r UserBuildTarget+    parseTargetApprox =+          (do a <- tokenQ+              return (UserBuildTargetSingle a))+      +++ (do a <- token+              _ <- Parse.char ':'+              b <- tokenQ+              return (UserBuildTargetDouble a b))+      +++ (do a <- token+              _ <- Parse.char ':'+              b <- token+              _ <- Parse.char ':'+              c <- tokenQ+              return (UserBuildTargetTriple a b c))++    token  = Parse.munch1 (\x -> not (isSpace x) && x /= ':')+    tokenQ = parseHaskellString <++ token+    parseHaskellString :: Parse.ReadP r String+    parseHaskellString = Parse.readS_to_P reads++    readPToMaybe :: Parse.ReadP a a -> String -> Maybe a+    readPToMaybe p str = listToMaybe [ r | (r,s) <- Parse.readP_to_S p str+                                         , all isSpace s ]++data UserBuildTargetProblem+   = UserBuildTargetUnrecognised String+  deriving Show++reportUserBuildTargetProblems :: [UserBuildTargetProblem] -> IO ()+reportUserBuildTargetProblems problems = do+    case [ target | UserBuildTargetUnrecognised target <- problems ] of+      []     -> return ()+      target ->+        die $ unlines+                [ "Unrecognised build target '" ++ name ++ "'."+                | name <- target ]+           ++ "Examples:\n"+           ++ " - build foo          -- component name "+           ++ "(library, executable, test-suite or benchmark)\n"+           ++ " - build Data.Foo     -- module name\n"+           ++ " - build Data/Foo.hsc -- file name\n"+           ++ " - build lib:foo exe:foo   -- component qualified by kind\n"+           ++ " - build foo:Data.Foo      -- module qualified by component\n"+           ++ " - build foo:Data/Foo.hsc  -- file qualified by component"++showUserBuildTarget :: UserBuildTarget -> String+showUserBuildTarget = intercalate ":" . components+  where+    components (UserBuildTargetSingle s1)       = [s1]+    components (UserBuildTargetDouble s1 s2)    = [s1,s2]+    components (UserBuildTargetTriple s1 s2 s3) = [s1,s2,s3]+++-- ------------------------------------------------------------+-- * Resolving user targets to build targets+-- ------------------------------------------------------------++{-+stargets =+  [ BuildTargetComponent (CExeName "foo")+  , BuildTargetModule    (CExeName "foo") (mkMn "Foo")+  , BuildTargetModule    (CExeName "tst") (mkMn "Foo")+  ]+    where+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse++ex_pkgid :: PackageIdentifier+Just ex_pkgid = simpleParse "thelib"+-}++-- | Given a bunch of user-specified targets, try to resolve what it is they+-- refer to.+--+resolveBuildTargets :: PackageDescription+                    -> [(UserBuildTarget, Bool)]+                    -> ([BuildTargetProblem], [BuildTarget])+resolveBuildTargets pkg = partitionEithers+                        . map (uncurry (resolveBuildTarget pkg))++resolveBuildTarget :: PackageDescription -> UserBuildTarget -> Bool+                   -> Either BuildTargetProblem BuildTarget+resolveBuildTarget pkg userTarget fexists =+    case findMatch (matchBuildTarget pkg userTarget fexists) of+      Unambiguous target  -> Right target+      Ambiguous   targets -> Left (BuildTargetAmbigious userTarget targets')+                               where targets' = disambiguateBuildTargets+                                                    (packageId pkg) userTarget+                                                    targets+      None        errs    -> Left (classifyMatchErrors errs)++  where+    classifyMatchErrors errs+      | not (null expected) = let (things, got:_) = unzip expected in+                              BuildTargetExpected userTarget things got+      | not (null nosuch)   = BuildTargetNoSuch   userTarget nosuch+      | otherwise = error $ "resolveBuildTarget: internal error in matching"+      where+        expected = [ (thing, got) | MatchErrorExpected thing got <- errs ]+        nosuch   = [ (thing, got) | MatchErrorNoSuch   thing got <- errs ]+++data BuildTargetProblem+   = BuildTargetExpected  UserBuildTarget [String]  String+     -- ^  [expected thing] (actually got)+   | BuildTargetNoSuch    UserBuildTarget [(String, String)]+     -- ^ [(no such thing,  actually got)]+   | BuildTargetAmbigious UserBuildTarget [(UserBuildTarget, BuildTarget)]+  deriving Show+++disambiguateBuildTargets :: PackageId -> UserBuildTarget -> [BuildTarget]+                         -> [(UserBuildTarget, BuildTarget)]+disambiguateBuildTargets pkgid original =+    disambiguate (userTargetQualLevel original)+  where+    disambiguate ql ts+        | null amb  = unamb+        | otherwise = unamb ++ disambiguate (succ ql) amb+      where+        (amb, unamb) = step ql ts++    userTargetQualLevel (UserBuildTargetSingle _    ) = QL1+    userTargetQualLevel (UserBuildTargetDouble _ _  ) = QL2+    userTargetQualLevel (UserBuildTargetTriple _ _ _) = QL3++    step  :: QualLevel -> [BuildTarget]+          -> ([BuildTarget], [(UserBuildTarget, BuildTarget)])+    step ql = (\(amb, unamb) -> (map snd $ concat amb, concat unamb))+            . partition (\g -> length g > 1)+            . groupBy (equating fst)+            . sortBy (comparing fst)+            . map (\t -> (renderBuildTarget ql t pkgid, t))++data QualLevel = QL1 | QL2 | QL3+  deriving (Enum, Show)++renderBuildTarget :: QualLevel -> BuildTarget -> PackageId -> UserBuildTarget+renderBuildTarget ql target pkgid =+    case ql of+      QL1 -> UserBuildTargetSingle s1        where  s1          = single target+      QL2 -> UserBuildTargetDouble s1 s2     where (s1, s2)     = double target+      QL3 -> UserBuildTargetTriple s1 s2 s3  where (s1, s2, s3) = triple target++  where+    single (BuildTargetComponent cn  ) = dispCName cn+    single (BuildTargetModule    _  m) = display m+    single (BuildTargetFile      _  f) = f++    double (BuildTargetComponent cn  ) = (dispKind cn, dispCName cn)+    double (BuildTargetModule    cn m) = (dispCName cn, display m)+    double (BuildTargetFile      cn f) = (dispCName cn, f)++    triple (BuildTargetComponent _   ) = error "triple BuildTargetComponent"+    triple (BuildTargetModule    cn m) = (dispKind cn, dispCName cn, display m)+    triple (BuildTargetFile      cn f) = (dispKind cn, dispCName cn, f)++    dispCName = componentStringName pkgid+    dispKind  = showComponentKindShort . componentKind++reportBuildTargetProblems :: [BuildTargetProblem] -> IO ()+reportBuildTargetProblems problems = do++    case [ (t, e, g) | BuildTargetExpected t e g <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Unrecognised build target '" ++ showUserBuildTarget target+            ++ "'.\n"+            ++ "Expected a " ++ intercalate " or " expected+            ++ ", rather than '" ++ got ++ "'."+          | (target, expected, got) <- targets ]++    case [ (t, e) | BuildTargetNoSuch t e <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Unknown build target '" ++ showUserBuildTarget target+            ++ "'.\nThere is no "+            ++ intercalate " or " [ mungeThing thing ++ " '" ++ got ++ "'"+                                  | (thing, got) <- nosuch ] ++ "."+          | (target, nosuch) <- targets ]+        where+          mungeThing "file" = "file target"+          mungeThing thing  = thing++    case [ (t, ts) | BuildTargetAmbigious t ts <- problems ] of+      []      -> return ()+      targets ->+        die $ unlines+          [    "Ambiguous build target '" ++ showUserBuildTarget target+            ++ "'. It could be:\n "+            ++ unlines [ "   "++ showUserBuildTarget ut +++                         " (" ++ showBuildTargetKind bt ++ ")"+                       | (ut, bt) <- amb ]+          | (target, amb) <- targets ]++  where+    showBuildTargetKind (BuildTargetComponent _  ) = "component"+    showBuildTargetKind (BuildTargetModule    _ _) = "module"+    showBuildTargetKind (BuildTargetFile      _ _) = "file"+++----------------------------------+-- Top level BuildTarget matcher+--++matchBuildTarget :: PackageDescription+                 -> UserBuildTarget -> Bool -> Match BuildTarget+matchBuildTarget pkg = \utarget fexists ->+    case utarget of+      UserBuildTargetSingle str1 ->+        matchBuildTarget1 cinfo str1 fexists++      UserBuildTargetDouble str1 str2 ->+        matchBuildTarget2 cinfo str1 str2 fexists++      UserBuildTargetTriple str1 str2 str3 ->+        matchBuildTarget3 cinfo str1 str2 str3 fexists+  where+    cinfo = pkgComponentInfo pkg++matchBuildTarget1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget+matchBuildTarget1 cinfo str1 fexists =+                        matchComponent1 cinfo str1+   `matchPlusShadowing` matchModule1    cinfo str1+   `matchPlusShadowing` matchFile1      cinfo str1 fexists+++matchBuildTarget2 :: [ComponentInfo] -> String -> String -> Bool+                  -> Match BuildTarget+matchBuildTarget2 cinfo str1 str2 fexists =+                        matchComponent2 cinfo str1 str2+   `matchPlusShadowing` matchModule2    cinfo str1 str2+   `matchPlusShadowing` matchFile2      cinfo str1 str2 fexists+++matchBuildTarget3 :: [ComponentInfo] -> String -> String -> String -> Bool+                  -> Match BuildTarget+matchBuildTarget3 cinfo str1 str2 str3 fexists =+                        matchModule3    cinfo str1 str2 str3+   `matchPlusShadowing` matchFile3      cinfo str1 str2 str3 fexists+++data ComponentInfo = ComponentInfo {+       cinfoName    :: ComponentName,+       cinfoStrName :: ComponentStringName,+       cinfoSrcDirs :: [FilePath],+       cinfoModules :: [ModuleName],+       cinfoHsFiles :: [FilePath],   -- other hs files (like main.hs)+       cinfoCFiles  :: [FilePath]+     }++type ComponentStringName = String++pkgComponentInfo :: PackageDescription -> [ComponentInfo]+pkgComponentInfo pkg =+    [ ComponentInfo {+        cinfoName    = componentName c,+        cinfoStrName = componentStringName pkg (componentName c),+        cinfoSrcDirs = hsSourceDirs bi,+        cinfoModules = componentModules c,+        cinfoHsFiles = componentHsFiles c,+        cinfoCFiles  = cSources bi+      }+    | c <- pkgComponents pkg+    , let bi = componentBuildInfo c ]++componentStringName :: Package pkg => pkg -> ComponentName -> ComponentStringName+componentStringName pkg CLibName          = display (packageName pkg)+componentStringName _   (CExeName  name)  = name+componentStringName _   (CTestName  name) = name+componentStringName _   (CBenchName name) = name++componentModules :: Component -> [ModuleName]+componentModules (CLib   lib)   = libModules lib+componentModules (CExe   exe)   = exeModules exe+componentModules (CTest  test)  = testModules test+componentModules (CBench bench) = benchmarkModules bench++componentHsFiles :: Component -> [FilePath]+componentHsFiles (CExe exe) = [modulePath exe]+componentHsFiles (CTest  TestSuite {+                           testInterface = TestSuiteExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles (CBench Benchmark {+                           benchmarkInterface = BenchmarkExeV10 _ mainfile+                         }) = [mainfile]+componentHsFiles _          = []++{-+ex_cs :: [ComponentInfo]+ex_cs =+  [ (mkC (CExeName "foo") ["src1", "src1/src2"] ["Foo", "Src2.Bar", "Bar"])+  , (mkC (CExeName "tst") ["src1", "test"]      ["Foo"])+  ]+    where+    mkC n ds ms = ComponentInfo n (componentStringName pkgid n) ds (map mkMn ms)+    mkMn :: String -> ModuleName+    mkMn  = fromJust . simpleParse+    pkgid :: PackageIdentifier+    Just pkgid = simpleParse "thelib"+-}++------------------------------+-- Matching component kinds+--++data ComponentKind = LibKind | ExeKind | TestKind | BenchKind+  deriving (Eq, Ord, Show)++componentKind :: ComponentName -> ComponentKind+componentKind CLibName       = LibKind+componentKind (CExeName  _)  = ExeKind+componentKind (CTestName  _) = TestKind+componentKind (CBenchName _) = BenchKind++cinfoKind :: ComponentInfo -> ComponentKind+cinfoKind = componentKind . cinfoName++matchComponentKind :: String -> Match ComponentKind+matchComponentKind s+  | s `elem` ["lib", "library"]            = increaseConfidence >> return LibKind+  | s `elem` ["exe", "executable"]         = increaseConfidence >> return ExeKind+  | s `elem` ["tst", "test", "test-suite"] = increaseConfidence+                                             >> return TestKind+  | s `elem` ["bench", "benchmark"]        = increaseConfidence+                                             >> return BenchKind+  | otherwise                              = matchErrorExpected+                                             "component kind" s++showComponentKind :: ComponentKind -> String+showComponentKind LibKind   = "library"+showComponentKind ExeKind   = "executable"+showComponentKind TestKind  = "test-suite"+showComponentKind BenchKind = "benchmark"++showComponentKindShort :: ComponentKind -> String+showComponentKindShort LibKind   = "lib"+showComponentKindShort ExeKind   = "exe"+showComponentKindShort TestKind  = "test"+showComponentKindShort BenchKind = "bench"++------------------------------+-- Matching component targets+--++matchComponent1 :: [ComponentInfo] -> String -> Match BuildTarget+matchComponent1 cs = \str1 -> do+    guardComponentName str1+    c <- matchComponentName cs str1+    return (BuildTargetComponent (cinfoName c))++matchComponent2 :: [ComponentInfo] -> String -> String -> Match BuildTarget+matchComponent2 cs = \str1 str2 -> do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    return (BuildTargetComponent (cinfoName c))++-- utils:++guardComponentName :: String -> Match ()+guardComponentName s+  | all validComponentChar s+    && not (null s)  = increaseConfidence+  | otherwise        = matchErrorExpected "component name" s+  where+    validComponentChar c = isAlphaNum c || c == '.'+                        || c == '_' || c == '-' || c == '\''++matchComponentName :: [ComponentInfo] -> String -> Match ComponentInfo+matchComponentName cs str =+    orNoSuchThing "component" str+  $ increaseConfidenceFor+  $ matchInexactly caseFold+      [ (cinfoStrName c, c) | c <- cs ]+      str++matchComponentKindAndName :: [ComponentInfo] -> ComponentKind -> String+                          -> Match ComponentInfo+matchComponentKindAndName cs ckind str =+    orNoSuchThing (showComponentKind ckind ++ " component") str+  $ increaseConfidenceFor+  $ matchInexactly (\(ck, cn) -> (ck, caseFold cn))+      [ ((cinfoKind c, cinfoStrName c), c) | c <- cs ]+      (ckind, str)+++------------------------------+-- Matching module targets+--++matchModule1 :: [ComponentInfo] -> String -> Match BuildTarget+matchModule1 cs = \str1 -> do+    guardModuleName str1+    nubMatchErrors $ do+      c <- tryEach cs+      let ms = cinfoModules c+      m <- matchModuleName ms str1+      return (BuildTargetModule (cinfoName c) m)++matchModule2 :: [ComponentInfo] -> String -> String -> Match BuildTarget+matchModule2 cs = \str1 str2 -> do+    guardComponentName str1+    guardModuleName    str2+    c <- matchComponentName cs str1+    let ms = cinfoModules c+    m <- matchModuleName ms str2+    return (BuildTargetModule (cinfoName c) m)++matchModule3 :: [ComponentInfo] -> String -> String -> String+             -> Match BuildTarget+matchModule3 cs str1 str2 str3 = do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    guardModuleName    str3+    let ms = cinfoModules c+    m <- matchModuleName ms str3+    return (BuildTargetModule (cinfoName c) m)++-- utils:++guardModuleName :: String -> Match ()+guardModuleName s+  | all validModuleChar s+    && not (null s)       = increaseConfidence+  | otherwise             = matchErrorExpected "module name" s+  where+    validModuleChar c = isAlphaNum c || c == '.' || c == '_' || c == '\''++matchModuleName :: [ModuleName] -> String -> Match ModuleName+matchModuleName ms str =+    orNoSuchThing "module" str+  $ increaseConfidenceFor+  $ matchInexactly caseFold+      [ (display m, m)+      | m <- ms ]+      str+++------------------------------+-- Matching file targets+--++matchFile1 :: [ComponentInfo] -> String -> Bool -> Match BuildTarget+matchFile1 cs str1 exists =+    nubMatchErrors $ do+      c <- tryEach cs+      filepath <- matchComponentFile c str1 exists+      return (BuildTargetFile (cinfoName c) filepath)+++matchFile2 :: [ComponentInfo] -> String -> String -> Bool -> Match BuildTarget+matchFile2 cs str1 str2 exists = do+    guardComponentName str1+    c <- matchComponentName cs str1+    filepath <- matchComponentFile c str2 exists+    return (BuildTargetFile (cinfoName c) filepath)+++matchFile3 :: [ComponentInfo] -> String -> String -> String -> Bool+           -> Match BuildTarget+matchFile3 cs str1 str2 str3 exists = do+    ckind <- matchComponentKind str1+    guardComponentName str2+    c <- matchComponentKindAndName cs ckind str2+    filepath <- matchComponentFile c str3 exists+    return (BuildTargetFile (cinfoName c) filepath)+++matchComponentFile :: ComponentInfo -> String -> Bool -> Match FilePath+matchComponentFile c str fexists =+    expecting "file" str $+      matchPlus+        (matchFileExists str fexists)+        (matchPlusShadowing+          (msum [ matchModuleFileRooted   dirs ms      str+                , matchOtherFileRooted    dirs hsFiles str ])+          (msum [ matchModuleFileUnrooted      ms      str+                , matchOtherFileUnrooted       hsFiles str+                , matchOtherFileUnrooted       cFiles  str ]))+  where+    dirs = cinfoSrcDirs c+    ms   = cinfoModules c+    hsFiles = cinfoHsFiles c+    cFiles  = cinfoCFiles c+++-- utils++matchFileExists :: FilePath -> Bool -> Match a+matchFileExists _     False = mzero+matchFileExists fname True  = do increaseConfidence+                                 matchErrorNoSuch "file" fname++matchModuleFileUnrooted :: [ModuleName] -> String -> Match FilePath+matchModuleFileUnrooted ms str = do+    let filepath = normalise str+    _ <- matchModuleFileStem ms filepath+    return filepath++matchModuleFileRooted :: [FilePath] -> [ModuleName] -> String -> Match FilePath+matchModuleFileRooted dirs ms str = nubMatches $ do+    let filepath = normalise str+    filepath' <- matchDirectoryPrefix dirs filepath+    _ <- matchModuleFileStem ms filepath'+    return filepath++matchModuleFileStem :: [ModuleName] -> FilePath -> Match ModuleName+matchModuleFileStem ms =+      increaseConfidenceFor+    . matchInexactly caseFold+        [ (toFilePath m, m) | m <- ms ]+    . dropExtension++matchOtherFileRooted :: [FilePath] -> [FilePath] -> FilePath -> Match FilePath+matchOtherFileRooted dirs fs str = do+    let filepath = normalise str+    filepath' <- matchDirectoryPrefix dirs filepath+    _ <- matchFile fs filepath'+    return filepath++matchOtherFileUnrooted :: [FilePath] -> FilePath -> Match FilePath+matchOtherFileUnrooted fs str = do+    let filepath = normalise str+    _ <- matchFile fs filepath+    return filepath++matchFile :: [FilePath] -> FilePath -> Match FilePath+matchFile fs = increaseConfidenceFor+             . matchInexactly caseFold [ (f, f) | f <- fs ]++matchDirectoryPrefix :: [FilePath] -> FilePath -> Match FilePath+matchDirectoryPrefix dirs filepath =+    exactMatches $+      catMaybes+       [ stripDirectory (normalise dir) filepath | dir <- dirs ]+  where+    stripDirectory :: FilePath -> FilePath -> Maybe FilePath+    stripDirectory dir fp =+      joinPath `fmap` stripPrefix (splitDirectories dir) (splitDirectories fp)+++------------------------------+-- Matching monad+--++-- | A matcher embodies a way to match some input as being some recognised+-- value. In particular it deals with multiple and ambigious matches.+--+-- There are various matcher primitives ('matchExactly', 'matchInexactly'),+-- ways to combine matchers ('ambigiousWith', 'shadows') and finally we can+-- run a matcher against an input using 'findMatch'.+--++data Match a = NoMatch      Confidence [MatchError]+             | ExactMatch   Confidence [a]+             | InexactMatch Confidence [a]+  deriving Show++type Confidence = Int++data MatchError = MatchErrorExpected String String+                | MatchErrorNoSuch   String String+  deriving (Show, Eq)+++instance Alternative Match where+      empty = mzero+      (<|>) = mplus++instance MonadPlus Match where+  mzero = matchZero+  mplus = matchPlus++matchZero :: Match a+matchZero = NoMatch 0 []++-- | Combine two matchers. Exact matches are used over inexact matches+-- but if we have multiple exact, or inexact then the we collect all the+-- ambigious matches.+--+matchPlus :: Match a -> Match a -> Match a+matchPlus   (ExactMatch   d1 xs)   (ExactMatch   d2 xs') =+  ExactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(ExactMatch   _  _ )   (InexactMatch _  _  ) = a+matchPlus a@(ExactMatch   _  _ )   (NoMatch      _  _  ) = a+matchPlus   (InexactMatch _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (InexactMatch d1 xs)   (InexactMatch d2 xs') =+  InexactMatch (max d1 d2) (xs ++ xs')+matchPlus a@(InexactMatch _  _ )   (NoMatch      _  _  ) = a+matchPlus   (NoMatch      _  _ ) b@(ExactMatch   _  _  ) = b+matchPlus   (NoMatch      _  _ ) b@(InexactMatch _  _  ) = b+matchPlus a@(NoMatch      d1 ms) b@(NoMatch      d2 ms')+                                             | d1 >  d2  = a+                                             | d1 <  d2  = b+                                             | otherwise = NoMatch d1 (ms ++ ms')++-- | Combine two matchers. This is similar to 'ambigiousWith' with the+-- difference that an exact match from the left matcher shadows any exact+-- match on the right. Inexact matches are still collected however.+--+matchPlusShadowing :: Match a -> Match a -> Match a+matchPlusShadowing a@(ExactMatch _ _) (ExactMatch _ _) = a+matchPlusShadowing a                   b               = matchPlus a b++instance Functor Match where+  fmap _ (NoMatch      d ms) = NoMatch      d ms+  fmap f (ExactMatch   d xs) = ExactMatch   d (fmap f xs)+  fmap f (InexactMatch d xs) = InexactMatch d (fmap f xs)++instance Applicative Match where+  pure = return+  (<*>) = ap++instance Monad Match where+  return a                = ExactMatch 0 [a]+  NoMatch      d ms >>= _ = NoMatch d ms+  ExactMatch   d xs >>= f = addDepth d+                          $ foldr matchPlus matchZero (map f xs)+  InexactMatch d xs >>= f = addDepth d .  forceInexact+                          $ foldr matchPlus matchZero (map f xs)++addDepth :: Confidence -> Match a -> Match a+addDepth d' (NoMatch      d msgs) = NoMatch      (d'+d) msgs+addDepth d' (ExactMatch   d xs)   = ExactMatch   (d'+d) xs+addDepth d' (InexactMatch d xs)   = InexactMatch (d'+d) xs++forceInexact :: Match a -> Match a+forceInexact (ExactMatch d ys) = InexactMatch d ys+forceInexact m                 = m++------------------------------+-- Various match primitives+--++matchErrorExpected, matchErrorNoSuch :: String -> String -> Match a+matchErrorExpected thing got = NoMatch 0 [MatchErrorExpected thing got]+matchErrorNoSuch   thing got = NoMatch 0 [MatchErrorNoSuch   thing got]++expecting :: String -> String -> Match a -> Match a+expecting thing got (NoMatch 0 _) = matchErrorExpected thing got+expecting _     _   m             = m++orNoSuchThing :: String -> String -> Match a -> Match a+orNoSuchThing thing got (NoMatch 0 _) = matchErrorNoSuch thing got+orNoSuchThing _     _   m             = m++increaseConfidence :: Match ()+increaseConfidence = ExactMatch 1 [()]++increaseConfidenceFor :: Match a -> Match a+increaseConfidenceFor m = m >>= \r -> increaseConfidence >> return r++nubMatches :: Eq a => Match a -> Match a+nubMatches (NoMatch      d msgs) = NoMatch      d msgs+nubMatches (ExactMatch   d xs)   = ExactMatch   d (nub xs)+nubMatches (InexactMatch d xs)   = InexactMatch d (nub xs)++nubMatchErrors :: Match a -> Match a+nubMatchErrors (NoMatch      d msgs) = NoMatch      d (nub msgs)+nubMatchErrors (ExactMatch   d xs)   = ExactMatch   d xs+nubMatchErrors (InexactMatch d xs)   = InexactMatch d xs++-- | Lift a list of matches to an exact match.+--+exactMatches, inexactMatches :: [a] -> Match a++exactMatches [] = matchZero+exactMatches xs = ExactMatch 0 xs++inexactMatches [] = matchZero+inexactMatches xs = InexactMatch 0 xs++tryEach :: [a] -> Match a+tryEach = exactMatches+++------------------------------+-- Top level match runner+--++-- | Given a matcher and a key to look up, use the matcher to find all the+-- possible matches. There may be 'None', a single 'Unambiguous' match or+-- you may have an 'Ambiguous' match with several possibilities.+--+findMatch :: Eq b => Match b -> MaybeAmbigious b+findMatch match =+    case match of+      NoMatch    _ msgs -> None (nub msgs)+      ExactMatch   _ xs -> checkAmbigious xs+      InexactMatch _ xs -> checkAmbigious xs+  where+    checkAmbigious xs = case nub xs of+                          [x] -> Unambiguous x+                          xs' -> Ambiguous   xs'++data MaybeAmbigious a = None [MatchError] | Unambiguous a | Ambiguous [a]+  deriving Show+++------------------------------+-- Basic matchers+--++{-+-- | A primitive matcher that looks up a value in a finite 'Map'. The+-- value must match exactly.+--+matchExactly :: forall a b. Ord a => [(a, b)] -> (a -> Match b)+matchExactly xs =+    \x -> case Map.lookup x m of+            Nothing -> matchZero+            Just ys -> ExactMatch 0 ys+  where+    m :: Ord a => Map a [b]+    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]+-}++-- | A primitive matcher that looks up a value in a finite 'Map'. It checks+-- for an exact or inexact match. We get an inexact match if the match+-- is not exact, but the canonical forms match. It takes a canonicalisation+-- function for this purpose.+--+-- So for example if we used string case fold as the canonicalisation+-- function, then we would get case insensitive matching (but it will still+-- report an exact match when the case matches too).+--+matchInexactly :: (Ord a, Ord a') =>+                        (a -> a') ->+                        [(a, b)] -> (a -> Match b)+matchInexactly cannonicalise xs =+    \x -> case Map.lookup x m of+            Just ys -> exactMatches ys+            Nothing -> case Map.lookup (cannonicalise x) m' of+                         Just ys -> inexactMatches ys+                         Nothing -> matchZero+  where+    m = Map.fromListWith (++) [ (k,[x]) | (k,x) <- xs ]++    -- the map of canonicalised keys to groups of inexact matches+    m' = Map.mapKeysWith (++) cannonicalise m++++------------------------------+-- Utils+--++caseFold :: String -> String+caseFold = lowercase
+ cabal/Cabal/Distribution/Simple/CCompiler.hs view
@@ -0,0 +1,121 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.CCompiler+-- Copyright   :  2011, Dan Knapp+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This simple package provides types and functions for interacting with+-- C compilers.  Currently it's just a type enumerating extant C-like+-- languages, which we call dialects.++{-+Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are+met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of Isaac Jones nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}++module Distribution.Simple.CCompiler (+   CDialect(..),+   cSourceExtensions,+   cDialectFilenameExtension,+   filenameCDialect+  ) where++import Data.Monoid+     ( Monoid(..) )+import System.FilePath+     ( takeExtension )+++-- | Represents a dialect of C.  The Monoid instance expresses backward+--   compatibility, in the sense that 'mappend a b' is the least inclusive+--   dialect which both 'a' and 'b' can be correctly interpreted as.+data CDialect = C+              | ObjectiveC+              | CPlusPlus+              | ObjectiveCPlusPlus+              deriving (Show)++instance Monoid CDialect where+  mempty = C++  mappend C                  anything           = anything+  mappend ObjectiveC         CPlusPlus          = ObjectiveCPlusPlus+  mappend CPlusPlus          ObjectiveC         = ObjectiveCPlusPlus+  mappend _                  ObjectiveCPlusPlus = ObjectiveCPlusPlus+  mappend ObjectiveC         _                  = ObjectiveC+  mappend CPlusPlus          _                  = CPlusPlus+  mappend ObjectiveCPlusPlus _                  = ObjectiveCPlusPlus+++-- | A list of all file extensions which are recognized as possibly containing+--   some dialect of C code.  Note that this list is only for source files,+--   not for header files.+cSourceExtensions :: [String]+cSourceExtensions = ["c", "i", "ii", "m", "mi", "mm", "M", "mii", "cc", "cp",+                     "cxx", "cpp", "CPP", "c++", "C"]+++-- | Takes a dialect of C and whether code is intended to be passed through+--   the preprocessor, and returns a filename extension for containing that+--   code.+cDialectFilenameExtension :: CDialect -> Bool -> String+cDialectFilenameExtension C True  = "c"+cDialectFilenameExtension C False = "i"+cDialectFilenameExtension ObjectiveC True  = "m"+cDialectFilenameExtension ObjectiveC False = "mi"+cDialectFilenameExtension CPlusPlus True   = "cpp"+cDialectFilenameExtension CPlusPlus False  = "ii"+cDialectFilenameExtension ObjectiveCPlusPlus True  = "mm"+cDialectFilenameExtension ObjectiveCPlusPlus False = "mii"+++-- | Infers from a filename's extension the dialect of C which it contains,+--   and whether it is intended to be passed through the preprocessor.+filenameCDialect :: String -> Maybe (CDialect, Bool)+filenameCDialect filename = do+  extension <- case takeExtension filename of+                 '.':ext -> Just ext+                 _       -> Nothing+  case extension of+    "c"   -> return (C, True)+    "i"   -> return (C, False)+    "ii"  -> return (CPlusPlus, False)+    "m"   -> return (ObjectiveC, True)+    "mi"  -> return (ObjectiveC, False)+    "mm"  -> return (ObjectiveCPlusPlus, True)+    "M"   -> return (ObjectiveCPlusPlus, True)+    "mii" -> return (ObjectiveCPlusPlus, False)+    "cc"  -> return (CPlusPlus, True)+    "cp"  -> return (CPlusPlus, True)+    "cxx" -> return (CPlusPlus, True)+    "cpp" -> return (CPlusPlus, True)+    "CPP" -> return (CPlusPlus, True)+    "c++" -> return (CPlusPlus, True)+    "C"   -> return (CPlusPlus, True)+    _     -> Nothing
cabal/Cabal/Distribution/Simple/Command.hs view
@@ -103,7 +103,8 @@     commandName        :: String,     -- | A short, one line description of the command to use in help texts.     commandSynopsis :: String,-    -- | The useage line summary for this command+    -- | A function that maps a program name to a usage summary for this+    -- command.     commandUsage    :: String -> String,     -- | Additional explanation of the command to use in help texts.     commandDescription :: Maybe (String -> String),@@ -126,12 +127,19 @@   optionName        :: Name,   optionDescr       :: [OptDescr a] } --- | An OptionField takes one or more OptDescrs, describing the command line interface for the field.-data OptDescr a  = ReqArg Description OptFlags ArgPlaceHolder (ReadE (a->a))         (a -> [String])-                 | OptArg Description OptFlags ArgPlaceHolder (ReadE (a->a)) (a->a)  (a -> [Maybe String])+-- | An OptionField takes one or more OptDescrs, describing the command line+-- interface for the field.+data OptDescr a  = ReqArg Description OptFlags ArgPlaceHolder+                   (ReadE (a->a)) (a -> [String])++                 | OptArg Description OptFlags ArgPlaceHolder+                   (ReadE (a->a)) (a->a)  (a -> [Maybe String])+                  | ChoiceOpt [(Description, OptFlags, a->a, a -> Bool)]-                 | BoolOpt Description OptFlags{-True-} OptFlags{-False-} (Bool -> a -> a) (a-> Maybe Bool) +                 | BoolOpt Description OptFlags{-True-} OptFlags{-False-}+                   (Bool -> a -> a) (a-> Maybe Bool)+ -- | Short command line option strings type SFlags   = [Char] -- | Long command line option strings@@ -142,24 +150,30 @@  -- | Create an option taking a single OptDescr. --   No explicit Name is given for the Option, the name is the first LFlag given.-option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a -> OptionField a+option :: SFlags -> LFlags -> Description -> get -> set -> MkOptDescr get set a+          -> OptionField a option sf lf@(n:_) d get set arg = OptionField n [arg sf lf d get set]-option _ _ _ _ _ _ = error "Distribution.command.option: An OptionField must have at least one LFlag"+option _ _ _ _ _ _ = error $ "Distribution.command.option: "+                     ++ "An OptionField must have at least one LFlag"  -- | Create an option taking several OptDescrs.---   You will have to give the flags and description individually to the OptDescr constructor.+--   You will have to give the flags and description individually to the+--   OptDescr constructor. multiOption :: Name -> get -> set-            -> [get -> set -> OptDescr a]  -- ^MkOptDescr constructors partially applied to flags and description.+            -> [get -> set -> OptDescr a]  -- ^MkOptDescr constructors partially+                                           -- applied to flags and description.             -> OptionField a multiOption n get set args = OptionField n [arg get set | arg <- args] -type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set -> OptDescr a+type MkOptDescr get set a = SFlags -> LFlags -> Description -> get -> set+                            -> OptDescr a  -- | Create a string-valued command line interface. reqArg :: Monoid b => ArgPlaceHolder -> ReadE b -> (b -> [String])                    -> MkOptDescr (a -> b) (b -> a -> a) a reqArg ad mkflag showflag sf lf d get set =-  ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag) (showflag . get)+  ReqArg d (sf,lf) ad (fmap (\a b -> set (get b `mappend` a) b) mkflag)+  (showflag . get)  -- | Create a string-valued command line interface with a default value. optArg :: Monoid b => ArgPlaceHolder -> ReadE b -> b -> (b -> [Maybe String])@@ -176,8 +190,9 @@     reqArg ad (succeedReadE mkflag) showflag  -- | (String -> a) variant of "optArg"-optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b) -> (b -> [Maybe String])-                    -> MkOptDescr (a -> b) (b -> a -> a) a+optArg' :: Monoid b => ArgPlaceHolder -> (Maybe String -> b)+           -> (b -> [Maybe String])+           -> MkOptDescr (a -> b) (b -> a -> a) a optArg' ad mkflag showflag =     optArg ad (succeedReadE (mkflag . Just)) def showflag       where def = mkflag Nothing@@ -185,34 +200,42 @@ noArg :: (Eq b, Monoid b) => b -> MkOptDescr (a -> b) (b -> a -> a) a noArg flag sf lf d = choiceOpt [(flag, (sf,lf), d)] sf lf d -boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt :: (b -> Maybe Bool) -> (Bool -> b) -> SFlags -> SFlags+           -> MkOptDescr (a -> b) (b -> a -> a) a boolOpt g s sfT sfF _sf _lf@(n:_) d get set =     BoolOpt d (sfT, ["enable-"++n]) (sfF, ["disable-"++n]) (set.s) (g.get)-boolOpt _ _ _ _ _ _ _ _ _ = error "Distribution.Simple.Setup.boolOpt: unreachable"+boolOpt _ _ _ _ _ _ _ _ _ = error+                            "Distribution.Simple.Setup.boolOpt: unreachable" -boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags -> MkOptDescr (a -> b) (b -> a -> a) a+boolOpt' :: (b -> Maybe Bool) -> (Bool -> b) -> OptFlags -> OptFlags+            -> MkOptDescr (a -> b) (b -> a -> a) a boolOpt' g s ffT ffF _sf _lf d get set = BoolOpt d ffT ffF (set.s) (g . get)  -- | create a Choice option-choiceOpt :: Eq b => [(b,OptFlags,Description)] -> MkOptDescr (a -> b) (b -> a -> a) a+choiceOpt :: Eq b => [(b,OptFlags,Description)]+             -> MkOptDescr (a -> b) (b -> a -> a) a choiceOpt aa_ff _sf _lf _d get set  = ChoiceOpt alts     where alts = [(d,flags, set alt, (==alt) . get) | (alt,flags,d) <- aa_ff]  -- | create a Choice option out of an enumeration type. --   As long flags, the Show output is used. As short flags, the first character --   which does not conflict with a previous one is used.-choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) => MkOptDescr (a -> b) (b -> a -> a) a-choiceOptFromEnum _sf _lf d get = choiceOpt [ (x, (sf, [map toLower $ show x]), d')-                                                | (x, sf) <- sflags'-                                                , let d' = d ++ show x]-                                            _sf _lf d get-    where sflags' = foldl f [] [firstOne..]-          f prev x = let prevflags = concatMap snd prev in-                     prev ++ take 1 [(x, [toLower sf]) | sf <- show x, isAlpha sf-                                                       , toLower sf `notElem` prevflags]-          firstOne = minBound `asTypeOf` get undefined+choiceOptFromEnum :: (Bounded b, Enum b, Show b, Eq b) =>+                     MkOptDescr (a -> b) (b -> a -> a) a+choiceOptFromEnum _sf _lf d get =+  choiceOpt [ (x, (sf, [map toLower $ show x]), d')+            | (x, sf) <- sflags'+            , let d' = d ++ show x]+  _sf _lf d get+  where sflags' = foldl f [] [firstOne..]+        f prev x = let prevflags = concatMap snd prev in+                       prev ++ take 1 [(x, [toLower sf])+                                      | sf <- show x, isAlpha sf+                                      , toLower sf `notElem` prevflags]+        firstOne = minBound `asTypeOf` get undefined -commandGetOpts :: ShowOrParseArgs -> CommandUI flags -> [GetOpt.OptDescr (flags -> flags)]+commandGetOpts :: ShowOrParseArgs -> CommandUI flags+                  -> [GetOpt.OptDescr (flags -> flags)] commandGetOpts showOrParse command =     concatMap viewAsGetOpt (commandOptions command showOrParse) @@ -232,53 +255,72 @@          [ GetOpt.Option sfT lfT (GetOpt.NoArg (set True))  ("Enable " ++ d)          , GetOpt.Option sfF lfF (GetOpt.NoArg (set False)) ("Disable " ++ d) ] --- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool > Choice > Opt) and consider only the first one.+-- | to view as a FieldDescr, we sort the list of interfaces (Req > Bool >+-- Choice > Opt) and consider only the first one. viewAsFieldDescr :: OptionField a -> FieldDescr a-viewAsFieldDescr (OptionField _n []) = error "Distribution.command.viewAsFieldDescr: unexpected"+viewAsFieldDescr (OptionField _n []) =+  error "Distribution.command.viewAsFieldDescr: unexpected" viewAsFieldDescr (OptionField n dd) = FieldDescr n get set-    where optDescr = head $ sortBy cmp dd-          ReqArg{}    `cmp` ReqArg{}    = EQ-          ReqArg{}    `cmp` _           = GT-          BoolOpt{}   `cmp` ReqArg{}    = LT-          BoolOpt{}   `cmp` BoolOpt{}   = EQ-          BoolOpt{}   `cmp` _           = GT-          ChoiceOpt{} `cmp` ReqArg{}    = LT-          ChoiceOpt{} `cmp` BoolOpt{}   = LT-          ChoiceOpt{} `cmp` ChoiceOpt{} = EQ-          ChoiceOpt{} `cmp` _           = GT-          OptArg{}    `cmp` OptArg{}    = EQ-          OptArg{}    `cmp` _           = LT-          get t = case optDescr of-                    ReqArg _ _ _ _ ppr ->-                     (cat . punctuate comma . map text . ppr) t-                    OptArg _ _ _ _ _ ppr ->-                     case ppr t of-                        []        -> empty+    where+      optDescr = head $ sortBy cmp dd++      cmp :: OptDescr a -> OptDescr a -> Ordering+      ReqArg{}    `cmp` ReqArg{}    = EQ+      ReqArg{}    `cmp` _           = GT+      BoolOpt{}   `cmp` ReqArg{}    = LT+      BoolOpt{}   `cmp` BoolOpt{}   = EQ+      BoolOpt{}   `cmp` _           = GT+      ChoiceOpt{} `cmp` ReqArg{}    = LT+      ChoiceOpt{} `cmp` BoolOpt{}   = LT+      ChoiceOpt{} `cmp` ChoiceOpt{} = EQ+      ChoiceOpt{} `cmp` _           = GT+      OptArg{}    `cmp` OptArg{}    = EQ+      OptArg{}    `cmp` _           = LT++--    get :: a -> Doc+      get t = case optDescr of+        ReqArg _ _ _ _ ppr ->+          (cat . punctuate comma . map text . ppr) t++        OptArg _ _ _ _ _ ppr ->+          case ppr t of []        -> empty                         (Nothing : _) -> text "True"                         (Just a  : _) -> text a-                    ChoiceOpt alts ->-                     fromMaybe empty $ listToMaybe-                         [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]-                    BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t-          set line val a =-                  case optDescr of-                    ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE val-                                             -- We parse for a single value instead of a list,-                                             -- as one can't really implement parseList :: ReadE a -> ReadE [a]-                                             -- with the current ReadE definition-                    ChoiceOpt{}             -> case getChoiceByLongFlag optDescr val of-                                                 Just f -> return (f a)-                                                 _      -> syntaxError line val-                    BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runP line n parse val-                    OptArg _ _ _  readE _ _ -> ($ a) `liftM` runE line n readE val-                                             -- Optional arguments are parsed just like required arguments here;-                                             -- we don't provide a method to set an OptArg field to the default value. +        ChoiceOpt alts ->+          fromMaybe empty $ listToMaybe+          [ text lf | (_,(_,lf:_), _,enabled) <- alts, enabled t]++        BoolOpt _ _ _ _ enabled -> (maybe empty disp . enabled) t++--    set :: LineNo -> String -> a -> ParseResult a+      set line val a =+        case optDescr of+          ReqArg _ _ _ readE _    -> ($ a) `liftM` runE line n readE val+                                     -- We parse for a single value instead of a+                                     -- list, as one can't really implement+                                     -- parseList :: ReadE a -> ReadE [a] with+                                     -- the current ReadE definition+          ChoiceOpt{}             ->+            case getChoiceByLongFlag optDescr val of+              Just f -> return (f a)+              _      -> syntaxError line val++          BoolOpt _ _ _ setV _    -> (`setV` a) `liftM` runP line n parse val++          OptArg _ _ _  readE _ _ -> ($ a) `liftM` runE line n readE val+                                     -- Optional arguments are parsed just like+                                     -- required arguments here; we don't+                                     -- provide a method to set an OptArg field+                                     -- to the default value.+ getChoiceByLongFlag :: OptDescr b -> String -> Maybe (b->b)-getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe [ set | (_,(_sf,lf:_), set, _) <- alts-                                                             , lf == val]+getChoiceByLongFlag (ChoiceOpt alts) val = listToMaybe+                                           [ set | (_,(_sf,lf:_), set, _) <- alts+                                                 , lf == val] -getChoiceByLongFlag _ _ = error "Distribution.command.getChoiceByLongFlag: expected a choice option"+getChoiceByLongFlag _ _ =+  error "Distribution.command.getChoiceByLongFlag: expected a choice option"  getCurrentChoice :: OptDescr a -> a -> [String] getCurrentChoice (ChoiceOpt alts) a =@@ -288,7 +330,8 @@   liftOption :: (b -> a) -> (a -> (b -> b)) -> OptionField a -> OptionField b-liftOption get' set' opt = opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}+liftOption get' set' opt =+  opt { optionDescr = liftOptDescr get' set' `map` optionDescr opt}   liftOptDescr :: (b -> a) -> (a -> (b -> b)) -> OptDescr a -> OptDescr b@@ -297,7 +340,8 @@               | (d, ff, set, get) <- opts]  liftOptDescr get' set' (OptArg d ff ad set def get) =-    OptArg d ff ad (liftSet get' set' `fmap` set) (liftSet get' set' def) (get . get')+    OptArg d ff ad (liftSet get' set' `fmap` set)+    (liftSet get' set' def) (get . get')  liftOptDescr get' set' (ReqArg d ff ad set get) =     ReqArg d ff ad (liftSet get' set' `fmap` set) (get . get')@@ -497,7 +541,7 @@     badCommand cname = CommandErrors ["unrecognised command: " ++ cname                                    ++ " (try --help)\n"]     commands'      = commands ++ [commandAddAction helpCommandUI undefined]-    commandNames   = [ name | (Command name _ _ _) <- commands' ]+    commandNames   = [ name | (Command name _ _ NormalCommand) <- commands' ]     globalCommand' = globalCommand {       commandUsage = \pname ->            (case commandUsage globalCommand pname of@@ -537,7 +581,7 @@       where globalHelp = commandHelp globalCommand'     helpCommandUI =-      (makeCommand "help" "Help about commands" Nothing () (const [])) {+      (makeCommand "help" "Help about commands." Nothing () (const [])) {         commandUsage = \pname ->              "Usage: " ++ pname ++ " help [FLAGS]\n"           ++ "   or: " ++ pname ++ " help COMMAND [FLAGS]\n\n"
cabal/Cabal/Distribution/Simple/Compiler.hs view
@@ -57,6 +57,8 @@         PackageDB(..),         PackageDBStack,         registrationPackageDB,+        absolutePackageDBPaths,+        absolutePackageDBPath,          -- * Support for optimisation levels         OptimisationLevel(..),@@ -67,7 +69,8 @@         languageToFlags,         unsupportedLanguages,         extensionsToFlags,-        unsupportedExtensions+        unsupportedExtensions,+        parmakeSupported   ) where  import Distribution.Compiler@@ -75,13 +78,21 @@ import Distribution.Text (display) import Language.Haskell.Extension (Language(Haskell98), Extension) +import Control.Monad (liftM) import Data.List (nub)+import qualified Data.Map as M (Map, lookup) import Data.Maybe (catMaybes, isNothing)+import System.Directory (canonicalizePath)  data Compiler = Compiler {         compilerId              :: CompilerId,+        -- ^ Compiler flavour and version.         compilerLanguages       :: [(Language, Flag)],-        compilerExtensions      :: [(Extension, Flag)]+        -- ^ Supported language standards.+        compilerExtensions      :: [(Extension, Flag)],+        -- ^ Supported extensions.+        compilerProperties      :: M.Map String String+        -- ^ A key-value map for properties not covered by the above fields.     }     deriving (Show, Read) @@ -135,6 +146,18 @@ registrationPackageDB []  = error "internal error: empty package db set" registrationPackageDB dbs = last dbs +-- | Make package paths absolute+++absolutePackageDBPaths :: PackageDBStack -> IO PackageDBStack+absolutePackageDBPaths = mapM absolutePackageDBPath++absolutePackageDBPath :: PackageDB -> IO PackageDB+absolutePackageDBPath GlobalPackageDB        = return GlobalPackageDB+absolutePackageDBPath UserPackageDB          = return UserPackageDB+absolutePackageDBPath (SpecificPackageDB db) =+  SpecificPackageDB `liftM` canonicalizePath db+ -- ------------------------------------------------------------ -- * Optimisation levels -- ------------------------------------------------------------@@ -192,3 +215,12 @@  extensionToFlag :: Compiler -> Extension -> Maybe Flag extensionToFlag comp ext = lookup ext (compilerExtensions comp)++-- | Does this compiler support parallel --make mode?+parmakeSupported :: Compiler -> Bool+parmakeSupported comp =+  case compilerFlavor comp of+    GHC -> case M.lookup "Support parallel --make" (compilerProperties comp) of+      Just "YES" -> True+      _          -> False+    _   -> False
cabal/Cabal/Distribution/Simple/Configure.hs view
@@ -54,26 +54,35 @@                                       writePersistBuildConfig,                                       getPersistBuildConfig,                                       checkPersistBuildConfigOutdated,+                                      tryGetPersistBuildConfig,                                       maybeGetPersistBuildConfig,                                       localBuildInfoFile,-                                      getInstalledPackages,+                                      getInstalledPackages, getPackageDBContents,                                       configCompiler, configCompilerAux,+                                      configCompilerEx, configCompilerAuxEx,                                       ccLdOptionsBuildInfo,-                                      tryGetConfigStateFile,                                       checkForeignDeps,                                       interpretPackageDbFlags,++                                      ConfigStateFileErrorType(..),+                                      ConfigStateFileError,+                                      tryGetConfigStateFile,+                                      platformDefines,                                      )     where +import Distribution.Compiler+    ( CompilerId(..) ) import Distribution.Simple.Compiler     ( CompilerFlavor(..), Compiler(compilerId), compilerFlavor, compilerVersion     , showCompilerId, unsupportedLanguages, unsupportedExtensions     , PackageDB(..), PackageDBStack )+import Distribution.Simple.PreProcess ( platformDefines ) import Distribution.Package     ( PackageName(PackageName), PackageIdentifier(..), PackageId     , packageName, packageVersion, Package(..)     , Dependency(Dependency), simplifyDependency-    , InstalledPackageId(..) )+    , InstalledPackageId(..), thisPackageVersion ) import Distribution.InstalledPackageInfo as Installed     ( InstalledPackageInfo, InstalledPackageInfo_(..)     , emptyInstalledPackageInfo )@@ -83,7 +92,7 @@     ( PackageDescription(..), specVersion, GenericPackageDescription(..)     , Library(..), hasLibs, Executable(..), BuildInfo(..), allExtensions     , HookedBuildInfo, updatePackageDescription, allBuildInfo-    , FlagName(..), TestSuite(..), Benchmark(..) )+    , Flag(flagName), FlagName(..), TestSuite(..), Benchmark(..) ) import Distribution.PackageDescription.Configuration     ( finalizePackageDescription, mapTreeData ) import Distribution.PackageDescription.Check@@ -92,6 +101,7 @@ import Distribution.Simple.Program     ( Program(..), ProgramLocation(..), ConfiguredProgram(..)     , ProgramConfiguration, defaultProgramConfiguration+    , ProgramSearchPathEntry(..), getProgramSearchPath, setProgramSearchPath     , configureAllKnownPrograms, knownPrograms, lookupKnownProgram     , userSpecifyArgss, userSpecifyPaths     , requireProgram, requireProgramVersion@@ -101,18 +111,21 @@ import Distribution.Simple.InstallDirs     ( InstallDirs(..), defaultInstallDirs, combineInstallDirs ) import Distribution.Simple.LocalBuildInfo-    ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+    ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)+    , LibraryName(..)     , absoluteInstallDirs, prefixRelativeInstallDirs, inplacePackageId-    , allComponentsBy, Component(..), foldComponent, ComponentName(..) )+    , ComponentName(..), showComponentName, pkgEnabledComponents+    , componentBuildInfo, componentName, checkComponentsCyclic ) import Distribution.Simple.BuildPaths     ( autogenModulesDir ) import Distribution.Simple.Utils-    ( die, warn, info, setupMessage, createDirectoryIfMissingVerbose+    ( die, warn, info, setupMessage+    , createDirectoryIfMissingVerbose, moreRecentFile     , intercalate, cabalVersion     , withFileContents, writeFileAtomic     , withTempFile ) import Distribution.System-    ( OS(..), buildOS, Arch(..), buildArch, buildPlatform )+    ( OS(..), buildOS, Platform, buildPlatform ) import Distribution.Version          ( Version(..), anyVersion, orLaterVersion, withinRange, isAnyVersion ) import Distribution.Verbosity@@ -124,56 +137,65 @@ import qualified Distribution.Simple.NHC  as NHC import qualified Distribution.Simple.Hugs as Hugs import qualified Distribution.Simple.UHC  as UHC+import qualified Distribution.Simple.HaskellSuite as HaskellSuite  import Control.Monad-    ( when, unless, foldM, filterM, forM )+    ( when, unless, foldM, filterM ) import Data.List-    ( nub, partition, isPrefixOf, inits, find )+    ( (\\), nub, partition, isPrefixOf, inits ) import Data.Maybe-    ( isNothing, catMaybes, mapMaybe )+    ( isNothing, catMaybes, fromMaybe ) import Data.Monoid     ( Monoid(..) )-import Data.Graph-    ( SCC(..), graphFromEdges, transposeG, vertices, stronglyConnCompR )+import qualified Data.Map as Map+import Data.Map (Map) import System.Directory-    ( doesFileExist, getModificationTime, createDirectoryIfMissing, getTemporaryDirectory )-import System.Exit-    ( ExitCode(..), exitWith )+    ( doesFileExist, createDirectoryIfMissing, getTemporaryDirectory ) import System.FilePath     ( (</>), isAbsolute ) import qualified System.Info     ( compilerName, compilerVersion ) import System.IO-    ( hPutStrLn, stderr, hClose )+    ( hPutStrLn, hClose ) import Distribution.Text     ( Text(disp), display, simpleParse ) import Text.PrettyPrint-    ( comma, punctuate, render, nest, sep )+    ( render, (<>), ($+$), char, text, comma+    , quotes, punctuate, nest, sep, hsep ) import Distribution.Compat.Exception ( catchExit, catchIO )  import qualified Data.ByteString.Lazy.Char8 as BS.Char8 -tryGetConfigStateFile :: (Read a) => FilePath -> IO (Either String a)+data ConfigStateFileErrorType = ConfigStateFileCantParse+                              | ConfigStateFileMissing+                              | ConfigStateFileBadVersion+                              deriving Eq+type ConfigStateFileError = (String, ConfigStateFileErrorType)++tryGetConfigStateFile :: (Read a) => FilePath+                         -> IO (Either ConfigStateFileError a) tryGetConfigStateFile filename = do   exists <- doesFileExist filename   if not exists-    then return (Left missing)+    then return (Left (missing, ConfigStateFileMissing))     else withFileContents filename $ \str ->       case lines str of-        [headder, rest] -> case checkHeader headder of-          Just msg -> return (Left msg)+        [header, rest] -> case checkHeader header of+          Just err -> return (Left err)           Nothing  -> case reads rest of             [(bi,_)] -> return (Right bi)-            _        -> return (Left cantParse)-        _            -> return (Left cantParse)+            _        -> return (Left (cantParse, ConfigStateFileCantParse))+        _            -> return (Left (cantParse, ConfigStateFileCantParse))   where-    checkHeader :: String -> Maybe String+    checkHeader :: String -> Maybe ConfigStateFileError     checkHeader header = case parseHeader header of       Just (cabalId, compId)         | cabalId        == currentCabalId -> Nothing-        | otherwise      -> Just (badVersion cabalId compId)-      Nothing            -> Just cantParse+        | otherwise      -> Just (badVersion cabalId compId+                                 ,ConfigStateFileBadVersion)+      Nothing            -> Just (cantParse+                                 ,ConfigStateFileCantParse)      missing   = "Run the 'configure' command first."     cantParse = "Saved package config file seems to be corrupt. "@@ -191,8 +213,9 @@              ++ display currentCompilerId              ++ ") which is probably the cause of the problem." --- internal function-tryGetPersistBuildConfig :: FilePath -> IO (Either String LocalBuildInfo)+-- |Try to read the 'localBuildInfoFile'.+tryGetPersistBuildConfig :: FilePath+                            -> IO (Either ConfigStateFileError LocalBuildInfo) tryGetPersistBuildConfig distPref     = tryGetConfigStateFile (localBuildInfoFile distPref) @@ -202,7 +225,7 @@ getPersistBuildConfig :: FilePath -> IO LocalBuildInfo getPersistBuildConfig distPref = do   lbi <- tryGetPersistBuildConfig distPref-  either die return lbi+  either (die . fst) return lbi  -- |Try to read the 'localBuildInfoFile'. maybeGetPersistBuildConfig :: FilePath -> IO (Maybe LocalBuildInfo)@@ -251,9 +274,7 @@ -- .cabal file. checkPersistBuildConfigOutdated :: FilePath -> FilePath -> IO Bool checkPersistBuildConfigOutdated distPref pkg_descr_file = do-  t0 <- getModificationTime pkg_descr_file-  t1 <- getModificationTime $ localBuildInfoFile distPref-  return (t0 > t1)+  pkg_descr_file `moreRecentFile` (localBuildInfoFile distPref)  -- |@dist\/setup-config@ localBuildInfoFile :: FilePath -> FilePath@@ -276,15 +297,13 @@          createDirectoryIfMissingVerbose (lessVerbose verbosity) True distPref -        let programsConfig = userSpecifyArgss (configProgramArgs cfg)-                           . userSpecifyPaths (configProgramPaths cfg)-                           $ configPrograms cfg-            userInstall = fromFlag (configUserInstall cfg)-            packageDbs  = interpretPackageDbFlags userInstall-                            (configPackageDBs cfg)+        let programsConfig = mkProgramsConfig cfg (configPrograms cfg)+            userInstall    = fromFlag (configUserInstall cfg)+            packageDbs     = interpretPackageDbFlags userInstall+                             (configPackageDBs cfg)          -- detect compiler-        (comp, programsConfig') <- configCompiler+        (comp, compPlatform, programsConfig') <- configCompilerEx           (flagToMaybe $ configHcFlavor cfg)           (flagToMaybe $ configHcPath cfg) (flagToMaybe $ configHcPkg cfg)           programsConfig (lessVerbose verbosity)@@ -312,23 +331,49 @@                 --      package ID into an installed package id we can use                 --      for the internal package set. The open-codes use of                 --      InstalledPackageId . display here is a hack.-                Installed.installedPackageId = InstalledPackageId $ display $ pid,+                Installed.installedPackageId =+                   InstalledPackageId $ display $ pid,                 Installed.sourcePackageId = pid               }             internalPackageSet = PackageIndex.fromList [internalPackage]         installedPackageSet <- getInstalledPackages (lessVerbose verbosity) comp                                       packageDbs programsConfig' -        let -- Constraint test function for the solver-            dependencySatisfiable =-                not . null . PackageIndex.lookupDependency pkgs'+        (allConstraints, requiredDepsMap) <- either die return $+          combinedConstraints (configConstraints cfg)+                              (configDependencies cfg)+                              installedPackageSet++        let exactConf = fromFlagOrDefault False (configExactConfiguration cfg)+            -- Constraint test function for the solver+            dependencySatisfiable d@(Dependency depName verRange)+              | exactConf =+                -- When we're given '--exact-configuration', we assume that all+                -- dependencies and flags are exactly specified on the command+                -- line. Thus we only consult the 'requiredDepsMap'. Note that+                -- we're not doing the version range check, so if there's some+                -- dependency that wasn't specified on the command line,+                -- 'finalizePackageDescription' will fail.+                --+                -- TODO: mention '--exact-configuration' in the error message+                -- when this fails?+                (depName `Map.member` requiredDepsMap) || isInternalDep++              | otherwise =+                -- Normal operation: just look up dependency in the package+                -- index.+                not . null . PackageIndex.lookupDependency pkgs' $ d               where                 pkgs' = PackageIndex.insert internalPackage installedPackageSet+                isInternalDep = pkgName pid == depName+                                && pkgVersion pid `withinRange` verRange             enableTest t = t { testEnabled = fromFlag (configTests cfg) }             flaggedTests = map (\(n, t) -> (n, mapTreeData enableTest t))                                (condTestSuites pkg_descr0)-            enableBenchmark bm = bm { benchmarkEnabled = fromFlag (configBenchmarks cfg) }-            flaggedBenchmarks = map (\(n, bm) -> (n, mapTreeData enableBenchmark bm))+            enableBenchmark bm = bm { benchmarkEnabled =+                                         fromFlag (configBenchmarks cfg) }+            flaggedBenchmarks = map (\(n, bm) ->+                                      (n, mapTreeData enableBenchmark bm))                                (condBenchmarks pkg_descr0)             pkg_descr0'' = pkg_descr0 { condTestSuites = flaggedTests                                       , condBenchmarks = flaggedBenchmarks }@@ -337,9 +382,9 @@                 case finalizePackageDescription                        (configConfigurationsFlags cfg)                        dependencySatisfiable-                       Distribution.System.buildPlatform+                       compPlatform                        (compilerId comp)-                       (configConstraints cfg)+                       allConstraints                        pkg_descr0''                 of Right r -> return r                    Left missing ->@@ -348,6 +393,17 @@                                     . map (disp . simplifyDependency)                                     $ missing) +        -- Sanity check: if '--exact-configuration' was given, ensure that the+        -- complete flag assignment was specified on the command line.+        when exactConf $ do+          let cmdlineFlags = map fst (configConfigurationsFlags cfg)+              allFlags     = map flagName . genPackageFlags $ pkg_descr0+              diffFlags    = allFlags \\ cmdlineFlags+          when (not . null $ diffFlags) $+            die $ "'--exact-conf' was given, "+            ++ "but the following flags were not specified: "+            ++ intercalate ", " (map show diffFlags)+         -- add extra include/lib dirs as specified in cfg         -- we do it here so that those get checked too         let pkg_descr =@@ -362,16 +418,23 @@         checkPackageProblems verbosity pkg_descr0           (updatePackageDescription pbi pkg_descr) -        let selectDependencies =+        let selectDependencies :: [Dependency] ->+                                  ([FailedDependency], [ResolvedDependency])+            selectDependencies =                 (\xs -> ([ x | Left x <- xs ], [ x | Right x <- xs ]))-              . map (selectDependency internalPackageSet installedPackageSet)+              . map (selectDependency internalPackageSet installedPackageSet+                                      requiredDepsMap) -            (failedDeps, allPkgDeps) = selectDependencies (buildDepends pkg_descr)+            (failedDeps, allPkgDeps) =+              selectDependencies (buildDepends pkg_descr) -            internalPkgDeps = [ pkgid | InternalDependency _ pkgid <- allPkgDeps ]-            externalPkgDeps = [ pkg   | ExternalDependency _ pkg   <- allPkgDeps ]+            internalPkgDeps = [ pkgid+                              | InternalDependency _ pkgid <- allPkgDeps ]+            externalPkgDeps = [ pkg+                              | ExternalDependency _ pkg   <- allPkgDeps ] -        when (not (null internalPkgDeps) && not (newPackageDepsBehaviour pkg_descr)) $+        when (not (null internalPkgDeps)+              && not (newPackageDepsBehaviour pkg_descr)) $             die $ "The field 'build-depends: "                ++ intercalate ", " (map (display . packageName) internalPkgDeps)                ++ "' refers to a library which is defined within the same "@@ -396,9 +459,11 @@                             | (pkg, deps) <- broken ]          let pseudoTopPkg = emptyInstalledPackageInfo {-                Installed.installedPackageId = InstalledPackageId (display (packageId pkg_descr)),+                Installed.installedPackageId =+                   InstalledPackageId (display (packageId pkg_descr)),                 Installed.sourcePackageId = packageId pkg_descr,-                Installed.depends = map Installed.installedPackageId externalPkgDeps+                Installed.depends =+                  map Installed.installedPackageId externalPkgDeps               }         case PackageIndex.dependencyInconsistencies            . PackageIndex.insert pseudoTopPkg@@ -413,13 +478,21 @@                          | (name, uses) <- inconsistencies                          , (pkg, ver) <- uses ] +        -- internal component graph+        buildComponents <-+          case mkComponentsLocalBuildInfo pkg_descr+                 internalPkgDeps externalPkgDeps of+            Left  componentCycle -> reportComponentCycle componentCycle+            Right components     -> return components+         -- installation directories         defaultDirs <- defaultInstallDirs flavor userInstall (hasLibs pkg_descr)         let installDirs = combineInstallDirs fromFlagOrDefault                             defaultDirs (configInstallDirs cfg)          -- check languages and extensions-        let langlist = nub $ catMaybes $ map defaultLanguage (allBuildInfo pkg_descr)+        let langlist = nub $ catMaybes $ map defaultLanguage+                       (allBuildInfo pkg_descr)         let langs = unsupportedLanguages comp langlist         when (not (null langs)) $           die $ "The package " ++ display (packageId pkg_descr0)@@ -440,7 +513,8 @@               [ buildTool               | let exeNames = map exeName (executables pkg_descr)               , bi <- allBuildInfo pkg_descr-              , buildTool@(Dependency (PackageName toolName) reqVer) <- buildTools bi+              , buildTool@(Dependency (PackageName toolName) reqVer)+                <- buildTools bi               , let isInternal =                         toolName `elem` exeNames                         -- we assume all internal build-tools are@@ -465,66 +539,13 @@                                           "--enable-split-objs; ignoring")                                     return False -        -- The allPkgDeps contains all the package deps for the whole package-        -- but we need to select the subset for this specific component.-        -- we just take the subset for the package names this component-        -- needs. Note, this only works because we cannot yet depend on two-        -- versions of the same package.-        let configLib lib = configComponent (libBuildInfo lib)-            configExe exe = (exeName exe, configComponent (buildInfo exe))-            configTest test = (testName test,-                    configComponent(testBuildInfo test))-            configBenchmark bm = (benchmarkName bm,-                    configComponent(benchmarkBuildInfo bm))-            configComponent bi = ComponentLocalBuildInfo {-              componentPackageDeps =-                if newPackageDepsBehaviour pkg_descr'-                  then [ (installedPackageId pkg, packageId pkg)-                       | pkg <- selectSubset bi externalPkgDeps ]-                    ++ [ (inplacePackageId pkgid, pkgid)-                       | pkgid <- selectSubset bi internalPkgDeps ]-                  else [ (installedPackageId pkg, packageId pkg)-                       | pkg <- externalPkgDeps ]-            }-            selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]-            selectSubset bi pkgs =-                [ pkg | pkg <- pkgs, packageName pkg `elem` names ]-              where-                names = [ name | Dependency name _ <- targetBuildDepends bi ]--        -- Obtains the intrapackage dependencies for the given component-        let ipDeps component =-                 mapMaybe exeDepToComp (buildTools bi)-              ++ mapMaybe libDepToComp (targetBuildDepends bi)-              where-                bi = foldComponent libBuildInfo buildInfo testBuildInfo-                     benchmarkBuildInfo component-                exeDepToComp (Dependency (PackageName name) _) =-                  CExe `fmap` find ((==) name . exeName)-                                (executables pkg_descr')-                libDepToComp (Dependency pn _)-                  | pn `elem` map packageName internalPkgDeps =-                    CLib `fmap` library pkg_descr'-                libDepToComp _ = Nothing--        let sccs = (stronglyConnCompR . map lkup . vertices . transposeG) g-              where (g, lkup, _) = graphFromEdges-                                 $ allComponentsBy pkg_descr'-                                 $ \c -> (c, key c, map key (ipDeps c))-                    key          = foldComponent (const "library") exeName-                                   testName benchmarkName--        -- check for cycles in the dependency graph-        buildOrder <- forM sccs $ \scc -> case scc of-          AcyclicSCC (c,_,_) -> return (foldComponent (const CLibName)-                                                      (CExeName . exeName)-                                                      (CTestName . testName)-                                                      (CBenchName . benchmarkName)-                                                      c)-          CyclicSCC vs ->-            die $ "Found cycle in intrapackage dependency graph:\n  "-                ++ intercalate " depends on "-                     (map (\(_,k,_) -> "'" ++ k ++ "'") (vs ++ [head vs]))+        let sharedLibsByDefault =+              case compilerId comp of+                CompilerId GHC _ ->+                  -- if ghc is dynamic, then ghci needs a shared+                  -- library, so we build one by default.+                  GHC.ghcDynamic comp+                _ -> False          let lbi = LocalBuildInfo {                     configFlags         = cfg,@@ -533,28 +554,27 @@                                                -- did they would go here.                     installDirTemplates = installDirs,                     compiler            = comp,+                    hostPlatform        = compPlatform,                     buildDir            = buildDir',                     scratchDir          = fromFlagOrDefault                                             (distPref </> "scratch")                                             (configScratchDir cfg),-                    libraryConfig       = configLib `fmap` library pkg_descr',-                    executableConfigs   = configExe `fmap` executables pkg_descr',-                    testSuiteConfigs    = configTest `fmap` testSuites pkg_descr',-                    benchmarkConfigs    = configBenchmark `fmap` benchmarks pkg_descr',-                    compBuildOrder      = buildOrder,+                    componentsConfigs   = buildComponents,                     installedPkgs       = packageDependsIndex,                     pkgDescrFile        = Nothing,                     localPkgDescr       = pkg_descr',                     withPrograms        = programsConfig''',                     withVanillaLib      = fromFlag $ configVanillaLib cfg,                     withProfLib         = fromFlag $ configProfLib cfg,-                    withSharedLib       = fromFlag $ configSharedLib cfg,+                    withSharedLib       = fromFlagOrDefault sharedLibsByDefault $+                                          configSharedLib cfg,                     withDynExe          = fromFlag $ configDynExe cfg,                     withProfExe         = fromFlag $ configProfExe cfg,                     withOptimization    = fromFlag $ configOptimization cfg,                     withGHCiLib         = fromFlag $ configGHCiLib cfg,                     splitObjs           = split_objs,                     stripExes           = fromFlag $ configStripExes cfg,+                    stripLibs           = fromFlag $ configStripLibs cfg,                     withPackageDB       = packageDbs,                     progPrefix          = fromFlag $ configProgPrefix cfg,                     progSuffix          = fromFlag $ configProgSuffix cfg@@ -584,6 +604,7 @@         dirinfo "Private binaries" (libexecdir dirs) (libexecdir relative)         dirinfo "Data files"       (datadir dirs)    (datadir relative)         dirinfo "Documentation"    (docdir dirs)     (docdir relative)+        dirinfo "Configuration files" (sysconfdir dirs) (sysconfdir relative)          sequence_ [ reportProgram verbosity prog configuredProg                   | (prog, configuredProg) <- knownPrograms programsConfig''' ]@@ -594,11 +615,24 @@       addExtraIncludeLibDirs pkg_descr =           let extraBi = mempty { extraLibDirs = configExtraLibDirs cfg                                , PD.includeDirs = configExtraIncludeDirs cfg}-              modifyLib l        = l{ libBuildInfo = libBuildInfo l `mappend` extraBi }-              modifyExecutable e = e{ buildInfo    = buildInfo e    `mappend` extraBi}+              modifyLib l        = l{ libBuildInfo = libBuildInfo l+                                                     `mappend` extraBi }+              modifyExecutable e = e{ buildInfo    = buildInfo e+                                                     `mappend` extraBi}           in pkg_descr{ library     = modifyLib        `fmap` library pkg_descr-                      , executables = modifyExecutable  `map` executables pkg_descr}+                      , executables = modifyExecutable  `map`+                                      executables pkg_descr} +mkProgramsConfig :: ConfigFlags -> ProgramConfiguration -> ProgramConfiguration+mkProgramsConfig cfg initialProgramsConfig = programsConfig+  where+    programsConfig = userSpecifyArgss (configProgramArgs cfg)+                   . userSpecifyPaths (configProgramPaths cfg)+                   . setProgramSearchPath searchpath+                   $ initialProgramsConfig+    searchpath     = getProgramSearchPath (initialProgramsConfig)+                  ++ map ProgramSearchPathDir (configProgramPathExtra cfg)+ -- ----------------------------------------------------------------------------- -- Configuring package dependencies @@ -618,7 +652,8 @@ hackageUrl = "http://hackage.haskell.org/package/"  data ResolvedDependency = ExternalDependency Dependency InstalledPackageInfo-                        | InternalDependency Dependency PackageId -- should be a lib name+                        | InternalDependency Dependency PackageId -- should be a+                                                                  -- lib name  data FailedDependency = DependencyNotExists PackageName                       | DependencyNoVersion Dependency@@ -626,9 +661,11 @@ -- | Test for a package dependency and record the version we have installed. selectDependency :: PackageIndex  -- ^ Internally defined packages                  -> PackageIndex  -- ^ Installed packages+                 -> Map PackageName InstalledPackageInfo+                    -- ^ Packages for which we have been given specific deps to use                  -> Dependency                  -> Either FailedDependency ResolvedDependency-selectDependency internalIndex installedIndex+selectDependency internalIndex installedIndex requiredDepsMap   dep@(Dependency pkgname vr) =   -- If the dependency specification matches anything in the internal package   -- index, then we prefer that match to anything in the second.@@ -648,12 +685,15 @@     [(_,[pkg])] | packageVersion pkg `withinRange` vr            -> Right $ InternalDependency dep (packageId pkg) -    _      -> case PackageIndex.lookupDependency installedIndex dep of-      []   -> Left  $ DependencyNotExists pkgname-      pkgs -> Right $ ExternalDependency dep $-                -- by default we just pick the latest+    _      -> case Map.lookup pkgname requiredDepsMap of+      -- If we know the exact pkg to use, then use it.+      Just pkginstance -> Right (ExternalDependency dep pkginstance)+      -- Otherwise we just pick an arbitrary instance of the latest version.+      Nothing -> case PackageIndex.lookupDependency installedIndex dep of+        []   -> Left  $ DependencyNotExists pkgname+        pkgs -> Right $ ExternalDependency dep $                 case last pkgs of-                  (_ver, instances) -> head instances -- the first preference+                  (_ver, pkginstances) -> head pkginstances  reportSelectedDependencies :: Verbosity                            -> [ResolvedDependency] -> IO ()@@ -697,9 +737,24 @@     LHC -> LHC.getInstalledPackages verbosity packageDBs progconf     NHC -> NHC.getInstalledPackages verbosity packageDBs progconf     UHC -> UHC.getInstalledPackages verbosity comp packageDBs progconf+    HaskellSuite {} ->+      HaskellSuite.getInstalledPackages verbosity packageDBs progconf     flv -> die $ "don't know how to find the installed packages for "               ++ display flv +-- | Like 'getInstalledPackages', but for a single package DB.+getPackageDBContents :: Verbosity -> Compiler+                     -> PackageDB -> ProgramConfiguration+                     -> IO PackageIndex+getPackageDBContents verbosity comp packageDB progconf = do+  info verbosity "Reading installed packages..."+  case compilerFlavor comp of+    GHC -> GHC.getPackageDBContents verbosity packageDB progconf++    -- For other compilers, try to fall back on 'getInstalledPackages'.+    _   -> getInstalledPackages verbosity comp [packageDB] progconf++ -- | The user interface specifies the package dbs to use with a combination of -- @--global@, @--user@ and @--package-db=global|user|clear|$file@. -- This function combines the global/user flag and interprets the package-db@@ -717,7 +772,8 @@     extra dbs' (Just db:dbs) = extra (dbs' ++ [db]) dbs  newPackageDepsBehaviourMinVersion :: Version-newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1], versionTags = [] }+newPackageDepsBehaviourMinVersion = Version { versionBranch = [1,7,1],+                                              versionTags = [] }  -- In older cabal versions, there was only one set of package dependencies for -- the whole package. In this version, we can have separate dependencies per@@ -728,15 +784,91 @@ newPackageDepsBehaviour pkg =    specVersion pkg >= newPackageDepsBehaviourMinVersion +-- We are given both --constraint="foo < 2.0" style constraints and also+-- specific packages to pick via --dependency="foo=foo-2.0-177d5cdf20962d0581".+--+-- When finalising the package we have to take into account the specific+-- installed deps we've been given, and the finalise function expects+-- constraints, so we have to translate these deps into version constraints.+--+-- But after finalising we then have to make sure we pick the right specific+-- deps in the end. So we still need to remember which installed packages to+-- pick.+combinedConstraints :: [Dependency] ->+                       [(PackageName, InstalledPackageId)] ->+                       PackageIndex ->+                       Either String ([Dependency],+                                      Map PackageName InstalledPackageInfo)+combinedConstraints constraints dependencies installedPackages = do++    when (not (null badInstalledPackageIds)) $+      Left $ render $ text "The following package dependencies were requested"+         $+$ nest 4 (dispDependencies badInstalledPackageIds)+         $+$ text "however the given installed package instance does not exist."++    when (not (null badNames)) $+      Left $ render $ text "The following package dependencies were requested"+         $+$ nest 4 (dispDependencies badNames)+         $+$ text "however the installed package's name does not match the name given."++    --TODO: we don't check that all dependencies are used!++    return (allConstraints, idConstraintMap)++  where+    allConstraints :: [Dependency]+    allConstraints = constraints+                  ++ [ thisPackageVersion (packageId pkg)+                     | (_, _, Just pkg) <- dependenciesPkgInfo ]++    idConstraintMap :: Map PackageName InstalledPackageInfo+    idConstraintMap = Map.fromList+                        [ (packageName pkg, pkg)+                        | (_, _, Just pkg) <- dependenciesPkgInfo ]++    -- The dependencies along with the installed package info, if it exists+    dependenciesPkgInfo :: [(PackageName, InstalledPackageId,+                             Maybe InstalledPackageInfo)]+    dependenciesPkgInfo =+      [ (pkgname, ipkgid, mpkg)+      | (pkgname, ipkgid) <- dependencies+      , let mpkg = PackageIndex.lookupInstalledPackageId+                     installedPackages ipkgid+      ]++    -- If we looked up a package specified by an installed package id+    -- (i.e. someone has written a hash) and didn't find it then it's+    -- an error.+    badInstalledPackageIds =+      [ (pkgname, ipkgid)+      | (pkgname, ipkgid, Nothing) <- dependenciesPkgInfo ]++    -- If someone has written e.g.+    -- --dependency="foo=MyOtherLib-1.0-07...5bf30" then they have+    -- probably made a mistake.+    badNames =+      [ (requestedPkgName, ipkgid)+      | (requestedPkgName, ipkgid, Just pkg) <- dependenciesPkgInfo+      , let foundPkgName = packageName pkg+      , requestedPkgName /= foundPkgName ]++    dispDependencies deps =+      hsep [    text "--dependency="+             <> quotes (disp pkgname <> char '=' <> disp ipkgid)+           | (pkgname, ipkgid) <- deps ]+ -- ----------------------------------------------------------------------------- -- Configuring program dependencies -configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration -> IO ProgramConfiguration+configureRequiredPrograms :: Verbosity -> [Dependency] -> ProgramConfiguration+                             -> IO ProgramConfiguration configureRequiredPrograms verbosity deps conf =   foldM (configureRequiredProgram verbosity) conf deps -configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency -> IO ProgramConfiguration-configureRequiredProgram verbosity conf (Dependency (PackageName progName) verRange) =+configureRequiredProgram :: Verbosity -> ProgramConfiguration -> Dependency+                            -> IO ProgramConfiguration+configureRequiredProgram verbosity conf+  (Dependency (PackageName progName) verRange) =   case lookupKnownProgram progName conf of     Nothing -> die ("Unknown build tool " ++ progName)     Just prog@@ -837,33 +969,134 @@ -- ----------------------------------------------------------------------------- -- Determining the compiler details -configCompilerAux :: ConfigFlags -> IO (Compiler, ProgramConfiguration)-configCompilerAux cfg = configCompiler (flagToMaybe $ configHcFlavor cfg)-                                       (flagToMaybe $ configHcPath cfg)-                                       (flagToMaybe $ configHcPkg cfg)-                                       programsConfig-                                       (fromFlag (configVerbosity cfg))+configCompilerAuxEx :: ConfigFlags+                    -> IO (Compiler, Platform, ProgramConfiguration)+configCompilerAuxEx cfg = configCompilerEx (flagToMaybe $ configHcFlavor cfg)+                                           (flagToMaybe $ configHcPath cfg)+                                           (flagToMaybe $ configHcPkg cfg)+                                           programsConfig+                                           (fromFlag (configVerbosity cfg))   where-    programsConfig = userSpecifyArgss (configProgramArgs cfg)-                   . userSpecifyPaths (configProgramPaths cfg)-                   $ defaultProgramConfiguration+    programsConfig = mkProgramsConfig cfg defaultProgramConfiguration +configCompilerEx :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath+                 -> ProgramConfiguration -> Verbosity+                 -> IO (Compiler, Platform, ProgramConfiguration)+configCompilerEx Nothing _ _ _ _ = die "Unknown compiler"+configCompilerEx (Just hcFlavor) hcPath hcPkg conf verbosity = do+  (comp, maybePlatform, programsConfig) <- case hcFlavor of+    GHC  -> GHC.configure  verbosity hcPath hcPkg conf+    JHC  -> JHC.configure  verbosity hcPath hcPkg conf+    LHC  -> do (_, _, ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf+               LHC.configure  verbosity hcPath Nothing ghcConf+    Hugs -> Hugs.configure verbosity hcPath hcPkg conf+    NHC  -> NHC.configure  verbosity hcPath hcPkg conf+    UHC  -> UHC.configure  verbosity hcPath hcPkg conf+    HaskellSuite {} -> HaskellSuite.configure verbosity hcPath hcPkg conf+    _    -> die "Unknown compiler"+  return (comp, fromMaybe buildPlatform maybePlatform, programsConfig)++-- Ideally we would like to not have separate configCompiler* and+-- configCompiler*Ex sets of functions, but there are many custom setup scripts+-- in the wild that are using them, so the versions with old types are kept for+-- backwards compatibility. Platform was added to the return triple in 1.18.++{-# DEPRECATED configCompiler+    "'configCompiler' is deprecated. Use 'configCompilerEx' instead." #-} configCompiler :: Maybe CompilerFlavor -> Maybe FilePath -> Maybe FilePath                -> ProgramConfiguration -> Verbosity                -> IO (Compiler, ProgramConfiguration)-configCompiler Nothing _ _ _ _ = die "Unknown compiler"-configCompiler (Just hcFlavor) hcPath hcPkg conf verbosity = do-  case hcFlavor of-      GHC  -> GHC.configure  verbosity hcPath hcPkg conf-      JHC  -> JHC.configure  verbosity hcPath hcPkg conf-      LHC  -> do (_,ghcConf) <- GHC.configure  verbosity Nothing hcPkg conf-                 LHC.configure  verbosity hcPath Nothing ghcConf-      Hugs -> Hugs.configure verbosity hcPath hcPkg conf-      NHC  -> NHC.configure  verbosity hcPath hcPkg conf-      UHC  -> UHC.configure  verbosity hcPath hcPkg conf-      _    -> die "Unknown compiler"+configCompiler mFlavor hcPath hcPkg conf verbosity =+  fmap (\(a,_,b) -> (a,b)) $ configCompilerEx mFlavor hcPath hcPkg conf verbosity +{-# DEPRECATED configCompilerAux+    "configCompilerAux is deprecated. Use 'configCompilerAuxEx' instead." #-}+configCompilerAux :: ConfigFlags+                  -> IO (Compiler, ProgramConfiguration)+configCompilerAux = fmap (\(a,_,b) -> (a,b)) . configCompilerAuxEx +-- -----------------------------------------------------------------------------+-- Making the internal component graph+++mkComponentsLocalBuildInfo :: PackageDescription+                           -> [PackageId] -> [InstalledPackageInfo]+                           -> Either [ComponentName]+                                     [(ComponentName,+                                       ComponentLocalBuildInfo, [ComponentName])]+mkComponentsLocalBuildInfo pkg_descr internalPkgDeps externalPkgDeps =+    let graph = [ (c, componentName c, componentDeps c)+                | c <- pkgEnabledComponents pkg_descr ]+     in case checkComponentsCyclic graph of+          Just ccycle -> Left  [ cname | (_,cname,_) <- ccycle ]+          Nothing     -> Right [ (cname, clbi, cdeps)+                               | (c, cname, cdeps) <- graph+                               , let clbi = componentLocalBuildInfo c ]+  where+    -- The dependencies for the given component+    componentDeps component =+         [ CExeName toolname | Dependency (PackageName toolname) _+                               <- buildTools bi+                             , toolname `elem` map exeName+                               (executables pkg_descr) ]++      ++ [ CLibName          | Dependency pkgname _ <- targetBuildDepends bi+                             , pkgname `elem` map packageName internalPkgDeps ]+      where+        bi = componentBuildInfo component++    -- The allPkgDeps contains all the package deps for the whole package+    -- but we need to select the subset for this specific component.+    -- we just take the subset for the package names this component+    -- needs. Note, this only works because we cannot yet depend on two+    -- versions of the same package.+    componentLocalBuildInfo component =+      case component of+      CLib _ ->+        LibComponentLocalBuildInfo {+          componentPackageDeps = cpds,+          componentLibraries = [LibraryName+                                ("HS" ++ display (package pkg_descr))]+        }+      CExe _ ->+        ExeComponentLocalBuildInfo {+          componentPackageDeps = cpds+        }+      CTest _ ->+        TestComponentLocalBuildInfo {+          componentPackageDeps = cpds+        }+      CBench _ ->+        BenchComponentLocalBuildInfo {+          componentPackageDeps = cpds+        }+      where+        bi = componentBuildInfo component+        cpds = if newPackageDepsBehaviour pkg_descr+               then [ (installedPackageId pkg, packageId pkg)+                    | pkg <- selectSubset bi externalPkgDeps ]+                 ++ [ (inplacePackageId pkgid, pkgid)+                    | pkgid <- selectSubset bi internalPkgDeps ]+               else [ (installedPackageId pkg, packageId pkg)+                    | pkg <- externalPkgDeps ]++    selectSubset :: Package pkg => BuildInfo -> [pkg] -> [pkg]+    selectSubset bi pkgs =+        [ pkg | pkg <- pkgs, packageName pkg `elem` names ]+      where+        names = [ name | Dependency name _ <- targetBuildDepends bi ]++reportComponentCycle :: [ComponentName] -> IO a+reportComponentCycle cnames =+    die $ "Components in the package depend on each other in a cyclic way:\n  "+       ++ intercalate " depends on "+            [ "'" ++ showComponentName cname ++ "'"+            | cname <- cnames ++ [head cnames] ]+++-- -----------------------------------------------------------------------------+-- Testing C lib and header dependencies+ -- Try to build a test C program which includes every header and links every -- lib. If that fails, try to narrow it down by preprocessing (only) and linking -- with individual headers and libs.  If none is the obvious culprit then give a@@ -871,7 +1104,8 @@ -- TODO: produce a log file from the compiler errors, if any. checkForeignDeps :: PackageDescription -> LocalBuildInfo -> Verbosity -> IO () checkForeignDeps pkg lbi verbosity = do-  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling lucky+  ifBuildsWith allHeaders (commonCcArgs ++ makeLdArgs allLibs) -- I'm feeling+                                                               -- lucky            (return ())            (do missingLibs <- findMissingLibs                missingHdr  <- findOffendingHdr@@ -908,7 +1142,7 @@          libExists lib = builds (makeProgram []) (makeLdArgs [lib]) -        commonCppArgs = hcDefines (compiler lbi)+        commonCppArgs = platformDefines lbi                      ++ [ "-I" ++ autogenModulesDir lbi ]                      ++ [ "-I" ++ dir | dir <- collectField PD.includeDirs ]                      ++ ["-I."]@@ -1007,66 +1241,6 @@           ++ "You can re-run configure with the verbosity flag "           ++ "-v3 to see the error messages from the C compiler." -        --FIXME: share this with the PreProcessor module-        hcDefines :: Compiler -> [String]-        hcDefines comp =-          case compilerFlavor comp of-            GHC  ->-                let ghcOS = case buildOS of-                            Linux     -> ["linux"]-                            Windows   -> ["mingw32"]-                            OSX       -> ["darwin"]-                            FreeBSD   -> ["freebsd"]-                            OpenBSD   -> ["openbsd"]-                            NetBSD    -> ["netbsd"]-                            Solaris   -> ["solaris2"]-                            AIX       -> ["aix"]-                            HPUX      -> ["hpux"]-                            IRIX      -> ["irix"]-                            HaLVM     -> []-                            OtherOS _ -> []-                    ghcArch = case buildArch of-                              I386        -> ["i386"]-                              X86_64      -> ["x86_64"]-                              PPC         -> ["powerpc"]-                              PPC64       -> ["powerpc64"]-                              Sparc       -> ["sparc"]-                              Arm         -> ["arm"]-                              Mips        -> ["mips"]-                              SH          -> []-                              IA64        -> ["ia64"]-                              S390        -> ["s390"]-                              Alpha       -> ["alpha"]-                              Hppa        -> ["hppa"]-                              Rs6000      -> ["rs6000"]-                              M68k        -> ["m68k"]-                              Vax         -> ["vax"]-                              OtherArch _ -> []-                in ["-D__GLASGOW_HASKELL__=" ++ versionInt version] ++-                   map (\os   -> "-D" ++ os   ++ "_HOST_OS=1")   ghcOS ++-                   map (\arch -> "-D" ++ arch ++ "_HOST_ARCH=1") ghcArch-            JHC  -> ["-D__JHC__=" ++ versionInt version]-            NHC  -> ["-D__NHC__=" ++ versionInt version]-            Hugs -> ["-D__HUGS__"]-            _    -> []-          where-            version = compilerVersion comp-                      -- TODO: move this into the compiler abstraction-            -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all-            -- the other compilers. Check if that's really what they want.-            versionInt :: Version -> String-            versionInt (Version { versionBranch = [] }) = "1"-            versionInt (Version { versionBranch = [n] }) = show n-            versionInt (Version { versionBranch = n1:n2:_ })-              = -- 6.8.x -> 608-                -- 6.10.x -> 610-                let s1 = show n1-                    s2 = show n2-                    middle = case s2 of-                             _ : _ : _ -> ""-                             _         -> "0"-                in s1 ++ middle ++ s2- -- | Output package check warnings and errors. Exit if any errors. checkPackageProblems :: Verbosity                      -> GenericPackageDescription@@ -1079,5 +1253,4 @@       warnings = [ w | PackageBuildWarning    w <- pureChecks ++ ioChecks ]   if null errors     then mapM_ (warn verbosity) warnings-    else do mapM_ (hPutStrLn stderr . ("Error: " ++)) errors-            exitWith (ExitFailure 1)+    else die (intercalate "\n\n" errors)
cabal/Cabal/Distribution/Simple/GHC.hs view
@@ -61,25 +61,27 @@ OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -}  module Distribution.Simple.GHC (-        configure, getInstalledPackages,+        getGhcInfo,+        configure, getInstalledPackages, getPackageDBContents,         buildLib, buildExe,+        replLib, replExe,+        startInterpreter,         installLib, installExe,         libAbiHash,         initPackageDB,+        invokeHcPkg,         registerPackage,         componentGhcOptions,         ghcLibDir,--        -- * Deprecated-        ghcVerbosityOptions,-        ghcPackageDbOptions,+        ghcDynamic,  ) where  import qualified Distribution.Simple.GHC.IPI641 as IPI641 import qualified Distribution.Simple.GHC.IPI642 as IPI642 import Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(..), Executable(..)-         , Library(..), libModules, hcOptions, usedExtensions, allExtensions )+         , Library(..), libModules, exeModules, hcOptions+         , usedExtensions, allExtensions ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import qualified Distribution.InstalledPackageInfo as InstalledPackageInfo@@ -88,28 +90,33 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)-         , absoluteInstallDirs )+         , LibraryName(..), absoluteInstallDirs ) import Distribution.Simple.InstallDirs hiding ( absoluteInstallDirs ) import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( PackageIdentifier, Package(..), PackageName(..) )+         ( Package(..), PackageName(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg-         , ProgramLocation(..), rawSystemProgram+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration+         , ProgramLocation(..), ProgramSearchPath, ProgramSearchPathEntry(..)+         , rawSystemProgram          , rawSystemProgramStdout, rawSystemProgramStdoutConf-         , getProgramInvocationOutput-         , requireProgramVersion, requireProgram, getProgramOutput+         , getProgramOutput, getProgramInvocationOutput, suppressOverrideArgs+         , requireProgramVersion, requireProgram          , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram          , ghcProgram, ghcPkgProgram, hsc2hsProgram-         , arProgram, ranlibProgram, ldProgram+         , arProgram, ldProgram          , gccProgram, stripProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg import qualified Distribution.Simple.Program.Ar    as Ar import qualified Distribution.Simple.Program.Ld    as Ld+import qualified Distribution.Simple.Program.Strip as Strip import Distribution.Simple.Program.GHC-import Distribution.Simple.Setup (toFlag, fromFlag)+import Distribution.Simple.Setup+         ( toFlag, fromFlag, fromFlagOrDefault )+import qualified Distribution.Simple.Setup as Cabal+        ( Flag ) import Distribution.Simple.Compiler          ( CompilerFlavor(..), CompilerId(..), Compiler(..), compilerVersion          , OptimisationLevel(..), PackageDB(..), PackageDBStack@@ -121,27 +128,32 @@ import Distribution.Verbosity import Distribution.Text          ( display, simpleParse )-import Language.Haskell.Extension (Language(..), Extension(..), KnownExtension(..))+import Language.Haskell.Extension (Language(..), Extension(..)+                                  ,KnownExtension(..)) -import Control.Monad            ( unless, when, liftM )+import Control.Monad            ( unless, when ) import Data.Char                ( isSpace ) import Data.List-import Data.Maybe               ( catMaybes, fromMaybe )+import qualified Data.Map as M  ( Map, fromList, lookup )+import Data.Maybe               ( catMaybes, fromMaybe, maybeToList ) import Data.Monoid              ( Monoid(..) ) import System.Directory-         ( removeFile, getDirectoryContents, doesFileExist-         , getTemporaryDirectory )+         ( getDirectoryContents, doesFileExist, getTemporaryDirectory ) import System.FilePath          ( (</>), (<.>), takeExtension,-                                  takeDirectory, replaceExtension, splitExtension )+                                  takeDirectory, replaceExtension,+                                  splitExtension ) import System.IO (hClose, hPutStrLn) import System.Environment (getEnv) import Distribution.Compat.Exception (catchExit, catchIO)+import Distribution.System (Platform, platformFromTriple) + -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration+          -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf0 = do    (ghcProg, ghcVersion, conf1) <-@@ -172,24 +184,22 @@   languages  <- getLanguages verbosity ghcProg   extensions <- getExtensions verbosity ghcProg -  ghcInfo <- if ghcVersion >= Version [6,7] []-             then do xs <- getProgramOutput verbosity ghcProg ["--info"]-                     case reads xs of-                         [(i, ss)]-                          | all isSpace ss ->-                             return i-                         _ ->-                             die "Can't parse --info output of GHC"-             else return []+  ghcInfo <- getGhcInfo verbosity ghcProg+  let ghcInfoMap = M.fromList ghcInfo    let comp = Compiler {-        compilerId             = CompilerId GHC ghcVersion,-        compilerLanguages      = languages,-        compilerExtensions     = extensions+        compilerId         = CompilerId GHC ghcVersion,+        compilerLanguages  = languages,+        compilerExtensions = extensions,+        compilerProperties = ghcInfoMap       }-      conf4 = configureToolchain ghcProg ghcInfo conf3 -- configure gcc and ld-  return (comp, conf4)+      compPlatform = targetPlatform ghcInfo+      conf4 = configureToolchain ghcProg ghcInfoMap conf3 -- configure gcc and ld+  return (comp, compPlatform, conf4) +targetPlatform :: [(String, String)] -> Maybe Platform+targetPlatform ghcInfo = platformFromTriple =<< lookup "Target platform" ghcInfo+ -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find -- the corresponding tool; e.g. if the tool is ghc-pkg, we try looking -- for a versioned or unversioned ghc-pkg in the same dir, that is:@@ -198,28 +208,36 @@ -- > /usr/local/bin/ghc-pkg-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg(.exe) ---guessToolFromGhcPath :: FilePath -> ConfiguredProgram -> Verbosity+guessToolFromGhcPath :: Program -> ConfiguredProgram+                     -> Verbosity -> ProgramSearchPath                      -> IO (Maybe FilePath)-guessToolFromGhcPath tool ghcProg verbosity-  = do let path              = programPath ghcProg+guessToolFromGhcPath tool ghcProg verbosity searchpath+  = do let toolname          = programName tool+           path              = programPath ghcProg            dir               = takeDirectory path            versionSuffix     = takeVersionSuffix (dropExeExtension path)-           guessNormal       = dir </> tool <.> exeExtension-           guessGhcVersioned = dir </> (tool ++ "-ghc" ++ versionSuffix) <.> exeExtension-           guessVersioned    = dir </> (tool ++ versionSuffix) <.> exeExtension+           guessNormal       = dir </> toolname <.> exeExtension+           guessGhcVersioned = dir </> (toolname ++ "-ghc" ++ versionSuffix)+                               <.> exeExtension+           guessVersioned    = dir </> (toolname ++ versionSuffix)+                               <.> exeExtension            guesses | null versionSuffix = [guessNormal]                    | otherwise          = [guessGhcVersioned,                                            guessVersioned,                                            guessNormal]-       info verbosity $ "looking for tool " ++ show tool ++ " near compiler in " ++ dir+       info verbosity $ "looking for tool " ++ toolname+         ++ " near compiler in " ++ dir        exists <- mapM doesFileExist guesses        case [ file | (file, True) <- zip guesses exists ] of-         [] -> return Nothing-         (fp:_) -> do info verbosity $ "found " ++ tool ++ " in " ++ fp+                   -- If we can't find it near ghc, fall back to the usual+                   -- method.+         []     -> programFindLocation tool verbosity searchpath+         (fp:_) -> do info verbosity $ "found " ++ toolname ++ " in " ++ fp                       return (Just fp)    where takeVersionSuffix :: FilePath -> String-        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") . reverse+        takeVersionSuffix = reverse . takeWhile (`elem ` "0123456789.-") .+                            reverse          dropExeExtension :: FilePath -> FilePath         dropExeExtension filepath =@@ -235,8 +253,9 @@ -- > /usr/local/bin/ghc-pkg-6.6.1(.exe) -- > /usr/local/bin/ghc-pkg(.exe) ---guessGhcPkgFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)-guessGhcPkgFromGhcPath = guessToolFromGhcPath "ghc-pkg"+guessGhcPkgFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+guessGhcPkgFromGhcPath = guessToolFromGhcPath ghcPkgProgram  -- | Given something like /usr/local/bin/ghc-6.6.1(.exe) we try and find a -- corresponding hsc2hs, we try looking for both a versioned and unversioned@@ -246,40 +265,29 @@ -- > /usr/local/bin/hsc2hs-6.6.1(.exe) -- > /usr/local/bin/hsc2hs(.exe) ---guessHsc2hsFromGhcPath :: ConfiguredProgram -> Verbosity -> IO (Maybe FilePath)-guessHsc2hsFromGhcPath = guessToolFromGhcPath "hsc2hs"+guessHsc2hsFromGhcPath :: ConfiguredProgram+                       -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+guessHsc2hsFromGhcPath = guessToolFromGhcPath hsc2hsProgram  -- | Adjust the way we find and configure gcc and ld ---configureToolchain :: ConfiguredProgram -> [(String, String)]+configureToolchain :: ConfiguredProgram -> M.Map String String                                         -> ProgramConfiguration                                         -> ProgramConfiguration configureToolchain ghcProg ghcInfo =     addKnownProgram gccProgram {-      programFindLocation = findProg gccProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "gcc.exe"-                                  else baseDir     </> "gcc.exe" ],+      programFindLocation = findProg gccProgram extraGccPath,       programPostConf     = configureGcc     }   . addKnownProgram ldProgram {-      programFindLocation = findProg ldProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "ld.exe"-                                  else libDir      </> "ld.exe" ],+      programFindLocation = findProg ldProgram extraLdPath,       programPostConf     = configureLd     }   . addKnownProgram arProgram {-      programFindLocation = findProg arProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "ar.exe"-                                  else libDir      </> "ar.exe" ]+      programFindLocation = findProg arProgram extraArPath     }   . addKnownProgram stripProgram {-      programFindLocation = findProg stripProgram-                              [ if ghcVersion >= Version [6,12] []-                                  then mingwBinDir </> binPrefix ++ "strip.exe"-                                  else libDir      </> "strip.exe" ]+      programFindLocation = findProg stripProgram extraStripPath     }   where     Just ghcVersion = programVersion ghcProg@@ -291,36 +299,65 @@     isWindows   = case buildOS of Windows -> True; _ -> False     binPrefix   = "" -    -- on Windows finding and configuring ghc's gcc and ld is a bit special-    findProg :: Program -> [FilePath] -> Verbosity -> IO (Maybe FilePath)-    findProg prog locations-      | isWindows = \verbosity -> look locations verbosity-      | otherwise = programFindLocation prog+    mkExtraPath :: Maybe FilePath -> FilePath -> [FilePath]+    mkExtraPath mbPath mingwPath | isWindows = mbDir ++ [mingwPath]+                                 | otherwise = mbDir       where-        look [] verbosity = do-          warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")-          programFindLocation prog verbosity-        look (f:fs) verbosity = do-          exists <- doesFileExist f-          if exists then return (Just f)-                    else look fs verbosity+        mbDir = maybeToList . fmap takeDirectory $ mbPath +    extraGccPath   = mkExtraPath mbGccLocation   windowsExtraGccDir+    extraLdPath    = mkExtraPath mbLdLocation    windowsExtraLdDir+    extraArPath    = mkExtraPath mbArLocation    windowsExtraArDir+    extraStripPath = mkExtraPath mbStripLocation windowsExtraStripDir++    -- on Windows finding and configuring ghc's gcc & binutils is a bit special+    windowsExtraGccDir+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix+      | otherwise                       = baseDir+    windowsExtraLdDir+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix+      | otherwise                       = libDir+    windowsExtraArDir+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix+      | otherwise                       = libDir+    windowsExtraStripDir+      | ghcVersion >= Version [6,12] [] = mingwBinDir </> binPrefix+      | otherwise                       = libDir++    findProg :: Program -> [FilePath]+             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+    findProg prog extraPath v searchpath =+        programFindLocation prog v searchpath'+      where+        searchpath' = (map ProgramSearchPathDir extraPath) ++ searchpath++    -- Read tool locations from the 'ghc --info' output. Useful when+    -- cross-compiling.+    mbGccLocation   = M.lookup "C compiler command" ghcInfo+    mbLdLocation    = M.lookup "ld command" ghcInfo+    mbArLocation    = M.lookup "ar command" ghcInfo+    mbStripLocation = M.lookup "strip command" ghcInfo+     ccFlags        = getFlags "C compiler flags"     gccLinkerFlags = getFlags "Gcc Linker flags"     ldLinkerFlags  = getFlags "Ld Linker flags" -    getFlags key = case lookup key ghcInfo of+    getFlags key = case M.lookup key ghcInfo of                    Nothing -> []                    Just flags ->                        case reads flags of                        [(args, "")] -> args                        _ -> [] -- XXX Should should be an error really -    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureGcc v cp = liftM (++ (ccFlags ++ gccLinkerFlags))-                      $ configureGcc' v cp+    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureGcc v gccProg = do+      gccProg' <- configureGcc' v gccProg+      return gccProg' {+        programDefaultArgs = programDefaultArgs gccProg'+                             ++ ccFlags ++ gccLinkerFlags+      } -    configureGcc' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureGcc' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureGcc'       | isWindows = \_ gccProg -> case programLocation gccProg of           -- if it's found on system then it means we're using the result@@ -330,20 +367,25 @@           -- various files:           FoundOnSystem {}            | ghcVersion < Version [6,11] [] ->-              return ["-B" ++ libDir, "-I" ++ includeDir]-          _ -> return []-      | otherwise = \_ _   -> return []+               return gccProg { programDefaultArgs = ["-B" ++ libDir,+                                                      "-I" ++ includeDir] }+          _ -> return gccProg+      | otherwise = \_ gccProg -> return gccProg -    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]-    configureLd v cp = liftM (++ ldLinkerFlags) $ configureLd' v cp+    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram+    configureLd v ldProg = do+      ldProg' <- configureLd' v ldProg+      return ldProg' {+        programDefaultArgs = programDefaultArgs ldProg' ++ ldLinkerFlags+      }      -- we need to find out if ld supports the -x flag-    configureLd' :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureLd' :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureLd' verbosity ldProg = do       tempDir <- getTemporaryDirectory       ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->              withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() {}"+               hPutStrLn testchnd "int foo() { return 0; }"                hClose testchnd; hClose testohnd                rawSystemProgram verbosity ghcProg ["-c", testcfile,                                                    "-o", testofile]@@ -356,8 +398,8 @@                  `catchIO`   (\_ -> return False)                  `catchExit` (\_ -> return False)       if ldx-        then return ["-x"]-        else return []+        then return ldProg { programDefaultArgs = ["-x"] }+        else return ldProg  getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] getLanguages _ ghcProg@@ -368,11 +410,27 @@   where     Just ghcVersion = programVersion ghcProg +getGhcInfo :: Verbosity -> ConfiguredProgram -> IO [(String, String)]+getGhcInfo verbosity ghcProg =+    case programVersion ghcProg of+    Just ghcVersion+     | ghcVersion >= Version [6,7] [] ->+        do xs <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)+                 ["--info"]+           case reads xs of+               [(i, ss)]+                | all isSpace ss ->+                   return i+               _ ->+                   die "Can't parse --info output of GHC"+    _ ->+        return []+ getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Flag)] getExtensions verbosity ghcProg   | ghcVersion >= Version [6,7] [] = do -    str <- rawSystemStdout verbosity (programPath ghcProg)+    str <- getProgramOutput verbosity (suppressOverrideArgs ghcProg)               ["--supported-languages"]     let extStrs = if ghcVersion >= Version [7] []                   then lines str@@ -467,24 +525,24 @@     ,(DeriveDataTypeable         , fglasgowExts)     ,(ConstrainedClassMethods    , fglasgowExts)     ]+-- | Given a single package DB, return all installed packages.+getPackageDBContents :: Verbosity -> PackageDB -> ProgramConfiguration+                        -> IO PackageIndex+getPackageDBContents verbosity packagedb conf = do+  pkgss <- getInstalledPackages' verbosity [packagedb] conf+  toPackageIndex verbosity pkgss conf +-- | Given a package DB stack, return all installed packages. getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration                      -> IO PackageIndex getInstalledPackages verbosity packagedbs conf = do   checkPackageDbEnvVar   checkPackageDbStack packagedbs   pkgss <- getInstalledPackages' verbosity packagedbs conf-  topDir <- ghcLibDir' verbosity ghcProg-  let indexes = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)-                | (_, pkgs) <- pkgss ]-  return $! hackRtsPackage (mconcat indexes)+  index <- toPackageIndex verbosity pkgss conf+  return $! hackRtsPackage index    where-    -- On Windows, various fields have $topdir/foo rather than full-    -- paths. We need to substitute the right value in so that when-    -- we, for example, call gcc, we have proper paths to give it-    Just ghcProg = lookupProgram ghcProgram conf-     hackRtsPackage index =       case PackageIndex.lookupPackageName index (PackageName "rts") of         [(_,[rts])]@@ -492,10 +550,30 @@         _  -> index -- No (or multiple) ghc rts package is registered!!                     -- Feh, whatever, the ghc testsuite does some crazy stuff. +-- | Given a list of @(PackageDB, InstalledPackageInfo)@ pairs, produce a+-- @PackageIndex@. Helper function used by 'getPackageDBContents' and+-- 'getInstalledPackages'.+toPackageIndex :: Verbosity+               -> [(PackageDB, [InstalledPackageInfo])]+               -> ProgramConfiguration+               -> IO PackageIndex+toPackageIndex verbosity pkgss conf = do+  -- On Windows, various fields have $topdir/foo rather than full+  -- paths. We need to substitute the right value in so that when+  -- we, for example, call gcc, we have proper paths to give it.+  topDir <- ghcLibDir' verbosity ghcProg+  let indices = [ PackageIndex.fromList (map (substTopDir topDir) pkgs)+                | (_, pkgs) <- pkgss ]+  return $! (mconcat indices)++  where+    Just ghcProg = lookupProgram ghcProgram conf+ ghcLibDir :: Verbosity -> LocalBuildInfo -> IO FilePath ghcLibDir verbosity lbi =     (reverse . dropWhile isSpace . reverse) `fmap`-     rawSystemProgramStdoutConf verbosity ghcProgram (withPrograms lbi) ["--print-libdir"]+     rawSystemProgramStdoutConf verbosity ghcProgram+     (withPrograms lbi) ["--print-libdir"]  ghcLibDir' :: Verbosity -> ConfiguredProgram -> IO FilePath ghcLibDir' verbosity ghcProg =@@ -607,33 +685,55 @@  -- | Build a library with GHC. ---buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Library            -> ComponentLocalBuildInfo -> IO ()-buildLib verbosity pkg_descr lbi lib clbi = do-  let pref = buildDir lbi+buildLib, replLib :: Verbosity          -> Cabal.Flag (Maybe Int)+                  -> PackageDescription -> LocalBuildInfo+                  -> Library            -> ComponentLocalBuildInfo -> IO ()+buildLib = buildOrReplLib False+replLib  = buildOrReplLib True++buildOrReplLib :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)+               -> PackageDescription -> LocalBuildInfo+               -> Library            -> ComponentLocalBuildInfo -> IO ()+buildOrReplLib forRepl verbosity numJobsFlag pkg_descr lbi lib clbi = do+  libName <- case componentLibraries clbi of+             [libName] -> return libName+             [] -> die "No library name found when building library"+             _  -> die "Multiple library names found when building library"++  let libTargetDir = buildDir lbi+      numJobs = fromMaybe 1 $ fromFlagOrDefault Nothing numJobsFlag       pkgid = packageId pkg_descr-      ifVanillaLib forceVanilla = when (forceVanilla || withVanillaLib lbi)-      ifProfLib = when (withProfLib lbi)-      ifSharedLib = when (withSharedLib lbi)-      ifGHCiLib = when (withGHCiLib lbi && withVanillaLib lbi)+      whenVanillaLib forceVanilla =+        when (not forRepl && (forceVanilla || withVanillaLib lbi))+      whenProfLib = when (not forRepl && withProfLib lbi)+      whenSharedLib forceShared =+        when (not forRepl &&  (forceShared || withSharedLib lbi))+      whenGHCiLib = when (not forRepl && withGHCiLib lbi && withVanillaLib lbi)+      ifReplLib = when forRepl       comp = compiler lbi       ghcVersion = compilerVersion comp    (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let runGhcProg = runGHC verbosity ghcProg+  let runGhcProg = runGHC verbosity ghcProg comp    libBi <- hackThreadedFlag verbosity              comp (withProfLib lbi) (libBuildInfo lib) -  let libTargetDir = pref-      forceVanillaLib = EnableExtension TemplateHaskell `elem` allExtensions libBi-      -- TH always needs vanilla libs, even when building for profiling+  let isGhcDynamic        = ghcDynamic comp+      dynamicTooSupported = ghcSupportsDynamicToo comp+      doingTH = EnableExtension TemplateHaskell `elem` allExtensions libBi+      forceVanillaLib = doingTH && not isGhcDynamic+      forceSharedLib  = doingTH &&     isGhcDynamic+      -- TH always needs default libs, even when building for profiling    createDirectoryIfMissingVerbose verbosity True libTargetDir-  -- TODO: do we need to put hs-boot files into place for mutually recurive modules?-  let baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir+  -- TODO: do we need to put hs-boot files into place for mutually recursive+  -- modules?+  let cObjs       = map (`replaceExtension` objExtension) (cSources libBi)+      baseOpts    = componentGhcOptions verbosity lbi libBi clbi libTargetDir       vanillaOpts = baseOpts `mappend` mempty {                       ghcOptMode         = toFlag GhcModeMake,+                      ghcOptNumJobs      = toFlag numJobs,                       ghcOptPackageName  = toFlag pkgid,                       ghcOptInputModules = libModules lib                     }@@ -646,49 +746,91 @@                     }        sharedOpts  = vanillaOpts `mappend` mempty {-                      ghcOptDynamic   = toFlag True,-                      ghcOptFPic      = toFlag True,-                      ghcOptHiSuffix  = toFlag "dyn_hi",-                      ghcOptObjSuffix = toFlag "dyn_o",-                      ghcOptExtra     = ghcSharedOptions libBi+                      ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                      ghcOptFPic        = toFlag True,+                      ghcOptHiSuffix    = toFlag "dyn_hi",+                      ghcOptObjSuffix   = toFlag "dyn_o",+                      ghcOptExtra       = ghcSharedOptions libBi                     }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = PD.ldOptions libBi,+                      ghcOptLinkLibs       = extraLibs libBi,+                      ghcOptLinkLibPath    = extraLibDirs libBi,+                      ghcOptLinkFrameworks = PD.frameworks libBi,+                      ghcOptInputFiles     = [libTargetDir </> x | x <- cObjs]+                   }+      replOpts    = vanillaOpts {+                      ghcOptExtra        = filterGhciFlags+                                           (ghcOptExtra vanillaOpts),+                      ghcOptNumJobs      = mempty+                    }+                    `mappend` linkerOpts+                    `mappend` mempty {+                      ghcOptMode         = toFlag GhcModeInteractive,+                      ghcOptOptimisation = toFlag GhcNoOptimisation+                    } +      vanillaSharedOpts = vanillaOpts `mappend` mempty {+                      ghcOptDynLinkMode  = toFlag GhcStaticAndDynamic,+                      ghcOptDynHiSuffix  = toFlag "dyn_hi",+                      ghcOptDynObjSuffix = toFlag "dyn_o"+                    }+   unless (null (libModules lib)) $-    do ifVanillaLib forceVanillaLib (runGhcProg vanillaOpts)-       ifProfLib (runGhcProg profOpts)-       ifSharedLib (runGhcProg sharedOpts)+    do let vanilla = whenVanillaLib forceVanillaLib (runGhcProg vanillaOpts)+           shared  = whenSharedLib  forceSharedLib  (runGhcProg sharedOpts)+           useDynToo = dynamicTooSupported &&+                       (forceVanillaLib || withVanillaLib lbi) &&+                       (forceSharedLib  || withSharedLib  lbi) &&+                       null (ghcSharedOptions libBi)+       if useDynToo+           then runGhcProg vanillaSharedOpts+           else if isGhcDynamic then do shared;  vanilla+                                else do vanilla; shared+       whenProfLib (runGhcProg profOpts)    -- build any C sources   unless (null (cSources libBi)) $ do      info verbosity "Building C Sources..."      sequence_        [ do let vanillaCcOpts = (componentCcGhcOptions verbosity lbi-                                    libBi clbi pref filename) `mappend` mempty {-                                  ghcOptProfilingMode = toFlag (withProfLib lbi)+                                    libBi clbi libTargetDir filename)+                profCcOpts    = vanillaCcOpts `mappend` mempty {+                                  ghcOptProfilingMode = toFlag True,+                                  ghcOptObjSuffix     = toFlag "p_o"                                 }                 sharedCcOpts  = vanillaCcOpts `mappend` mempty {-                                  ghcOptFPic      = toFlag True,-                                  ghcOptDynamic   = toFlag True,-                                  ghcOptObjSuffix = toFlag "dyn_o"+                                  ghcOptFPic        = toFlag True,+                                  ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                                  ghcOptObjSuffix   = toFlag "dyn_o"                                 }                 odir          = fromFlag (ghcOptObjDir vanillaCcOpts)             createDirectoryIfMissingVerbose verbosity True odir             runGhcProg vanillaCcOpts-            ifSharedLib (runGhcProg sharedCcOpts)+            whenSharedLib forceSharedLib (runGhcProg sharedCcOpts)+            whenProfLib (runGhcProg profCcOpts)        | filename <- cSources libBi] +  -- TODO: problem here is we need the .c files built first, so we can load them+  -- with ghci, but .c files can depend on .h files generated by ghc by ffi+  -- exports.+  unless (null (libModules lib)) $+     ifReplLib (runGhcProg replOpts)++   -- link:   info verbosity "Linking..."-  let cObjs = map (`replaceExtension` objExtension) (cSources libBi)-      cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)-      vanillaLibFilePath = libTargetDir </> mkLibName pkgid-      profileLibFilePath = libTargetDir </> mkProfLibName pkgid-      sharedLibFilePath  = libTargetDir </> mkSharedLibName pkgid-                                              (compilerId (compiler lbi))-      ghciLibFilePath    = libTargetDir </> mkGHCiLibName pkgid+  let cProfObjs   = map (`replaceExtension` ("p_" ++ objExtension))+                    (cSources libBi)+      cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension))+                    (cSources libBi)+      cid = compilerId (compiler lbi)+      vanillaLibFilePath = libTargetDir </> mkLibName           libName+      profileLibFilePath = libTargetDir </> mkProfLibName       libName+      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName+      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       libName       libInstallPath = libdir $ absoluteInstallDirs pkg_descr lbi NoCopyDest-      sharedLibInstallPath = libInstallPath </> mkSharedLibName pkgid-                                              (compilerId (compiler lbi))+      sharedLibInstallPath = libInstallPath </> mkSharedLibName cid libName    stubObjs <- fmap catMaybes $ sequence     [ findFileWithExtension [objExtension] [libTargetDir]@@ -707,40 +849,35 @@     , x <- libModules lib ]    hObjs     <- getHaskellObjects lib lbi-                    pref objExtension True+                    libTargetDir objExtension True   hProfObjs <-     if (withProfLib lbi)             then getHaskellObjects lib lbi-                    pref ("p_" ++ objExtension) True+                    libTargetDir ("p_" ++ objExtension) True             else return []   hSharedObjs <-     if (withSharedLib lbi)             then getHaskellObjects lib lbi-                    pref ("dyn_" ++ objExtension) False+                    libTargetDir ("dyn_" ++ objExtension) False             else return []    unless (null hObjs && null cObjs && null stubObjs) $ do-    -- first remove library files if they exists-    sequence_-      [ removeFile libFilePath `catchIO` \_ -> return ()-      | libFilePath <- [vanillaLibFilePath, profileLibFilePath-                       ,sharedLibFilePath,  ghciLibFilePath] ]      let staticObjectFiles =                hObjs-            ++ map (pref </>) cObjs+            ++ map (libTargetDir </>) cObjs             ++ stubObjs         profObjectFiles =                hProfObjs-            ++ map (pref </>) cObjs+            ++ map (libTargetDir </>) cProfObjs             ++ stubProfObjs         ghciObjFiles =                hObjs-            ++ map (pref </>) cObjs+            ++ map (libTargetDir </>) cObjs             ++ stubObjs         dynamicObjectFiles =                hSharedObjs-            ++ map (pref </>) cSharedObjs+            ++ map (libTargetDir </>) cSharedObjs             ++ stubSharedObjs         -- After the relocation lib is created we invoke ghc -shared         -- with the dependencies spelled out as -package arguments@@ -748,7 +885,7 @@         ghcSharedLinkArgs =             mempty {               ghcOptShared             = toFlag True,-              ghcOptDynamic            = toFlag True,+              ghcOptDynLinkMode        = toFlag GhcDynamicOnly,               ghcOptInputFiles         = dynamicObjectFiles,               ghcOptOutputFile         = toFlag sharedLibFilePath,               -- For dynamic libs, Mac OS/X needs to know the install location@@ -764,104 +901,194 @@               ghcOptLinkLibPath        = extraLibDirs libBi             } -    ifVanillaLib False $ do-      (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)-      Ar.createArLibArchive verbosity arProg+    whenVanillaLib False $ do+      Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)         vanillaLibFilePath staticObjectFiles -    ifProfLib $ do-      (arProg, _) <- requireProgram verbosity arProgram (withPrograms lbi)-      Ar.createArLibArchive verbosity arProg+    whenProfLib $ do+      Ar.createArLibArchive verbosity (withPrograms lbi) (stripLibs lbi)         profileLibFilePath profObjectFiles -    ifGHCiLib $ do+    whenGHCiLib $ do       (ldProg, _) <- requireProgram verbosity ldProgram (withPrograms lbi)       Ld.combineObjectFiles verbosity ldProg         ghciLibFilePath ghciObjFiles -    ifSharedLib $+    whenSharedLib False $       runGhcProg ghcSharedLinkArgs +-- | Start a REPL without loading any source files.+startInterpreter :: Verbosity -> ProgramConfiguration -> Compiler+                 -> PackageDBStack -> IO ()+startInterpreter verbosity conf comp packageDBs = do+  let replOpts = mempty {+        ghcOptMode       = toFlag GhcModeInteractive,+        ghcOptPackageDBs = packageDBs+        }+  checkPackageDbStack packageDBs+  (ghcProg, _) <- requireProgram verbosity ghcProgram conf+  runGHC verbosity ghcProg comp replOpts  -- | Build an executable with GHC. ---buildExe :: Verbosity -> PackageDescription -> LocalBuildInfo-                      -> Executable         -> ComponentLocalBuildInfo -> IO ()-buildExe verbosity _pkg_descr lbi+buildExe, replExe :: Verbosity          -> Cabal.Flag (Maybe Int)+                  -> PackageDescription -> LocalBuildInfo+                  -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildExe = buildOrReplExe False+replExe  = buildOrReplExe True++buildOrReplExe :: Bool -> Verbosity  -> Cabal.Flag (Maybe Int)+               -> PackageDescription -> LocalBuildInfo+               -> Executable         -> ComponentLocalBuildInfo -> IO ()+buildOrReplExe forRepl verbosity numJobsFlag _pkg_descr lbi   exe@Executable { exeName = exeName', modulePath = modPath } clbi = do-  let pref = buildDir lbi    (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  let runGhcProg = runGHC verbosity ghcProg+  let comp       = compiler lbi+      numJobs    = fromMaybe 1 $+                   fromFlagOrDefault Nothing numJobsFlag+      runGhcProg = runGHC verbosity ghcProg comp    exeBi <- hackThreadedFlag verbosity-             (compiler lbi) (withProfExe lbi) (buildInfo exe)+             comp (withProfExe lbi) (buildInfo exe)    -- exeNameReal, the name that GHC really uses (with .exe on Windows)   let exeNameReal = exeName' <.>-                    (if null $ takeExtension exeName' then exeExtension else "")+                    (if takeExtension exeName' /= ('.':exeExtension)+                       then exeExtension+                       else "") -  let targetDir = pref </> exeName'+  let targetDir = (buildDir lbi) </> exeName'   let exeDir    = targetDir </> (exeName' ++ "-tmp")   createDirectoryIfMissingVerbose verbosity True targetDir   createDirectoryIfMissingVerbose verbosity True exeDir-  -- TODO: do we need to put hs-boot files into place for mutually recursive modules?-  -- FIX: what about exeName.hi-boot?+  -- TODO: do we need to put hs-boot files into place for mutually recursive+  -- modules?  FIX: what about exeName.hi-boot?    -- build executables-  unless (null (cSources exeBi)) $ do-   info verbosity "Building C Sources."-   sequence_-     [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi-                         exeDir filename) `mappend` mempty {-                       ghcOptDynamic       = toFlag (withDynExe lbi),-                       ghcOptProfilingMode = toFlag (withProfExe lbi)-                     }-              odir = fromFlag (ghcOptObjDir opts)-          createDirectoryIfMissingVerbose verbosity True odir-          runGhcProg opts-     | filename <- cSources exeBi] -  srcMainFile <- findFile (exeDir : hsSourceDirs exeBi) modPath--  let cObjs = map (`replaceExtension` objExtension) (cSources exeBi)-  let vanillaOpts = (componentGhcOptions verbosity lbi exeBi clbi exeDir)+  srcMainFile         <- findFile (exeDir : hsSourceDirs exeBi) modPath+  let isGhcDynamic        = ghcDynamic comp+      dynamicTooSupported = ghcSupportsDynamicToo comp+      isHaskellMain = elem (takeExtension srcMainFile) [".hs", ".lhs"]+      cSrcs         = cSources exeBi ++ [srcMainFile | not isHaskellMain]+      cObjs         = map (`replaceExtension` objExtension) cSrcs+      baseOpts   = (componentGhcOptions verbosity lbi exeBi clbi exeDir)                     `mappend` mempty {-                      ghcOptMode           = toFlag GhcModeMake,-                      ghcOptInputFiles     = [exeDir </> x | x <- cObjs]-                                          ++ [srcMainFile],-                      ghcOptLinkOptions    = PD.ldOptions exeBi,-                      ghcOptLinkLibs       = extraLibs exeBi,-                      ghcOptLinkLibPath    = extraLibDirs exeBi,-                      ghcOptLinkFrameworks = PD.frameworks exeBi+                      ghcOptMode         = toFlag GhcModeMake,+                      ghcOptInputFiles   =+                        [ srcMainFile | isHaskellMain],+                      ghcOptInputModules =+                        [ m | not isHaskellMain, m <- exeModules exe]                     }--      exeOpts     | withProfExe lbi = vanillaOpts `mappend` mempty {+      staticOpts = baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticOnly+                   }+      profOpts   = baseOpts `mappend` mempty {                       ghcOptProfilingMode  = toFlag True,                       ghcOptHiSuffix       = toFlag "p_hi",                       ghcOptObjSuffix      = toFlag "p_o",                       ghcOptExtra          = ghcProfOptions exeBi                     }-                  | withDynExe lbi = vanillaOpts `mappend` mempty {-                      ghcOptDynamic        = toFlag True,+      dynOpts    = baseOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcDynamicOnly,                       ghcOptHiSuffix       = toFlag "dyn_hi",                       ghcOptObjSuffix      = toFlag "dyn_o",                       ghcOptExtra          = ghcSharedOptions exeBi                     }-                  | otherwise = vanillaOpts+      dynTooOpts = staticOpts `mappend` mempty {+                      ghcOptDynLinkMode    = toFlag GhcStaticAndDynamic,+                      ghcOptDynHiSuffix    = toFlag "dyn_hi",+                      ghcOptDynObjSuffix   = toFlag "dyn_o"+                    }+      linkerOpts = mempty {+                      ghcOptLinkOptions    = PD.ldOptions exeBi,+                      ghcOptLinkLibs       = extraLibs exeBi,+                      ghcOptLinkLibPath    = extraLibDirs exeBi,+                      ghcOptLinkFrameworks = PD.frameworks exeBi,+                      ghcOptInputFiles     = [exeDir </> x | x <- cObjs]+                   }+      replOpts   = baseOpts {+                      ghcOptExtra          = filterGhciFlags+                                             (ghcOptExtra baseOpts)+                   }+                   -- For a normal compile we do separate invocations of ghc for+                   -- compiling as for linking. But for repl we have to do just+                   -- the one invocation, so that one has to include all the+                   -- linker stuff too, like -l flags and any .o files from C+                   -- files etc.+                   `mappend` linkerOpts+                   `mappend` mempty {+                      ghcOptMode           = toFlag GhcModeInteractive,+                      ghcOptOptimisation   = toFlag GhcNoOptimisation+                   }+      commonOpts  | withProfExe lbi = profOpts+                  | withDynExe  lbi = dynOpts+                  | otherwise       = staticOpts+      compileOpts | useDynToo = dynTooOpts+                  | otherwise = commonOpts+      withStaticExe = (not $ withProfExe lbi) && (not $ withDynExe lbi) -  -- For building exe's for profiling that use TH we actually-  -- have to build twice, once without profiling and the again-  -- with profiling. This is because the code that TH needs to-  -- run at compile time needs to be the vanilla ABI so it can-  -- be loaded up and run by the compiler.-  when ((withProfExe lbi || withDynExe lbi) &&-        EnableExtension TemplateHaskell `elem` allExtensions exeBi) $-    runGhcProg vanillaOpts { ghcOptNoLink = toFlag True }+      -- For building exe's that use TH with -prof or -dynamic we actually have+      -- to build twice, once without -prof/-dynamic and then again with+      -- -prof/-dynamic. This is because the code that TH needs to run at+      -- compile time needs to be the vanilla ABI so it can be loaded up and run+      -- by the compiler.+      -- With dynamic-by-default GHC the TH object files loaded at compile-time+      -- need to be .dyn_o instead of .o.+      doingTH = EnableExtension TemplateHaskell `elem` allExtensions exeBi+      -- Should we use -dynamic-too instead of compilng twice?+      useDynToo = dynamicTooSupported && isGhcDynamic+                  && doingTH && withStaticExe && null (ghcSharedOptions exeBi)+      compileTHOpts | isGhcDynamic = dynOpts+                    | otherwise    = staticOpts+      compileForTH+        | forRepl      = False+        | useDynToo    = False+        | isGhcDynamic = doingTH && (withProfExe lbi || withStaticExe)+        | otherwise    = doingTH && (withProfExe lbi || withDynExe lbi) -  runGhcProg exeOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }+      linkOpts = commonOpts `mappend`+                 linkerOpts `mappend` mempty {+                      ghcOptLinkNoHsMain   = toFlag (not isHaskellMain)+                 } +  -- Build static/dynamic object files for TH, if needed.+  when compileForTH $+    runGhcProg compileTHOpts { ghcOptNoLink  = toFlag True+                             , ghcOptNumJobs = toFlag numJobs } +  unless forRepl $+    runGhcProg compileOpts { ghcOptNoLink  = toFlag True+                           , ghcOptNumJobs = toFlag numJobs }++  -- build any C sources+  unless (null cSrcs) $ do+   info verbosity "Building C Sources..."+   sequence_+     [ do let opts = (componentCcGhcOptions verbosity lbi exeBi clbi+                         exeDir filename) `mappend` mempty {+                       ghcOptDynLinkMode   = toFlag (if withDynExe lbi+                                                       then GhcDynamicOnly+                                                       else GhcStaticOnly),+                       ghcOptProfilingMode = toFlag (withProfExe lbi)+                     }+              odir = fromFlag (ghcOptObjDir opts)+          createDirectoryIfMissingVerbose verbosity True odir+          runGhcProg opts+     | filename <- cSrcs ]++  -- TODO: problem here is we need the .c files built first, so we can load them+  -- with ghci, but .c files can depend on .h files generated by ghc by ffi+  -- exports.+  when forRepl $ runGhcProg replOpts++  -- link:+  unless forRepl $ do+    info verbosity "Linking..."+    runGhcProg linkOpts { ghcOptOutputFile = toFlag (targetDir </> exeNameReal) }++ -- | Filter the "-threaded" flag when profiling as it does not --   work with ghc-6.8 and older. hackThreadedFlag :: Verbosity -> Compiler -> Bool -> BuildInfo -> IO BuildInfo@@ -878,6 +1105,19 @@       [ (hc, if hc == GHC then filter p opts else opts)       | (hc, opts) <- hcoptss ] +-- | Strip out flags that are not supported in ghci+filterGhciFlags :: [String] -> [String]+filterGhciFlags = filter supported+  where+    supported ('-':'O':_) = False+    supported "-debug"    = False+    supported "-threaded" = False+    supported "-ticky"    = False+    supported "-eventlog" = False+    supported "-prof"     = False+    supported "-unreg"    = False+    supported _           = True+ -- when using -split-objs, we need to search for object files in the -- Module_split directory for each module. getHaskellObjects :: Library -> LocalBuildInfo@@ -909,16 +1149,34 @@   libBi <- hackThreadedFlag verbosity              (compiler lbi) (withProfLib lbi) (libBuildInfo lib)   let-      ghcArgs =+      comp        = compiler lbi+      vanillaArgs =         (componentGhcOptions verbosity lbi libBi clbi (buildDir lbi))         `mappend` mempty {           ghcOptMode         = toFlag GhcModeAbiHash,           ghcOptPackageName  = toFlag (packageId pkg_descr),           ghcOptInputModules = exposedModules lib         }+      sharedArgs = vanillaArgs `mappend` mempty {+                       ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                       ghcOptFPic        = toFlag True,+                       ghcOptHiSuffix    = toFlag "dyn_hi",+                       ghcOptObjSuffix   = toFlag "dyn_o",+                       ghcOptExtra       = ghcSharedOptions libBi+                   }+      profArgs = vanillaArgs `mappend` mempty {+                     ghcOptProfilingMode = toFlag True,+                     ghcOptHiSuffix      = toFlag "p_hi",+                     ghcOptObjSuffix     = toFlag "p_o",+                     ghcOptExtra         = ghcProfOptions libBi+                 }+      ghcArgs = if withVanillaLib lbi then vanillaArgs+           else if withSharedLib  lbi then sharedArgs+           else if withProfLib    lbi then profArgs+           else error "libAbiHash: Can't find an enabled library way"   --   (ghcProg, _) <- requireProgram verbosity ghcProgram (withPrograms lbi)-  getProgramInvocationOutput verbosity (ghcInvocation ghcProg ghcArgs)+  getProgramInvocationOutput verbosity (ghcInvocation ghcProg comp ghcArgs)   componentGhcOptions :: Verbosity -> LocalBuildInfo@@ -943,6 +1201,7 @@       ghcOptObjDir          = toFlag odir,       ghcOptHiDir           = toFlag odir,       ghcOptStubDir         = toFlag odir,+      ghcOptOutputDir       = toFlag odir,       ghcOptOptimisation    = toGhcOptimisation (withOptimization lbi),       ghcOptExtra           = hcOptions GHC bi,       ghcOptLanguage        = toFlag (fromMaybe Haskell98 (defaultLanguage bi)),@@ -966,7 +1225,8 @@       ghcOptMode           = toFlag GhcModeCompile,       ghcOptInputFiles     = [filename], -      ghcOptCppIncludePath = odir : PD.includeDirs bi,+      ghcOptCppIncludePath = [autogenModulesDir lbi, odir]+                                   ++ PD.includeDirs bi,       ghcOptPackageDBs     = withPackageDB lbi,       ghcOptPackages       = componentPackageDeps clbi,       ghcOptCcOptions      = PD.ccOptions bi@@ -980,27 +1240,8 @@          | otherwise = pref </> takeDirectory filename          -- ghc 6.4.0 had a bug in -odir handling for C compilations. -{-# DEPRECATED ghcVerbosityOptions "Use the GhcOptions record instead" #-}-ghcVerbosityOptions :: Verbosity -> [String]-ghcVerbosityOptions verbosity-     | verbosity >= deafening = ["-v"]-     | verbosity >= normal    = []-     | otherwise              = ["-w", "-v0"]--{-# DEPRECATED ghcPackageDbOptions "Use the GhcOptions record instead" #-}-ghcPackageDbOptions :: PackageDBStack -> [String]-ghcPackageDbOptions dbstack = case dbstack of-  (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-  (GlobalPackageDB:dbs)               -> "-no-user-package-conf"-                                       : concatMap specific dbs-  _                                   -> ierror-  where-    specific (SpecificPackageDB db) = [ "-package-conf", db ]-    specific _ = ierror-    ierror     = error ("internal error: unexpected package db stack: " ++ show dbstack)--mkGHCiLibName :: PackageIdentifier -> String-mkGHCiLibName lib = "HS" ++ display lib <.> "o"+mkGHCiLibName :: LibraryName -> String+mkGHCiLibName (LibraryName lib) = lib <.> "o"  -- ----------------------------------------------------------------------------- -- Installing@@ -1014,7 +1255,8 @@            -> PackageDescription            -> Executable            -> IO ()-installExe verbosity lbi installDirs buildPref (progprefix, progsuffix) _pkg exe = do+installExe verbosity lbi installDirs buildPref+  (progprefix, progsuffix) _pkg exe = do   let binDir = bindir installDirs   createDirectoryIfMissingVerbose verbosity True binDir   let exeFileName = exeName exe <.> exeExtension@@ -1023,26 +1265,10 @@           installExecutableFile verbosity             (buildPref </> exeName exe </> exeFileName)             (dest <.> exeExtension)-          stripExe verbosity lbi exeFileName (dest <.> exeExtension)+          when (stripExes lbi) $+            Strip.stripExe verbosity (withPrograms lbi) (dest <.> exeExtension)   installBinary (binDir </> fixedExeBaseName) -stripExe :: Verbosity -> LocalBuildInfo -> FilePath -> FilePath -> IO ()-stripExe verbosity lbi name path = when (stripExes lbi) $-  case lookupProgram stripProgram (withPrograms lbi) of-    Just strip -> rawSystemProgram verbosity strip args-    Nothing    -> unless (buildOS == Windows) $-                  -- Don't bother warning on windows, we don't expect them to-                  -- have the strip program anyway.-                  warn verbosity $ "Unable to strip executable '" ++ name-                                ++ "' (missing the 'strip' program)"-  where-    args = path : case buildOS of-       OSX -> ["-x"] -- By default, stripping the ghc binary on at least-                     -- some OS X installations causes:-                     --     HSbase-3.0.o: unknown symbol `_environ'"-                     -- The -x flag fixes that.-       _   -> []- -- |Install for ghc, .hi, .a and, if --with-ghci given, .o installLib    :: Verbosity               -> LocalBuildInfo@@ -1051,59 +1277,51 @@               -> FilePath  -- ^Build location               -> PackageDescription               -> Library+              -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do   -- copy .hi files over:-  let copyHelper installFun src dst n = do-        createDirectoryIfMissingVerbose verbosity True dst-        installFun verbosity (src </> n) (dst </> n)-      copy       = copyHelper installOrdinaryFile-      copyShared = copyHelper installExecutableFile-      copyModuleFiles ext =-        findModuleFiles [builtDir] [ext] (libModules lib)-          >>= installOrdinaryFiles verbosity targetDir-  ifVanilla $ copyModuleFiles "hi"-  ifProf    $ copyModuleFiles "p_hi"-  ifShared  $ copyModuleFiles "dyn_hi"+  whenVanilla $ copyModuleFiles "hi"+  whenProf    $ copyModuleFiles "p_hi"+  whenShared  $ copyModuleFiles "dyn_hi"    -- copy the built library files over:-  ifVanilla $ copy builtDir targetDir vanillaLibName-  ifProf    $ copy builtDir targetDir profileLibName-  ifGHCi    $ copy builtDir targetDir ghciLibName-  ifShared  $ copyShared builtDir dynlibTargetDir sharedLibName--  -- run ranlib if necessary:-  ifVanilla $ updateLibArchive verbosity lbi-                               (targetDir </> vanillaLibName)-  ifProf    $ updateLibArchive verbosity lbi-                               (targetDir </> profileLibName)+  whenVanilla $ mapM_ (installOrdinary builtDir targetDir)       vanillaLibNames+  whenProf    $ mapM_ (installOrdinary builtDir targetDir)       profileLibNames+  whenGHCi    $ mapM_ (installOrdinary builtDir targetDir)       ghciLibNames+  whenShared  $ mapM_ (installShared   builtDir dynlibTargetDir) sharedLibNames    where-    vanillaLibName = mkLibName pkgid-    profileLibName = mkProfLibName pkgid-    ghciLibName    = mkGHCiLibName pkgid-    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))+    install isShared srcDir dstDir name = do+      let src = srcDir </> name+          dst = dstDir </> name+      createDirectoryIfMissingVerbose verbosity True dstDir+      if isShared+        then do when (stripLibs lbi) $+                  Strip.stripLib verbosity (withPrograms lbi) src+                installExecutableFile verbosity src dst+        else installOrdinaryFile   verbosity src dst -    pkgid          = packageId pkg+    installOrdinary = install False+    installShared   = install True +    copyModuleFiles ext =+      findModuleFiles [builtDir] [ext] (libModules lib)+      >>= installOrdinaryFiles verbosity targetDir++    cid = compilerId (compiler lbi)+    libNames = componentLibraries clbi+    vanillaLibNames = map mkLibName             libNames+    profileLibNames = map mkProfLibName         libNames+    ghciLibNames    = map mkGHCiLibName         libNames+    sharedLibNames  = map (mkSharedLibName cid) libNames+     hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))-    ifVanilla = when (hasLib && withVanillaLib lbi)-    ifProf    = when (hasLib && withProfLib    lbi)-    ifGHCi    = when (hasLib && withGHCiLib    lbi)-    ifShared  = when (hasLib && withSharedLib  lbi)---- | On MacOS X we have to call @ranlib@ to regenerate the archive index after--- copying. This is because the silly MacOS X linker checks that the archive--- index is not older than the file itself, which means simply--- copying/installing the file breaks it!!----updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()-updateLibArchive verbosity lbi path-  | buildOS == OSX = do-    (ranlib, _) <- requireProgram verbosity ranlibProgram (withPrograms lbi)-    rawSystemProgram verbosity ranlib [path]-  | otherwise = return ()+    whenVanilla = when (hasLib && withVanillaLib lbi)+    whenProf    = when (hasLib && withProfLib    lbi)+    whenGHCi    = when (hasLib && withGHCiLib    lbi)+    whenShared  = when (hasLib && withSharedLib  lbi)  -- ----------------------------------------------------------------------------- -- Registering@@ -1114,6 +1332,15 @@   where     Just ghcPkgProg = lookupProgram ghcPkgProgram conf +-- | Run 'ghc-pkg' using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+invokeHcPkg :: Verbosity -> ProgramConfiguration -> PackageDBStack -> [String]+               -> IO ()+invokeHcPkg verbosity conf dbStack extraArgs =+    HcPkg.invoke verbosity ghcPkgProg dbStack extraArgs+  where+    Just ghcPkgProg = lookupProgram ghcPkgProgram conf+ registerPackage   :: Verbosity   -> InstalledPackageInfo@@ -1125,3 +1352,18 @@ registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do   let Just ghcPkg = lookupProgram ghcPkgProgram (withPrograms lbi)   HcPkg.reregister verbosity ghcPkg packageDbs (Right installedPkgInfo)++-- -----------------------------------------------------------------------------+-- Utils++ghcLookupProperty :: String -> Compiler -> Bool+ghcLookupProperty prop comp =+  case M.lookup prop (compilerProperties comp) of+    Just "YES" -> True+    _          -> False++ghcDynamic :: Compiler -> Bool+ghcDynamic = ghcLookupProperty "GHC Dynamic"++ghcSupportsDynamicToo :: Compiler -> Bool+ghcSupportsDynamicToo = ghcLookupProperty "Support dynamic-too"
cabal/Cabal/Distribution/Simple/Haddock.hs view
@@ -6,12 +6,12 @@ -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable ----- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is--- a rather complicated module. It deals with two versions of haddock (0.x and--- 2.x). It has to do pre-processing for haddock 0.x which involves--- \'unlit\'ing and using @-DHADDOCK@ for any source code that uses @cpp@. It--- uses information about installed packages (from @ghc-pkg@) to find the--- locations of documentation for dependent packages, so it can create links.+-- This module deals with the @haddock@ and @hscolour@ commands. Sadly this is a+-- rather complicated module. It deals with two versions of haddock (0.x and+-- 2.x). It has to do pre-processing which involves \'unlit\'ing and using+-- @-D__HADDOCK__@ for any source code that uses @cpp@. It uses information+-- about installed packages (from @ghc-pkg@) to find the locations of+-- documentation for dependent packages, so it can create links. -- -- The @hscolour@ support allows generating html versions of the original -- source, with coloured syntax highlighting.@@ -52,15 +52,20 @@  -- local import Distribution.Package-         ( PackageIdentifier, Package(..), packageName )+         ( PackageIdentifier(..)+         , Package(..)+         , PackageName(..), packageName ) import qualified Distribution.ModuleName as ModuleName import Distribution.PackageDescription as PD          ( PackageDescription(..), BuildInfo(..), allExtensions-         , Library(..), hasLibs, Executable(..) )+         , Library(..), hasLibs, Executable(..)+         , TestSuite(..), TestSuiteInterface(..)+         , Benchmark(..), BenchmarkInterface(..) ) import Distribution.Simple.Compiler          ( Compiler(..), compilerVersion ) import Distribution.Simple.GHC ( componentGhcOptions, ghcLibDir )-import Distribution.Simple.Program.GHC ( GhcOptions(..), renderGhcOptions )+import Distribution.Simple.Program.GHC+         ( GhcOptions(..), GhcDynLinkMode(..), renderGhcOptions ) import Distribution.Simple.Program          ( ConfiguredProgram(..), requireProgramVersion          , rawSystemProgram, rawSystemProgramStdout@@ -75,11 +80,10 @@ import Distribution.Simple.InstallDirs (InstallDirs(..), PathTemplateEnv, PathTemplate,                                         PathTemplateVariable(..),                                         toPathTemplate, fromPathTemplate,-                                        substPathTemplate,-                                        initialPathTemplateEnv)+                                        substPathTemplate, initialPathTemplateEnv) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), Component(..), ComponentLocalBuildInfo(..)-         , withComponentsLBI )+         , withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( haddockName,                                         hscolourPref, autogenModulesDir,                                         )@@ -90,9 +94,11 @@ import Distribution.InstalledPackageInfo          ( InstalledPackageInfo ) import Distribution.Simple.Utils-         ( die, warn, notice, intercalate, setupMessage-         , createDirectoryIfMissingVerbose, withTempFile, copyFileVerbose-         , withTempDirectory+         ( die, copyFileTo, warn, notice, intercalate, setupMessage+         , createDirectoryIfMissingVerbose+         , TempFileOptions(..), defaultTempFileOptions+         , withTempFileEx, copyFileVerbose+         , withTempDirectoryEx, matchFileGlob          , findFileWithExtension, findFile ) import Distribution.Text          ( display, simpleParse )@@ -102,13 +108,13 @@ -- Base import System.Directory(removeFile, doesFileExist, createDirectoryIfMissing) -import Control.Monad ( when, guard )+import Control.Monad ( when, guard, forM_ ) import Control.Exception (assert) import Data.Monoid import Data.Maybe    ( fromMaybe, listToMaybe )  import System.FilePath((</>), (<.>), splitFileName, splitExtension,-                       normalise, splitPath, joinPath)+                       normalise, splitPath, joinPath, isAbsolute ) import System.IO (hClose, hPutStrLn) import Distribution.Version @@ -125,7 +131,7 @@  argContents :: Flag String,                      -- ^ optional url to contents page  argVerbose :: Any,  argOutput :: Flag [Output],                      -- ^ Html or Hoogle doc or both?                                   required.- argInterfaces :: [(FilePath, Maybe FilePath)],   -- ^ [(interface file, path to the html docs for links)]+ argInterfaces :: [(FilePath, Maybe String)],     -- ^ [(interface file, URL to the html docs for links)]  argOutputDir :: Directory,                       -- ^ where to generate the documentation.  argTitle :: Flag String,                         -- ^ page's title,                                         required.  argPrologue :: Flag String,                      -- ^ prologue text,                                        required.@@ -150,10 +156,13 @@ haddock :: PackageDescription -> LocalBuildInfo -> [PPSuffixHandler] -> HaddockFlags -> IO () haddock pkg_descr _ _ haddockFlags   |    not (hasLibs pkg_descr)-    && not (fromFlag $ haddockExecutables haddockFlags) =+    && not (fromFlag $ haddockExecutables haddockFlags)+    && not (fromFlag $ haddockTestSuites  haddockFlags)+    && not (fromFlag $ haddockBenchmarks  haddockFlags) =       warn (fromFlag $ haddockVerbosity haddockFlags) $            "No documentation was generated as this package does not contain "-        ++ "a library. Perhaps you want to use the --executables flag."+        ++ "a library. Perhaps you want to use the --executables, --tests or"+        ++ " --benchmarks flags."  haddock pkg_descr lbi suffixes flags = do @@ -185,7 +194,7 @@               ++ "GHC version.\n"               ++ "The GHC version is " ++ display ghcVersion ++ " but "               ++ "haddock is using GHC version " ++ display haddockGhcVersion-          where ghcVersion = compilerVersion (compiler lbi)+          where ghcVersion = compilerVersion comp      -- the tools match the requests, we can proceed @@ -201,39 +210,54 @@             , fromPackageDescription pkg_descr ]      let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withComponentsLBI pkg_descr lbi $ \comp clbi -> do-      pre comp-      case comp of+    withAllComponentsInBuildOrder pkg_descr lbi $ \component clbi -> do+      pre component+      let+        doExe com = case (compToExe com) of+          Just exe -> do+            withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do+              let bi = buildInfo exe+              exeArgs  <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate+              exeArgs' <- prepareSources verbosity tmp+                            lbi version bi (commonArgs `mappend` exeArgs)+              runHaddock verbosity tmpFileOpts comp confHaddock exeArgs'+          Nothing -> do+           warn (fromFlag $ haddockVerbosity flags)+             "Unsupported component, skipping..."+           return ()+      case component of         CLib lib -> do-          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do+          withTempDirectoryEx verbosity tmpFileOpts (buildDir lbi) "tmp" $ \tmp -> do             let bi = libBuildInfo lib             libArgs  <- fromLibrary verbosity tmp lbi lib clbi htmlTemplate             libArgs' <- prepareSources verbosity tmp-                          lbi isVersion2 bi (commonArgs `mappend` libArgs)-            runHaddock verbosity confHaddock libArgs'-        CExe exe -> when (flag haddockExecutables) $ do-          withTempDirectory verbosity (buildDir lbi) "tmp" $ \tmp -> do-            let bi = buildInfo exe-            exeArgs  <- fromExecutable verbosity tmp lbi exe clbi htmlTemplate-            exeArgs' <- prepareSources verbosity tmp-                          lbi isVersion2 bi (commonArgs `mappend` exeArgs)-            runHaddock verbosity confHaddock exeArgs'-        _ -> return ()+                          lbi version bi (commonArgs `mappend` libArgs)+            runHaddock verbosity tmpFileOpts comp confHaddock libArgs'+        CExe   _ -> when (flag haddockExecutables) $ doExe component+        CTest  _ -> when (flag haddockTestSuites)  $ doExe component+        CBench _ -> when (flag haddockBenchmarks)  $ doExe component++    forM_ (extraDocFiles pkg_descr) $ \ fpath -> do+      files <- matchFileGlob fpath+      forM_ files $ copyFileTo verbosity (unDir $ argOutputDir commonArgs)   where-    verbosity = flag haddockVerbosity-    flag f    = fromFlag $ f flags-    htmlTemplate = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags+    verbosity     = flag haddockVerbosity+    keepTempFiles = flag haddockKeepTempFiles+    comp          = compiler lbi+    tmpFileOpts   = defaultTempFileOptions { optKeepTempFiles = keepTempFiles }+    flag f        = fromFlag $ f flags+    htmlTemplate  = fmap toPathTemplate . flagToMaybe . haddockHtmlLocation $ flags  -- | performs cpp and unlit preprocessing where needed on the files in -- | argTargets, which must have an .hs or .lhs extension. prepareSources :: Verbosity                   -> FilePath                   -> LocalBuildInfo-                  -> Bool            -- haddock == 2.*+                  -> Version                   -> BuildInfo                   -> HaddockArgs                   -> IO HaddockArgs-prepareSources verbosity tmp lbi isVersion2 bi args@HaddockArgs{argTargets=files} =+prepareSources verbosity tmp lbi haddockVersion bi args@HaddockArgs{argTargets=files} =               mapM (mockPP tmp) files >>= \targets -> return args {argTargets=targets}           where             mockPP pref file = do@@ -259,9 +283,14 @@                      removeFile targetFile                   return hsFile-            needsCpp = EnableExtension CPP `elem` allExtensions bi-            defines | isVersion2 = []-                    | otherwise  = ["-D__HADDOCK__"]+            needsCpp             = EnableExtension CPP `elem` allExtensions bi+            isVersion2           = haddockVersion >= Version [2,0] []+            defines | isVersion2 = [haddockVersionMacro]+                    | otherwise  = ["-D__HADDOCK__", haddockVersionMacro]+            haddockVersionMacro  = "-D__HADDOCK_VERSION__="+                                   ++ show (v1 * 1000 + v2 * 10 + v3)+              where+                [v1, v2, v3] = take 3 $ versionBranch haddockVersion ++ [0,0]  -------------------------------------------------------------------------------------------------- -- constributions to HaddockArgs@@ -277,7 +306,7 @@       argCssFile = haddockCss flags,       argContents = fmap (fromPathTemplate . substPathTemplate env) (haddockContents flags),       argVerbose = maybe mempty (Any . (>= deafening)) . flagToMaybe $ haddockVerbosity flags,-      argOutput = +      argOutput =           Flag $ case [ Html | Flag True <- [haddockHtml flags] ] ++                       [ Hoogle | Flag True <- [haddockHoogle flags] ]                  of [] -> [ Html ]@@ -308,17 +337,30 @@ fromLibrary verbosity tmp lbi lib clbi htmlTemplate = do     inFiles <- map snd `fmap` getLibSourceFiles lbi lib     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {+                          -- Noooooooooo!!!!!111+                          -- haddock stomps on our precious .hi+                          -- and .o files. Workaround by telling+                          -- haddock to write them elsewhere.+                          ghcOptObjDir  = toFlag tmp,+                          ghcOptHiDir   = toFlag tmp,+                          ghcOptStubDir = toFlag tmp+                      }+        sharedOpts = vanillaOpts {+                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                         ghcOptFPic        = toFlag True,+                         ghcOptHiSuffix    = toFlag "dyn_hi",+                         ghcOptObjSuffix   = toFlag "dyn_o",+                         ghcOptExtra       = ghcSharedOptions bi+                     }+    opts <- if withVanillaLib lbi+            then return vanillaOpts+            else if withSharedLib lbi+            then return sharedOpts+            else die "Must have vanilla or shared libraries enabled in order to run haddock"     return ifaceArgs {       argHideModules = (mempty,otherModules $ bi),-      argGhcOptions  = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {-                       -- Noooooooooo!!!!!111-                       -- haddock stomps on our precious .hi-                       -- and .o files. Workaround by telling-                       -- haddock to write them elsewhere.-                         ghcOptObjDir  = toFlag tmp,-                         ghcOptHiDir   = toFlag tmp,-                         ghcOptStubDir = toFlag tmp-                       },ghcVersion),+      argGhcOptions  = toFlag (opts, ghcVersion),       argTargets     = inFiles     }   where@@ -333,16 +375,29 @@ fromExecutable verbosity tmp lbi exe clbi htmlTemplate = do     inFiles <- map snd `fmap` getExeSourceFiles lbi exe     ifaceArgs <- getInterfaces verbosity lbi clbi htmlTemplate+    let vanillaOpts = (componentGhcOptions normal lbi bi clbi (buildDir lbi)) {+                          -- Noooooooooo!!!!!111+                          -- haddock stomps on our precious .hi+                          -- and .o files. Workaround by telling+                          -- haddock to write them elsewhere.+                          ghcOptObjDir  = toFlag tmp,+                          ghcOptHiDir   = toFlag tmp,+                          ghcOptStubDir = toFlag tmp+                      }+        sharedOpts = vanillaOpts {+                         ghcOptDynLinkMode = toFlag GhcDynamicOnly,+                         ghcOptFPic        = toFlag True,+                         ghcOptHiSuffix    = toFlag "dyn_hi",+                         ghcOptObjSuffix   = toFlag "dyn_o",+                         ghcOptExtra       = ghcSharedOptions bi+                     }+    opts <- if withVanillaLib lbi+            then return vanillaOpts+            else if withSharedLib lbi+            then return sharedOpts+            else die "Must have vanilla or shared libraries enabled in order to run haddock"     return ifaceArgs {-      argGhcOptions = toFlag ((componentGhcOptions normal lbi bi clbi (buildDir lbi)) {-                      -- Noooooooooo!!!!!111-                      -- haddock stomps on our precious .hi-                      -- and .o files. Workaround by telling-                      -- haddock to write them elsewhere.-                        ghcOptObjDir  = toFlag tmp,-                        ghcOptHiDir   = toFlag tmp,-                        ghcOptStubDir = toFlag tmp-                      }, ghcVersion),+      argGhcOptions = toFlag (opts, ghcVersion),       argOutputDir  = Dir (exeName exe),       argTitle      = Flag (exeName exe),       argTargets    = inFiles@@ -351,6 +406,24 @@     bi = buildInfo exe     ghcVersion = compilerVersion (compiler lbi) +compToExe :: Component -> Maybe Executable+compToExe comp =+  case comp of+    CTest test@TestSuite { testInterface = TestSuiteExeV10 _ f } ->+      Just Executable {+        exeName    = testName test,+        modulePath = f,+        buildInfo  = testBuildInfo test+      }+    CBench bench@Benchmark { benchmarkInterface = BenchmarkExeV10 _ f } ->+      Just Executable {+        exeName    = benchmarkName bench,+        modulePath = f,+        buildInfo  = benchmarkBuildInfo bench+      }+    CExe exe -> Just exe+    _ -> Nothing+ getInterfaces :: Verbosity               -> LocalBuildInfo               -> ComponentLocalBuildInfo@@ -376,11 +449,17 @@ ----------------------------------------------------------------------------------------------  -- | Call haddock with the specified arguments.-runHaddock :: Verbosity -> ConfiguredProgram -> HaddockArgs -> IO ()-runHaddock verbosity confHaddock args = do+runHaddock :: Verbosity+              -> TempFileOptions+              -> Compiler+              -> ConfiguredProgram+              -> HaddockArgs+              -> IO ()+runHaddock verbosity tmpFileOpts comp confHaddock args = do   let haddockVersion = fromMaybe (error "unable to determine haddock version")                        (programVersion confHaddock)-  renderArgs verbosity haddockVersion args $ \(flags,result)-> do+  renderArgs verbosity tmpFileOpts haddockVersion comp args $+    \(flags,result)-> do        rawSystemProgram verbosity confHaddock flags @@ -388,18 +467,20 @@   renderArgs :: Verbosity+              -> TempFileOptions               -> Version+              -> Compiler               -> HaddockArgs               -> (([String], FilePath) -> IO a)               -> IO a-renderArgs verbosity version args k = do+renderArgs verbosity tmpFileOpts version comp args k = do   createDirectoryIfMissingVerbose verbosity True outputDir-  withTempFile outputDir "haddock-prolog.txt" $ \prologFileName h -> do+  withTempFileEx tmpFileOpts outputDir "haddock-prolog.txt" $ \prologFileName h -> do           do              hPutStrLn h $ fromFlag $ argPrologue args              hClose h-             let pflag = (:[]).("--prologue="++) $ prologFileName-             k $ (pflag ++ renderPureArgs version args, result)+             let pflag = "--prologue=" ++ prologFileName+             k (pflag : renderPureArgs version comp args, result)     where       isVersion2 = version >= Version [2,0] []       outputDir = (unDir $ argOutputDir args)@@ -415,14 +496,14 @@               pkgid = arg argPackageName       arg f = fromFlag $ f args -renderPureArgs :: Version -> HaddockArgs -> [String]-renderPureArgs version args = concat+renderPureArgs :: Version -> Compiler -> HaddockArgs -> [String]+renderPureArgs version comp args = concat     [      (:[]) . (\f -> "--dump-interface="++ unDir (argOutputDir args) </> f)      . fromFlag . argInterfaceFile $ args,-     (\pkgName -> if isVersion2-                  then ["--optghc=-package-name", "--optghc=" ++ pkgName]-                  else ["--package=" ++ pkgName]) . display . fromFlag . argPackageName $ args,+     (\pname ->   if isVersion2+                  then ["--optghc=-package-name", "--optghc=" ++ pname]+                  else ["--package=" ++ pname]) . display . fromFlag . argPackageName $ args,      (\(All b,xs) -> bool (map (("--hide=" ++). display) xs) [] b) . argHideModules $ args,      bool ["--ignore-all-exports"] [] . getAny . argIgnoreExports $ args,      maybe [] (\(m,e) -> ["--source-module=" ++ m@@ -436,13 +517,15 @@      (:[]).("--title="++) . (bool (++" (internal documentation)") id (getAny $ argIgnoreExports args))               . fromFlag . argTitle $ args,      [ "--optghc=" ++ opt | isVersion2-                          , (opts, ghcVersion) <- flagToList (argGhcOptions args)-                          , opt <- renderGhcOptions ghcVersion opts ],+                          , (opts, _ghcVer) <- flagToList (argGhcOptions args)+                          , opt <- renderGhcOptions comp opts ],      maybe [] (\l -> ["-B"++l]) $ guard isVersion2 >> flagToMaybe (argGhcLibDir args), -- error if isVersion2 and Nothing?      argTargets $ args     ]     where-      renderInterfaces = map (\(i,mh) -> "--read-interface=" ++ maybe "" (++",") mh ++ i)+      renderInterfaces =+        map (\(i,mh) -> "--read-interface=" +++          maybe "" (++",") mh ++ i)       bool a b c = if c then a else b       isVersion2 = version >= Version [2,0] []       isVersion2_5 = version >= Version [2,5] []@@ -455,7 +538,7 @@ haddockPackageFlags :: LocalBuildInfo                     -> ComponentLocalBuildInfo                     -> Maybe PathTemplate-                    -> IO ([(FilePath,Maybe FilePath)], Maybe String)+                    -> IO ([(FilePath,Maybe String)], Maybe String) haddockPackageFlags lbi clbi htmlTemplate = do   let allPkgs = installedPkgs lbi       directDeps = map fst (componentPackageDeps clbi)@@ -471,7 +554,9 @@           if exists             then return (Right (interface, html))             else return (Left (packageId ipkg))-    | ipkg <- PackageIndex.allPackages transitiveDeps ]+    | ipkg <- PackageIndex.allPackages transitiveDeps+    , pkgName (packageId ipkg) `notElem` noHaddockWhitelist+    ]    let missing = [ pkgid | Left pkgid <- interfaces ]       warning = "The documentation for the following packages are not "@@ -483,20 +568,30 @@   return (flags, if null missing then Nothing else Just warning)    where+    noHaddockWhitelist = map PackageName [ "rts" ]     interfaceAndHtmlPath :: InstalledPackageInfo -> Maybe (FilePath, FilePath)     interfaceAndHtmlPath pkg = do       interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)       html <- case htmlTemplate of-        Nothing -> listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)+        Nothing -> fmap fixFileUrl+                        (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))         Just htmlPathTemplate -> Just (expandTemplateVars htmlPathTemplate)       return (interface, html) -      where expandTemplateVars = fromPathTemplate . substPathTemplate env-            env = haddockTemplateEnv lbi (packageId pkg)+      where+        expandTemplateVars = fromPathTemplate . substPathTemplate env+        env = haddockTemplateEnv lbi (packageId pkg) +        -- the 'haddock-html' field in the hc-pkg output is often set as a+        -- native path, but we need it as a URL.+        -- See https://github.com/haskell/cabal/issues/1064+        fixFileUrl f | isAbsolute f = "file://" ++ f+                     | otherwise    = f+ haddockTemplateEnv :: LocalBuildInfo -> PackageIdentifier -> PathTemplateEnv haddockTemplateEnv lbi pkg_id = (PrefixVar, prefix (installDirTemplates lbi))                                 : initialPathTemplateEnv pkg_id (compilerId (compiler lbi))+                                  (hostPlatform lbi)  -- -------------------------------------------------------------------------- -- hscolour support@@ -527,16 +622,24 @@     createDirectoryIfMissingVerbose verbosity True $ hscolourPref distPref pkg_descr      let pre c = preprocessComponent pkg_descr c lbi False verbosity suffixes-    withComponentsLBI pkg_descr lbi $ \comp _ -> do+    withAllComponentsInBuildOrder pkg_descr lbi $ \comp _ -> do       pre comp+      let+        doExe com = case (compToExe com) of+          Just exe -> do+            let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"+            runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe+          Nothing -> do+           warn (fromFlag $ hscolourVerbosity flags)+             "Unsupported component, skipping..."+           return ()       case comp of         CLib lib -> do           let outputDir = hscolourPref distPref pkg_descr </> "src"           runHsColour hscolourProg outputDir =<< getLibSourceFiles lbi lib-        CExe exe | fromFlag (hscolourExecutables flags) -> do-          let outputDir = hscolourPref distPref pkg_descr </> exeName exe </> "src"-          runHsColour hscolourProg outputDir =<< getExeSourceFiles lbi exe-        _ -> return ()+        CExe   _ -> when (fromFlag (hscolourExecutables flags)) $ doExe comp+        CTest  _ -> when (fromFlag (hscolourTestSuites  flags)) $ doExe comp+        CBench _ -> when (fromFlag (hscolourBenchmarks  flags)) $ doExe comp   where     stylesheet = flagToMaybe (hscolourCSS flags) @@ -552,7 +655,7 @@                    | otherwise -> return ()            Just s -> copyFileVerbose verbosity s (outputDir </> "hscolour.css") -         flip mapM_ moduleFiles $ \(m, inFile) ->+         forM_ moduleFiles $ \(m, inFile) ->              rawSystemProgram verbosity prog                     ["-css", "-anchor", "-o" ++ outFile m, inFile]         where@@ -563,6 +666,8 @@     HscolourFlags {       hscolourCSS         = haddockHscolourCss flags,       hscolourExecutables = haddockExecutables flags,+      hscolourTestSuites  = haddockTestSuites  flags,+      hscolourBenchmarks  = haddockBenchmarks  flags,       hscolourVerbosity   = haddockVerbosity   flags,       hscolourDistPref    = haddockDistPref    flags     }
+ cabal/Cabal/Distribution/Simple/HaskellSuite.hs view
@@ -0,0 +1,222 @@+module Distribution.Simple.HaskellSuite where++import Control.Monad+import Control.Applicative+import Data.Maybe+import Data.Version+import qualified Data.Map as M (empty)++import Distribution.Simple.Program+import Distribution.Simple.Compiler as Compiler+import Distribution.Simple.Utils+import Distribution.Simple.BuildPaths+import Distribution.Verbosity+import Distribution.Text+import Distribution.Package+import Distribution.InstalledPackageInfo hiding (includeDirs)+import Distribution.Simple.PackageIndex as PackageIndex+import Distribution.PackageDescription+import Distribution.Simple.LocalBuildInfo+import Distribution.System (Platform)+import Distribution.Compat.Exception+import Language.Haskell.Extension+import Distribution.Simple.Program.Builtin+  (haskellSuiteProgram, haskellSuitePkgProgram)++configure+  :: Verbosity -> Maybe FilePath -> Maybe FilePath+  -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration)+configure verbosity mbHcPath hcPkgPath conf0 = do++  -- We have no idea how a haskell-suite tool is named, so we require at+  -- least some information from the user.+  hcPath <-+    let msg = "You have to provide name or path of a haskell-suite tool (-w PATH)"+    in maybe (die msg) return mbHcPath++  when (isJust hcPkgPath) $+    warn verbosity "--with-hc-pkg option is ignored for haskell-suite"++  (comp, confdCompiler, conf1) <- configureCompiler hcPath conf0++  -- Update our pkg tool. It uses the same executable as the compiler, but+  -- all command start with "pkg"+  (confdPkg, _) <- requireProgram verbosity haskellSuitePkgProgram conf1+  let conf2 =+        updateProgram+          confdPkg+            { programLocation = programLocation confdCompiler+            , programDefaultArgs = ["pkg"]+            }+          conf1++  return (comp, Nothing, conf2)++  where+    configureCompiler hcPath conf0' = do+      let+        haskellSuiteProgram' =+          haskellSuiteProgram+            { programFindLocation = \v _p -> findProgramLocation v hcPath }++      -- NB: cannot call requireProgram right away — it'd think that+      -- the program is already configured and won't reconfigure it again.+      -- Instead, call configureProgram directly first.+      conf1 <- configureProgram verbosity haskellSuiteProgram' conf0'+      (confdCompiler, conf2) <- requireProgram verbosity haskellSuiteProgram' conf1++      extensions <- getExtensions verbosity confdCompiler+      languages  <- getLanguages  verbosity confdCompiler+      (compName, compVersion) <-+        getCompilerVersion verbosity confdCompiler++      let+        comp = Compiler {+          compilerId             = CompilerId (HaskellSuite compName) compVersion,+          compilerLanguages      = languages,+          compilerExtensions     = extensions,+          compilerProperties     = M.empty+        }++      return (comp, confdCompiler, conf2)++hstoolVersion :: Verbosity -> FilePath -> IO (Maybe Version)+hstoolVersion = findProgramVersion "--hspkg-version" id++numericVersion :: Verbosity -> FilePath -> IO (Maybe Version)+numericVersion = findProgramVersion "--compiler-version" (last . words)++getCompilerVersion :: Verbosity -> ConfiguredProgram -> IO (String, Version)+getCompilerVersion verbosity prog = do+  output <- rawSystemStdout verbosity (programPath prog) ["--compiler-version"]+  let+    parts = words output+    name = concat $ init parts -- there shouldn't be any spaces in the name anyway+    versionStr = last parts+  version <-+    maybe (die "haskell-suite: couldn't determine compiler version") return $+      simpleParse versionStr+  return (name, version)++getExtensions :: Verbosity -> ConfiguredProgram -> IO [(Extension, Compiler.Flag)]+getExtensions verbosity prog = do+  extStrs <-+    lines <$>+    rawSystemStdout verbosity (programPath prog) ["--supported-extensions"]+  return+    [ (ext, "-X" ++ display ext) | Just ext <- map simpleParse extStrs ]++getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Compiler.Flag)]+getLanguages verbosity prog = do+  langStrs <-+    lines <$>+    rawSystemStdout verbosity (programPath prog) ["--supported-languages"]+  return+    [ (ext, "-G" ++ display ext) | Just ext <- map simpleParse langStrs ]++-- Other compilers do some kind of a packagedb stack check here. Not sure+-- if we need something like that as well.+getInstalledPackages :: Verbosity -> PackageDBStack -> ProgramConfiguration+                     -> IO PackageIndex+getInstalledPackages verbosity packagedbs conf =+  liftM (PackageIndex.fromList . concat) $ forM packagedbs $ \packagedb ->+    do str <-+        getDbProgramOutput verbosity haskellSuitePkgProgram conf+                ["dump", packageDbOpt packagedb]+         `catchExit` \_ -> die $ "pkg dump failed"+       case parsePackages str of+         Right ok -> return ok+         _       -> die "failed to parse output of 'pkg dump'"++  where+    parsePackages str =+      let parsed = map parseInstalledPackageInfo (splitPkgs str)+       in case [ msg | ParseFailed msg <- parsed ] of+            []   -> Right [ pkg | ParseOk _ pkg <- parsed ]+            msgs -> Left msgs++    splitPkgs :: String -> [String]+    splitPkgs = map unlines . splitWith ("---" ==) . lines+      where+        splitWith :: (a -> Bool) -> [a] -> [[a]]+        splitWith p xs = ys : case zs of+                           []   -> []+                           _:ws -> splitWith p ws+          where (ys,zs) = break p xs++buildLib+  :: Verbosity -> PackageDescription -> LocalBuildInfo+  -> Library -> ComponentLocalBuildInfo -> IO ()+buildLib verbosity pkg_descr lbi lib clbi = do+  -- In future, there should be a mechanism for the compiler to request any+  -- number of the above parameters (or their parts) — in particular,+  -- pieces of PackageDescription.+  --+  -- For now, we only pass those that we know are used.++  let odir = buildDir lbi+      bi = libBuildInfo lib+      srcDirs = hsSourceDirs bi ++ [odir]+      dbStack = withPackageDB lbi+      language = fromMaybe Haskell98 (defaultLanguage bi)+      conf = withPrograms lbi+      pkgid = packageId pkg_descr++  runDbProgram verbosity haskellSuiteProgram conf $+    [ "compile", "--build-dir", odir ] +++    concat [ ["-i", d] | d <- srcDirs ] +++    concat [ ["-I", d] | d <- [autogenModulesDir lbi, odir] ++ includeDirs bi ] +++    [ packageDbOpt pkgDb | pkgDb <- dbStack ] +++    [ "--package-name", display pkgid ] +++    concat [ ["--package-id", display ipkgid ]+           | (ipkgid, _) <- componentPackageDeps clbi ] +++    ["-G", display language] +++    concat [ ["-X", display ex] | ex <- usedExtensions bi ] +++    [ display modu | modu <- libModules lib ]++++installLib+  :: Verbosity+  -> LocalBuildInfo+  -> FilePath  -- ^install location+  -> FilePath  -- ^install location for dynamic librarys+  -> FilePath  -- ^Build location+  -> PackageDescription+  -> Library+  -> IO ()+installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+  let conf = withPrograms lbi+  runDbProgram verbosity haskellSuitePkgProgram conf $+    [ "install-library"+    , "--build-dir", builtDir+    , "--target-dir", targetDir+    , "--dynlib-target-dir", dynlibTargetDir+    , "--package-id", display $ packageId pkg+    ] ++ map display (libModules lib)++registerPackage+  :: Verbosity+  -> InstalledPackageInfo+  -> PackageDescription+  -> LocalBuildInfo+  -> Bool+  -> PackageDBStack+  -> IO ()+registerPackage verbosity installedPkgInfo _pkg lbi _inplace packageDbs = do+  (hspkg, _) <- requireProgram verbosity haskellSuitePkgProgram (withPrograms lbi)++  runProgramInvocation verbosity $+    (programInvocation hspkg+      ["update", packageDbOpt $ last packageDbs])+      { progInvokeInput = Just $ showInstalledPackageInfo installedPkgInfo }++initPackageDB :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()+initPackageDB verbosity conf dbPath =+  runDbProgram verbosity haskellSuitePkgProgram conf+    ["init", dbPath]++packageDbOpt :: PackageDB -> String+packageDbOpt GlobalPackageDB        = "--global"+packageDbOpt UserPackageDB          = "--user"+packageDbOpt (SpecificPackageDB db) = "--package-db=" ++ db
cabal/Cabal/Distribution/Simple/Hpc.hs view
@@ -60,9 +60,13 @@     , testModules     ) import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..) )-import Distribution.Simple.Program ( hpcProgram, requireProgram )+import Distribution.Simple.Program+    ( hpcProgram+    , requireProgramVersion+    ) import Distribution.Simple.Program.Hpc ( markup, union ) import Distribution.Simple.Utils ( notice )+import Distribution.Version ( anyVersion ) import Distribution.Text import Distribution.Verbosity ( Verbosity() ) import System.Directory ( createDirectoryIfMissing, doesFileExist )@@ -138,14 +142,19 @@ markupTest verbosity lbi distPref libName suite = do     tixFileExists <- doesFileExist $ tixFilePath distPref $ testName suite     when tixFileExists $ do-        (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi-        markup hpc verbosity (tixFilePath distPref $ testName suite)-                             (mixDir distPref libName)-                             (htmlDir distPref $ testName suite)-                             (testModules suite ++ [ main ])+        -- behaviour of 'markup' depends on version, so we need *a* version+        -- but no particular one+        (hpc, hpcVer, _) <- requireProgramVersion verbosity+            hpcProgram anyVersion (withPrograms lbi)+        markup hpc hpcVer verbosity+            (tixFilePath distPref $ testName suite) mixDirs+            (htmlDir distPref $ testName suite)+            (testModules suite ++ [ main ])         notice verbosity $ "Test coverage report written to "                             ++ htmlDir distPref (testName suite)                             </> "hpc_index" <.> "html"+  where+    mixDirs = map (mixDir distPref) [ testName suite, libName ]  -- | Generate the HTML markup for all of a package's test suites. markupPackage :: Verbosity@@ -158,13 +167,17 @@     let tixFiles = map (tixFilePath distPref . testName) suites     tixFilesExist <- mapM doesFileExist tixFiles     when (and tixFilesExist) $ do-        (hpc, _) <- requireProgram verbosity hpcProgram $ withPrograms lbi+        -- behaviour of 'markup' depends on version, so we need *a* version+        -- but no particular one+        (hpc, hpcVer, _) <- requireProgramVersion verbosity+            hpcProgram anyVersion (withPrograms lbi)         let outFile = tixFilePath distPref libName-            mixDir' = mixDir distPref libName             htmlDir' = htmlDir distPref libName             excluded = concatMap testModules suites ++ [ main ]         createDirectoryIfMissing True $ takeDirectory outFile         union hpc verbosity tixFiles outFile excluded-        markup hpc verbosity outFile mixDir' htmlDir' excluded+        markup hpc hpcVer verbosity outFile mixDirs htmlDir' excluded         notice verbosity $ "Package coverage report written to "                            ++ htmlDir' </> "hpc_index.html"+  where+    mixDirs = map (mixDir distPref) $ libName : map testName suites
cabal/Cabal/Distribution/Simple/Hugs.hs view
@@ -108,6 +108,7 @@ import Distribution.Verbosity  import Data.Char                ( isSpace )+import qualified Data.Map as M  ( empty ) import Data.Maybe               ( mapMaybe, catMaybes ) import Data.Monoid              ( Monoid(..) ) import Control.Monad            ( unless, when, filterM )@@ -118,6 +119,7 @@ import System.Exit          ( ExitCode(ExitSuccess) ) import Distribution.Compat.Exception+import Distribution.System ( Platform )  import qualified Data.ByteString.Lazy.Char8 as BS.Char8 @@ -125,7 +127,7 @@ -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (_ffihugsProg, conf') <- requireProgram verbosity ffihugsProgram@@ -137,9 +139,11 @@   let comp = Compiler {         compilerId             = CompilerId Hugs version,         compilerLanguages      = hugsLanguages,-        compilerExtensions     = hugsLanguageExtensions+        compilerExtensions     = hugsLanguageExtensions,+        compilerProperties     = M.empty       }-  return (comp, conf'')+      compPlatform = Nothing+  return (comp, compPlatform, conf'')    where     hugsProgram' = hugsProgram { programFindVersion = getVersion }@@ -147,6 +151,7 @@ getVersion :: Verbosity -> FilePath -> IO (Maybe Version) getVersion verbosity hugsPath = do   (output, _err, exit) <- rawSystemStdInOut verbosity hugsPath []+                              Nothing Nothing                               (Just (":quit", False)) False   if exit == ExitSuccess     then return $! findVersion output
cabal/Cabal/Distribution/Simple/Install.hs view
@@ -51,11 +51,12 @@ import Distribution.Package (Package(..)) import Distribution.Simple.LocalBuildInfo (         LocalBuildInfo(..), InstallDirs(..), absoluteInstallDirs,-        substPathTemplate)+        substPathTemplate, withLibLBI) import Distribution.Simple.BuildPaths (haddockName, haddockPref) import Distribution.Simple.Utils-         ( createDirectoryIfMissingVerbose, installDirectoryContents-         , installOrdinaryFile, die, info, notice, matchDirFileGlob )+         ( createDirectoryIfMissingVerbose+         , installDirectoryContents, installOrdinaryFile, isInSearchPath+         , die, info, notice, warn, matchDirFileGlob ) import Distribution.Simple.Compiler          ( CompilerFlavor(..), compilerFlavor ) import Distribution.Simple.Setup (CopyFlags(..), CopyDest(..), fromFlag)@@ -66,6 +67,7 @@ import qualified Distribution.Simple.LHC  as LHC import qualified Distribution.Simple.Hugs as Hugs import qualified Distribution.Simple.UHC  as UHC+import qualified Distribution.Simple.HaskellSuite as HaskellSuite  import Control.Monad (when, unless) import System.Directory@@ -143,19 +145,23 @@   let buildPref = buildDir lbi   when (hasLibs pkg_descr) $     notice verbosity ("Installing library in " ++ libPref)-  when (hasExes pkg_descr) $+  when (hasExes pkg_descr) $ do     notice verbosity ("Installing executable(s) in " ++ binPref)+    inPath <- isInSearchPath binPref+    when (not inPath) $+      warn verbosity ("The directory " ++ binPref+                      ++ " is not in the system search path.")    -- install include files for all compilers - they may be needed to compile   -- haskell files (using the CPP extension)   when (hasLibs pkg_descr) $ installIncludeFiles verbosity pkg_descr incPref    case compilerFlavor (compiler lbi) of-     GHC  -> do withLib pkg_descr $+     GHC  -> do withLibLBI pkg_descr lbi $                   GHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr                 withExe pkg_descr $                   GHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr-     LHC  -> do withLib pkg_descr $+     LHC  -> do withLibLBI pkg_descr lbi $                   LHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr                 withExe pkg_descr $                   LHC.installExe verbosity lbi installDirs buildPref (progPrefixPref, progSuffixPref) pkg_descr@@ -167,13 +173,15 @@        let targetProgPref = progdir (absoluteInstallDirs pkg_descr lbi NoCopyDest)        let scratchPref = scratchDir lbi        Hugs.install verbosity lbi libPref progPref binPref targetProgPref scratchPref (progPrefixPref, progSuffixPref) pkg_descr-     NHC  -> do withLib pkg_descr $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)+     NHC  -> do withLibLBI pkg_descr lbi $ NHC.installLib verbosity libPref buildPref (packageId pkg_descr)                 withExe pkg_descr $ NHC.installExe verbosity binPref buildPref (progPrefixPref, progSuffixPref)      UHC  -> do withLib pkg_descr $ UHC.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr+     HaskellSuite {} ->+       withLib pkg_descr $+         HaskellSuite.installLib verbosity lbi libPref dynlibPref buildPref pkg_descr      _    -> die $ "installing with "                 ++ display (compilerFlavor (compiler lbi))                 ++ " is not implemented"-  return ()   -- register step should be performed by caller.  -- | Install the files listed in data-files
cabal/Cabal/Distribution/Simple/InstallDirs.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.InstallDirs@@ -77,14 +75,12 @@ import Data.Monoid (Monoid(..)) import System.Directory (getAppUserDataDirectory) import System.FilePath ((</>), isPathSeparator, pathSeparator)-#if __HUGS__ || __GLASGOW_HASKELL__ > 606 import System.FilePath (dropDrive)-#endif  import Distribution.Package          ( PackageIdentifier, packageName, packageVersion ) import Distribution.System-         ( OS(..), buildOS, Platform(..), buildPlatform )+         ( OS(..), buildOS, Platform(..) ) import Distribution.Compiler          ( CompilerId, CompilerFlavor(..) ) import Distribution.Text@@ -120,7 +116,8 @@         docdir       :: dir,         mandir       :: dir,         htmldir      :: dir,-        haddockdir   :: dir+        haddockdir   :: dir,+        sysconfdir   :: dir     } deriving (Read, Show)  instance Functor InstallDirs where@@ -138,7 +135,8 @@     docdir       = f (docdir dirs),     mandir       = f (mandir dirs),     htmldir      = f (htmldir dirs),-    haddockdir   = f (haddockdir dirs)+    haddockdir   = f (haddockdir dirs),+    sysconfdir   = f (sysconfdir dirs)   }  instance Monoid dir => Monoid (InstallDirs dir) where@@ -156,7 +154,8 @@       docdir       = mempty,       mandir       = mempty,       htmldir      = mempty,-      haddockdir   = mempty+      haddockdir   = mempty,+      sysconfdir   = mempty   }   mappend = combineInstallDirs mappend @@ -178,7 +177,8 @@     docdir       = docdir a     `combine` docdir b,     mandir       = mandir a     `combine` mandir b,     htmldir      = htmldir a    `combine` htmldir b,-    haddockdir   = haddockdir a `combine` haddockdir b+    haddockdir   = haddockdir a `combine` haddockdir b,+    sysconfdir   = sysconfdir a `combine` sysconfdir b   }  appendSubdirs :: (a -> a -> a) -> InstallDirs a -> InstallDirs a@@ -240,7 +240,7 @@            JHC    -> "$compiler"            LHC    -> "$compiler"            UHC    -> "$pkgid"-           _other -> "$pkgid" </> "$compiler",+           _other -> "$arch-$os-$compiler" </> "$pkgid",       dynlibdir    = "$libdir",       libexecdir   = case buildOS of         Windows   -> "$prefix" </> "$pkgid"@@ -250,11 +250,12 @@       datadir      = case buildOS of         Windows   -> "$prefix"         _other    -> "$prefix" </> "share",-      datasubdir   = "$pkgid",-      docdir       = "$datadir" </> "doc" </> "$pkgid",+      datasubdir   = "$arch-$os-$compiler" </> "$pkgid",+      docdir       = "$datadir" </> "doc" </> "$arch-$os-$compiler" </> "$pkgid",       mandir       = "$datadir" </> "man",       htmldir      = "$docdir"  </> "html",-      haddockdir   = "$htmldir"+      haddockdir   = "$htmldir",+      sysconfdir   = "$prefix" </> "etc"   }  -- ---------------------------------------------------------------------------@@ -292,7 +293,8 @@       mandir     = subst mandir     (prefixBinLibDataVars ++ [docdirVar]),       htmldir    = subst htmldir    (prefixBinLibDataVars ++ [docdirVar]),       haddockdir = subst haddockdir (prefixBinLibDataVars ++-                                      [docdirVar, htmldirVar])+                                      [docdirVar, htmldirVar]),+      sysconfdir = subst sysconfdir prefixBinLibVars     }     subst dir env' = substPathTemplate (env'++env) (dir dirs) @@ -310,10 +312,10 @@ -- | Convert from abstract install directories to actual absolute ones by -- substituting for all the variables in the abstract paths, to get real -- absolute path.-absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest+absoluteInstallDirs :: PackageIdentifier -> CompilerId -> CopyDest -> Platform                     -> InstallDirs PathTemplate                     -> InstallDirs FilePath-absoluteInstallDirs pkgId compilerId copydest dirs =+absoluteInstallDirs pkgId compilerId copydest platform dirs =     (case copydest of        CopyTo destdir -> fmap ((destdir </>) . dropDrive)        _              -> id)@@ -321,7 +323,7 @@   . fmap fromPathTemplate   $ substituteInstallDirTemplates env dirs   where-    env = initialPathTemplateEnv pkgId compilerId+    env = initialPathTemplateEnv pkgId compilerId platform   -- |The location prefix for the /copy/ command.@@ -336,10 +338,10 @@ -- prevents us from making a relocatable package (also known as a \"prefix -- independent\" package). ---prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId+prefixRelativeInstallDirs :: PackageIdentifier -> CompilerId -> Platform                           -> InstallDirTemplates                           -> InstallDirs (Maybe FilePath)-prefixRelativeInstallDirs pkgId compilerId dirs =+prefixRelativeInstallDirs pkgId compilerId platform dirs =     fmap relative   . appendSubdirs combinePathTemplate   $ -- substitute the path template into each other, except that we map@@ -349,7 +351,7 @@       prefix = PathTemplate [Variable PrefixVar]     }   where-    env = initialPathTemplateEnv pkgId compilerId+    env = initialPathTemplateEnv pkgId compilerId platform      -- If it starts with $prefix then it's relative and produce the relative     -- path by stripping off $prefix/ or $prefix@@ -390,7 +392,8 @@      | ArchVar       -- ^ The cpu architecture name, eg @i386@ or @x86_64@      | ExecutableNameVar -- ^ The executable name; used in shell wrappers      | TestSuiteNameVar   -- ^ The name of the test suite being run-     | TestSuiteResultVar -- ^ The result of the test suite being run, eg @pass@, @fail@, or @error@.+     | TestSuiteResultVar -- ^ The result of the test suite being run, eg+                          -- @pass@, @fail@, or @error@.      | BenchmarkNameVar   -- ^ The name of the benchmark being run   deriving Eq @@ -421,12 +424,12 @@                   Nothing                        -> [component]  -- | The initial environment has all the static stuff but no paths-initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> PathTemplateEnv-initialPathTemplateEnv pkgId compilerId =+initialPathTemplateEnv :: PackageIdentifier -> CompilerId -> Platform+                       -> PathTemplateEnv+initialPathTemplateEnv pkgId compilerId platform =      packageTemplateEnv  pkgId   ++ compilerTemplateEnv compilerId-  ++ platformTemplateEnv buildPlatform -- platform should be param if we want-                                       -- to do cross-platform configuation+  ++ platformTemplateEnv platform  packageTemplateEnv :: PackageIdentifier -> PathTemplateEnv packageTemplateEnv pkgId =@@ -561,9 +564,6 @@ #if mingw32_HOST_OS shGetFolderPath :: CInt -> IO (Maybe FilePath) shGetFolderPath n =-# if __HUGS__-  return Nothing-# else   allocaArray long_path_size $ \pPath -> do      r <- c_SHGetFolderPath nullPtr n nullPtr 0 pPath      if (r /= 0)@@ -571,7 +571,6 @@         else do s <- peekCWString pPath; return (Just s)   where     long_path_size      = 1024 -- MAX_PATH is 260, this should be plenty-# endif  csidl_PROGRAM_FILES :: CInt csidl_PROGRAM_FILES = 0x0026@@ -585,20 +584,4 @@                               -> CInt                               -> CWString                               -> IO CInt-#endif--#if !(__HUGS__ || __GLASGOW_HASKELL__ > 606)--- Compat: this function only appears in FilePath > 1.0--- (which at the time of writing is unreleased)-dropDrive :: FilePath -> FilePath-dropDrive (c:cs) | isPathSeparator c = cs-dropDrive (_:':':c:cs) | isWindows-                      && isPathSeparator c = cs  -- path with drive letter-dropDrive (_:':':cs)   | isWindows         = cs-dropDrive cs = cs--isWindows :: Bool-isWindows = case buildOS of-  Windows -> True-  _       -> False #endif
cabal/Cabal/Distribution/Simple/JHC.hs view
@@ -84,9 +84,11 @@          ( Text(parse), display ) import Distribution.Compat.ReadP     ( readP_to_S, string, skipSpaces )+import Distribution.System ( Platform )  import Data.List                ( nub ) import Data.Char                ( isSpace )+import qualified Data.Map as M  ( empty ) import Data.Maybe               ( fromMaybe )  import qualified Data.ByteString.Lazy.Char8 as BS.Char8@@ -96,7 +98,7 @@ -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (jhcProg, _, conf') <- requireProgramVersion verbosity@@ -107,9 +109,11 @@       comp = Compiler {         compilerId             = CompilerId JHC version,         compilerLanguages      = jhcLanguages,-        compilerExtensions     = jhcLanguageExtensions+        compilerExtensions     = jhcLanguageExtensions,+        compilerProperties     = M.empty       }-  return (comp, conf')+      compPlatform = Nothing+  return (comp, compPlatform, conf')  jhcLanguages :: [(Language, Flag)] jhcLanguages = [(Haskell98, "")]
cabal/Cabal/Distribution/Simple/LHC.hs view
@@ -81,20 +81,22 @@ import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.ParseUtils  ( ParseResult(..) ) import Distribution.Simple.LocalBuildInfo-         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..) )+         ( LocalBuildInfo(..), ComponentLocalBuildInfo(..),+           LibraryName(..) ) import Distribution.Simple.InstallDirs import Distribution.Simple.BuildPaths import Distribution.Simple.Utils import Distribution.Package-         ( PackageIdentifier, Package(..) )+         ( Package(..) ) import qualified Distribution.ModuleName as ModuleName import Distribution.Simple.Program-         ( Program(..), ConfiguredProgram(..), ProgramConfiguration, ProgArg-         , ProgramLocation(..), rawSystemProgram, rawSystemProgramConf+         ( Program(..), ConfiguredProgram(..), ProgramConfiguration+         , ProgramSearchPath, ProgramLocation(..)+         , rawSystemProgram, rawSystemProgramConf          , rawSystemProgramStdout, rawSystemProgramStdoutConf          , requireProgramVersion          , userMaybeSpecifyPath, programPath, lookupProgram, addKnownProgram-         , arProgram, ranlibProgram, ldProgram+         , arProgram, ldProgram          , gccProgram, stripProgram          , lhcProgram, lhcPkgProgram ) import qualified Distribution.Simple.Program.HcPkg as HcPkg@@ -114,6 +116,7 @@  import Control.Monad            ( unless, when ) import Data.List+import qualified Data.Map as M  ( empty ) import Data.Maybe               ( catMaybes ) import Data.Monoid              ( Monoid(..) ) import System.Directory         ( removeFile, renameFile,@@ -123,12 +126,13 @@                                   takeDirectory, replaceExtension ) import System.IO (hClose, hPutStrLn) import Distribution.Compat.Exception (catchExit, catchIO)+import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath hcPkgPath conf = do    (lhcProg, lhcVersion, conf') <-@@ -152,10 +156,12 @@   let comp = Compiler {         compilerId             = CompilerId LHC lhcVersion,         compilerLanguages      = languages,-        compilerExtensions     = extensions+        compilerExtensions     = extensions,+        compilerProperties     = M.empty       }       conf''' = configureToolchain lhcProg conf'' -- configure gcc and ld-  return (comp, conf''')+      compPlatform = Nothing+  return (comp, compPlatform, conf''')  -- | Adjust the way we find and configure gcc and ld --@@ -178,32 +184,36 @@     isWindows   = case buildOS of Windows -> True; _ -> False      -- on Windows finding and configuring ghc's gcc and ld is a bit special-    findProg :: Program -> FilePath -> Verbosity -> IO (Maybe FilePath)-    findProg prog location | isWindows = \verbosity -> do+    findProg :: Program -> FilePath+             -> Verbosity -> ProgramSearchPath -> IO (Maybe FilePath)+    findProg prog location | isWindows = \verbosity searchpath -> do         exists <- doesFileExist location         if exists then return (Just location)                   else do warn verbosity ("Couldn't find " ++ programName prog ++ " where I expected it. Trying the search path.")-                          programFindLocation prog verbosity+                          programFindLocation prog verbosity searchpath       | otherwise = programFindLocation prog -    configureGcc :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureGcc :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureGcc       | isWindows = \_ gccProg -> case programLocation gccProg of           -- if it's found on system then it means we're using the result           -- of programFindLocation above rather than a user-supplied path           -- that means we should add this extra flag to tell ghc's gcc           -- where it lives and thus where gcc can find its various files:-          FoundOnSystem {} -> return ["-B" ++ libDir, "-I" ++ includeDir]-          UserSpecified {} -> return []-      | otherwise = \_ _   -> return []+          FoundOnSystem {} -> return gccProg {+                                programDefaultArgs = ["-B" ++ libDir,+                                                      "-I" ++ includeDir]+                              }+          UserSpecified {} -> return gccProg+      | otherwise = \_ gccProg -> return gccProg      -- we need to find out if ld supports the -x flag-    configureLd :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+    configureLd :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram     configureLd verbosity ldProg = do       tempDir <- getTemporaryDirectory       ldx <- withTempFile tempDir ".c" $ \testcfile testchnd ->              withTempFile tempDir ".o" $ \testofile testohnd -> do-               hPutStrLn testchnd "int foo() {}"+               hPutStrLn testchnd "int foo() { return 0; }"                hClose testchnd; hClose testohnd                rawSystemProgram verbosity lhcProg ["-c", testcfile,                                                    "-o", testofile]@@ -216,8 +226,8 @@                  `catchIO`   (\_ -> return False)                  `catchExit` (\_ -> return False)       if ldx-        then return ["-x"]-        else return []+        then return ldProg { programDefaultArgs = ["-x"] }+        else return ldProg  getLanguages :: Verbosity -> ConfiguredProgram -> IO [(Language, Flag)] getLanguages _ _ = return [(Haskell98, "")]@@ -332,6 +342,11 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do+  libName <- case componentLibraries clbi of+             [libName] -> return libName+             [] -> die "No library name found when building library"+             _  -> die "Multiple library names found when building library"+   let pref = buildDir lbi       pkgid = packageId pkg_descr       runGhcProg = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)@@ -385,11 +400,11 @@   info verbosity "Linking..."   let cObjs = map (`replaceExtension` objExtension) (cSources libBi)       cSharedObjs = map (`replaceExtension` ("dyn_" ++ objExtension)) (cSources libBi)-      vanillaLibFilePath = libTargetDir </> mkLibName pkgid-      profileLibFilePath = libTargetDir </> mkProfLibName pkgid-      sharedLibFilePath  = libTargetDir </> mkSharedLibName pkgid-                                              (compilerId (compiler lbi))-      ghciLibFilePath    = libTargetDir </> mkGHCiLibName pkgid+      cid = compilerId (compiler lbi)+      vanillaLibFilePath = libTargetDir </> mkLibName           libName+      profileLibFilePath = libTargetDir </> mkProfLibName       libName+      sharedLibFilePath  = libTargetDir </> mkSharedLibName cid libName+      ghciLibFilePath    = libTargetDir </> mkGHCiLibName       libName    stubObjs <- fmap catMaybes $ sequence     [ findFileWithExtension [objExtension] [libTargetDir]@@ -695,8 +710,8 @@            _              -> ["-optc-O2"])      ++ ["-odir", odir] -mkGHCiLibName :: PackageIdentifier -> String-mkGHCiLibName lib = "HS" ++ display lib <.> "o"+mkGHCiLibName :: LibraryName -> String+mkGHCiLibName (LibraryName lib) = lib <.> "o"  -- ----------------------------------------------------------------------------- -- Installing@@ -747,8 +762,9 @@               -> FilePath  -- ^Build location               -> PackageDescription               -> Library+              -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity lbi targetDir dynlibTargetDir builtDir pkg lib = do+installLib verbosity lbi targetDir dynlibTargetDir builtDir _pkg lib clbi = do   -- copy .hi files over:   let copy src dst n = do         createDirectoryIfMissingVerbose verbosity True dst@@ -762,24 +778,18 @@   flip mapM_ hcrFiles $ \(srcBase, srcFile) -> runLhc ["--install-library", srcBase </> srcFile]    -- copy the built library files over:-  ifVanilla $ copy builtDir targetDir vanillaLibName-  ifProf    $ copy builtDir targetDir profileLibName-  ifGHCi    $ copy builtDir targetDir ghciLibName-  ifShared  $ copy builtDir dynlibTargetDir sharedLibName--  -- run ranlib if necessary:-  ifVanilla $ updateLibArchive verbosity lbi-                               (targetDir </> vanillaLibName)-  ifProf    $ updateLibArchive verbosity lbi-                               (targetDir </> profileLibName)+  ifVanilla $ mapM_ (copy builtDir targetDir)       vanillaLibNames+  ifProf    $ mapM_ (copy builtDir targetDir)       profileLibNames+  ifGHCi    $ mapM_ (copy builtDir targetDir)       ghciLibNames+  ifShared  $ mapM_ (copy builtDir dynlibTargetDir) sharedLibNames    where-    vanillaLibName = mkLibName pkgid-    profileLibName = mkProfLibName pkgid-    ghciLibName    = mkGHCiLibName pkgid-    sharedLibName  = mkSharedLibName pkgid (compilerId (compiler lbi))--    pkgid          = packageId pkg+    cid = compilerId (compiler lbi)+    libNames = componentLibraries clbi+    vanillaLibNames = map mkLibName             libNames+    profileLibNames = map mkProfLibName         libNames+    ghciLibNames    = map mkGHCiLibName         libNames+    sharedLibNames  = map (mkSharedLibName cid) libNames      hasLib    = not $ null (libModules lib)                    && null (cSources (libBuildInfo lib))@@ -789,20 +799,6 @@     ifShared  = when (hasLib && withSharedLib  lbi)      runLhc    = rawSystemProgramConf verbosity lhcProgram (withPrograms lbi)---- | use @ranlib@ or @ar -s@ to build an index. This is necessary on systems--- like MacOS X. If we can't find those, don't worry too much about it.----updateLibArchive :: Verbosity -> LocalBuildInfo -> FilePath -> IO ()-updateLibArchive verbosity lbi path =-  case lookupProgram ranlibProgram (withPrograms lbi) of-    Just ranlib -> rawSystemProgram verbosity ranlib [path]-    Nothing     -> case lookupProgram arProgram (withPrograms lbi) of-      Just ar   -> rawSystemProgram verbosity ar ["-s", path]-      Nothing   -> warn verbosity $-                        "Unable to generate a symbol index for the static "-                     ++ "library '" ++ path-                     ++ "' (missing the 'ranlib' and 'ar' programs)"  -- ----------------------------------------------------------------------------- -- Registering
cabal/Cabal/Distribution/Simple/LocalBuildInfo.hs view
@@ -51,11 +51,27 @@          -- * Buildable package components         Component(..),-        foldComponent,-        componentBuildInfo,-        allComponentsBy,         ComponentName(..),+        showComponentName,         ComponentLocalBuildInfo(..),+        LibraryName(..),+        foldComponent,+        componentName,+        componentBuildInfo,+        componentEnabled,+        componentDisabledReason,+        ComponentDisabledReason(..),+        pkgComponents,+        pkgEnabledComponents,+        lookupComponent,+        getComponent,+        getComponentLocalBuildInfo,+        allComponentsInBuildOrder,+        componentsInBuildOrder,+        checkComponentsCyclic,++        withAllComponentsInBuildOrder,+        withComponentsInBuildOrder,         withComponentsLBI,         withLibLBI,         withExeLBI,@@ -83,14 +99,17 @@          ( Compiler(..), PackageDBStack, OptimisationLevel ) import Distribution.Simple.PackageIndex          ( PackageIndex )-import Distribution.Simple.Utils-         ( die ) import Distribution.Simple.Setup          ( ConfigFlags ) import Distribution.Text          ( display )-+import Distribution.System+          ( Platform ) import Data.List (nub, find)+import Data.Graph+import Data.Tree  (flatten)+import Data.Array ((!))+import Data.Maybe  -- | Data cached after configuration step.  See also -- 'Distribution.Simple.Setup.ConfigFlags'.@@ -107,18 +126,16 @@         --TODO: inplaceDirTemplates :: InstallDirs FilePath         compiler      :: Compiler,                 -- ^ The compiler we're building with+        hostPlatform  :: Platform,+                -- ^ The platform we're building for         buildDir      :: FilePath,                 -- ^ Where to build the package.         --TODO: eliminate hugs's scratchDir, use builddir         scratchDir    :: FilePath,                 -- ^ Where to put the result of the Hugs build.-        libraryConfig       :: Maybe ComponentLocalBuildInfo,-        executableConfigs   :: [(String, ComponentLocalBuildInfo)],-        compBuildOrder :: [ComponentName],-                -- ^ All the components to build, ordered by topological sort+        componentsConfigs   :: [(ComponentName, ComponentLocalBuildInfo, [ComponentName])],+                -- ^ All the components to build, ordered by topological sort, and with their dependencies                 -- over the intrapackage dependency graph-        testSuiteConfigs    :: [(String, ComponentLocalBuildInfo)],-        benchmarkConfigs    :: [(String, ComponentLocalBuildInfo)],         installedPkgs :: PackageIndex,                 -- ^ All the info about the installed packages that the                 -- current package depends on (directly or indirectly).@@ -138,6 +155,7 @@         withGHCiLib   :: Bool,  -- ^Whether to build libs suitable for use with GHCi.         splitObjs     :: Bool,  -- ^Use -split-objs with GHC, if available         stripExes     :: Bool,  -- ^Whether to strip executables during install+        stripLibs     :: Bool,  -- ^Whether to strip libraries during install         progPrefix    :: PathTemplate, -- ^Prefix to be prepended to installed executables         progSuffix    :: PathTemplate -- ^Suffix to be appended to installed executables   } deriving (Read, Show)@@ -145,12 +163,12 @@ -- | External package dependencies for the package as a whole. This is the -- union of the individual 'componentPackageDeps', less any internal deps. externalPackageDeps :: LocalBuildInfo -> [(InstalledPackageId, PackageId)]-externalPackageDeps lbi = filter (not . internal . snd) $ nub $-  -- TODO:  what about non-buildable components?-       maybe [] componentPackageDeps (libraryConfig lbi)-    ++ concatMap (componentPackageDeps . snd) (executableConfigs lbi)-    ++ concatMap (componentPackageDeps . snd) (testSuiteConfigs lbi)-    ++ concatMap (componentPackageDeps . snd) (benchmarkConfigs lbi)+externalPackageDeps lbi =+    -- TODO:  what about non-buildable components?+    nub [ (ipkgid, pkgid)+        | (_,clbi,_)      <- componentsConfigs lbi+        , (ipkgid, pkgid) <- componentPackageDeps clbi+        , not (internal pkgid) ]   where     -- True if this dependency is an internal one (depends on the library     -- defined in the same package).@@ -175,15 +193,32 @@                    | CExeName   String                    | CTestName  String                    | CBenchName String-                   deriving (Show, Eq, Read)+                   deriving (Show, Eq, Ord, Read) -data ComponentLocalBuildInfo = ComponentLocalBuildInfo {+showComponentName :: ComponentName -> String+showComponentName CLibName          = "library"+showComponentName (CExeName   name) = "executable '" ++ name ++ "'"+showComponentName (CTestName  name) = "test suite '" ++ name ++ "'"+showComponentName (CBenchName name) = "benchmark '" ++ name ++ "'"++data ComponentLocalBuildInfo+  = LibComponentLocalBuildInfo {     -- | Resolved internal and external package dependencies for this component.     -- The 'BuildInfo' specifies a set of build dependencies that must be     -- satisfied in terms of version ranges. This field fixes those dependencies     -- to the specific versions available on this machine for this compiler.+    componentPackageDeps :: [(InstalledPackageId, PackageId)],+    componentLibraries :: [LibraryName]+  }+  | ExeComponentLocalBuildInfo {     componentPackageDeps :: [(InstalledPackageId, PackageId)]   }+  | TestComponentLocalBuildInfo {+    componentPackageDeps :: [(InstalledPackageId, PackageId)]+  }+  | BenchComponentLocalBuildInfo {+    componentPackageDeps :: [(InstalledPackageId, PackageId)]+  }   deriving (Read, Show)  foldComponent :: (Library -> a)@@ -197,113 +232,180 @@ foldComponent _ _ f _ (CTest  tst) = f tst foldComponent _ _ _ f (CBench bch) = f bch +data LibraryName = LibraryName String+    deriving (Read, Show)+ componentBuildInfo :: Component -> BuildInfo componentBuildInfo =   foldComponent libBuildInfo buildInfo testBuildInfo benchmarkBuildInfo --- | Obtains all components (libs, exes, or test suites), transformed by the--- given function.  Useful for gathering dependencies with component context.-allComponentsBy :: PackageDescription-                -> (Component -> a)-                -> [a]-allComponentsBy pkg_descr f =-    [ f (CLib  lib) | Just lib <- [library pkg_descr]-                    , buildable (libBuildInfo lib) ]- ++ [ f (CExe  exe) | exe <- executables pkg_descr-                    , buildable (buildInfo exe) ]- ++ [ f (CTest tst) | tst <- testSuites pkg_descr-                    , buildable (testBuildInfo tst)-                    , testEnabled tst ]- ++ [ f (CBench bm) | bm <- benchmarks pkg_descr-                    , buildable (benchmarkBuildInfo bm)-                    , benchmarkEnabled bm ]+componentName :: Component -> ComponentName+componentName =+  foldComponent (const CLibName)+                (CExeName . exeName)+                (CTestName . testName)+                (CBenchName . benchmarkName) +-- | All the components in the package (libs, exes, or test suites).+--+pkgComponents :: PackageDescription -> [Component]+pkgComponents pkg =+    [ CLib  lib | Just lib <- [library pkg] ]+ ++ [ CExe  exe | exe <- executables pkg ]+ ++ [ CTest tst | tst <- testSuites  pkg ]+ ++ [ CBench bm | bm  <- benchmarks  pkg ]++-- | All the components in the package that are buildable and enabled.+-- Thus this excludes non-buildable components and test suites or benchmarks+-- that have been disabled.+--+pkgEnabledComponents :: PackageDescription -> [Component]+pkgEnabledComponents = filter componentEnabled . pkgComponents++componentEnabled :: Component -> Bool+componentEnabled = isNothing . componentDisabledReason++data ComponentDisabledReason = DisabledComponent+                             | DisabledAllTests+                             | DisabledAllBenchmarks++componentDisabledReason :: Component -> Maybe ComponentDisabledReason+componentDisabledReason (CLib  lib)+  | not (buildable (libBuildInfo lib))      = Just DisabledComponent+componentDisabledReason (CExe  exe)+  | not (buildable (buildInfo exe))         = Just DisabledComponent+componentDisabledReason (CTest tst)+  | not (buildable (testBuildInfo tst))     = Just DisabledComponent+  | not (testEnabled tst)                   = Just DisabledAllTests+componentDisabledReason (CBench bm)+  | not (buildable (benchmarkBuildInfo bm)) = Just DisabledComponent+  | not (benchmarkEnabled bm)               = Just DisabledAllBenchmarks+componentDisabledReason _                   = Nothing++lookupComponent :: PackageDescription -> ComponentName -> Maybe Component+lookupComponent pkg CLibName =+    fmap CLib $ library pkg+lookupComponent pkg (CExeName name) =+    fmap CExe $ find ((name ==) . exeName) (executables pkg)+lookupComponent pkg (CTestName name) =+    fmap CTest $ find ((name ==) . testName) (testSuites pkg)+lookupComponent pkg (CBenchName name) =+    fmap CBench $ find ((name ==) . benchmarkName) (benchmarks pkg)++getComponent :: PackageDescription -> ComponentName -> Component+getComponent pkg cname =+    case lookupComponent pkg cname of+      Just cpnt -> cpnt+      Nothing   -> missingComponent+  where+    missingComponent =+      error $ "internal error: the package description contains no "+           ++ "component corresponding to " ++ show cname+++getComponentLocalBuildInfo :: LocalBuildInfo -> ComponentName -> ComponentLocalBuildInfo+getComponentLocalBuildInfo lbi cname =+    case [ clbi+         | (cname', clbi, _) <- componentsConfigs lbi+         , cname == cname' ] of+      [clbi] -> clbi+      _      -> missingComponent+  where+    missingComponent =+      error $ "internal error: there is no configuration data "+           ++ "for component " ++ show cname++ -- |If the package description has a library section, call the given --  function with the library build info as argument.  Extended version of -- 'withLib' that also gives corresponding build info. withLibLBI :: PackageDescription -> LocalBuildInfo            -> (Library -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withLibLBI pkg_descr lbi f = withLib pkg_descr $ \lib ->-  case libraryConfig lbi of-    Just clbi -> f lib clbi-    Nothing   -> die missingLibConf+withLibLBI pkg_descr lbi f =+    withLib pkg_descr $ \lib ->+      f lib (getComponentLocalBuildInfo lbi CLibName)  -- | Perform the action on each buildable 'Executable' in the package -- description.  Extended version of 'withExe' that also gives corresponding -- build info. withExeLBI :: PackageDescription -> LocalBuildInfo            -> (Executable -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withExeLBI pkg_descr lbi f = withExe pkg_descr $ \exe ->-  case lookup (exeName exe) (executableConfigs lbi) of-    Just clbi -> f exe clbi-    Nothing   -> die (missingExeConf (exeName exe))+withExeLBI pkg_descr lbi f =+    withExe pkg_descr $ \exe ->+      f exe (getComponentLocalBuildInfo lbi (CExeName (exeName exe)))  withTestLBI :: PackageDescription -> LocalBuildInfo             -> (TestSuite -> ComponentLocalBuildInfo -> IO ()) -> IO ()-withTestLBI pkg_descr lbi f = withTest pkg_descr $ \test ->-  case lookup (testName test) (testSuiteConfigs lbi) of-    Just clbi -> f test clbi-    Nothing -> die (missingTestConf (testName test))+withTestLBI pkg_descr lbi f =+    withTest pkg_descr $ \test ->+      f test (getComponentLocalBuildInfo lbi (CTestName (testName test))) --- | Perform the action on each buildable 'Library' or 'Executable' (Component)--- in the PackageDescription, subject to the build order specified by the--- 'compBuildOrder' field of the given 'LocalBuildInfo'+{-# DEPRECATED withComponentsLBI "Use withAllComponentsInBuildOrder" #-} withComponentsLBI :: PackageDescription -> LocalBuildInfo                   -> (Component -> ComponentLocalBuildInfo -> IO ())                   -> IO ()-withComponentsLBI pkg_descr lbi f = mapM_ compF (compBuildOrder lbi)+withComponentsLBI = withAllComponentsInBuildOrder++-- | Perform the action on each buildable 'Library' or 'Executable' (Component)+-- in the PackageDescription, subject to the build order specified by the+-- 'compBuildOrder' field of the given 'LocalBuildInfo'+withAllComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo+                              -> (Component -> ComponentLocalBuildInfo -> IO ())+                              -> IO ()+withAllComponentsInBuildOrder pkg lbi f =+    sequence_+      [ f (getComponent pkg cname) clbi+      | (cname, clbi) <- allComponentsInBuildOrder lbi ]++withComponentsInBuildOrder :: PackageDescription -> LocalBuildInfo+                                  -> [ComponentName]+                                  -> (Component -> ComponentLocalBuildInfo -> IO ())+                                  -> IO ()+withComponentsInBuildOrder pkg lbi cnames f =+    sequence_+      [ f (getComponent pkg cname') clbi+      | (cname', clbi) <- componentsInBuildOrder lbi cnames ]++allComponentsInBuildOrder :: LocalBuildInfo+                          -> [(ComponentName, ComponentLocalBuildInfo)]+allComponentsInBuildOrder lbi =+    componentsInBuildOrder lbi+      [ cname | (cname, _, _) <- componentsConfigs lbi ]++componentsInBuildOrder :: LocalBuildInfo -> [ComponentName]+                       -> [(ComponentName, ComponentLocalBuildInfo)]+componentsInBuildOrder lbi cnames =+      map ((\(clbi,cname,_) -> (cname,clbi)) . vertexToNode)+    . postOrder graph+    . map (\cname -> fromMaybe (noSuchComp cname) (keyToVertex cname))+    $ cnames   where-    compF CLibName =-        case library pkg_descr of-          Nothing  -> die missinglib-          Just lib -> case libraryConfig lbi of-                        Nothing   -> die missingLibConf-                        Just clbi -> f (CLib lib) clbi-      where-        missinglib  = "internal error: component list includes a library "-                   ++ "but the package description contains no library"+    (graph, vertexToNode, keyToVertex) =+      graphFromEdges (map (\(a,b,c) -> (b,a,c)) (componentsConfigs lbi)) -    compF (CExeName name) =-        case find (\exe -> exeName exe == name) (executables pkg_descr) of-          Nothing  -> die missingexe-          Just exe -> case lookup name (executableConfigs lbi) of-                        Nothing   -> die (missingExeConf name)-                        Just clbi -> f (CExe exe) clbi-      where-        missingexe  = "internal error: component list includes an executable "-                   ++ name ++ " but the package contains no such executable."+    noSuchComp cname = error $ "internal error: componentsInBuildOrder: "+                            ++ "no such component: " ++ show cname -    compF (CTestName name) =-        case find (\tst -> testName tst == name) (testSuites pkg_descr) of-          Nothing  -> die missingtest-          Just tst -> case lookup name (testSuiteConfigs lbi) of-                        Nothing   -> die (missingTestConf name)-                        Just clbi -> f (CTest tst) clbi-      where-        missingtest = "internal error: component list includes a test suite "-                   ++ name ++ " but the package contains no such test suite."+    postOrder :: Graph -> [Vertex] -> [Vertex]+    postOrder g vs = postorderF (dfs g vs) [] -    compF (CBenchName name) =-        case find (\bch -> benchmarkName bch == name) (benchmarks pkg_descr) of-          Nothing  -> die missingbench-          Just bch -> case lookup name (benchmarkConfigs lbi) of-                        Nothing   -> die (missingBenchConf name)-                        Just clbi -> f (CBench bch) clbi-      where-        missingbench = "internal error: component list includes a benchmark "-                       ++ name ++ " but the package contains no such benchmark."+    postorderF   :: Forest a -> [a] -> [a]+    postorderF ts = foldr (.) id $ map postorderT ts -missingLibConf :: String-missingExeConf, missingTestConf, missingBenchConf :: String -> String+    postorderT :: Tree a -> [a] -> [a]+    postorderT (Node a ts) = postorderF ts . (a :) -missingLibConf       = "internal error: the package contains a library "-                    ++ "but there is no corresponding configuration data"-missingExeConf  name = "internal error: the package contains an executable "-                    ++ name ++ " but there is no corresponding configuration data"-missingTestConf name = "internal error: the package contains a test suite "-                    ++ name ++ " but there is no corresponding configuration data"-missingBenchConf name = "internal error: the package contains a benchmark "-                    ++ name ++ " but there is no corresponding configuration data"+checkComponentsCyclic :: Ord key => [(node, key, [key])]+                      -> Maybe [(node, key, [key])]+checkComponentsCyclic es =+    let (graph, vertexToNode, _) = graphFromEdges es+        cycles                   = [ flatten c | c <- scc graph, isCycle c ]+        isCycle (Node v [])      = selfCyclic v+        isCycle _                = True+        selfCyclic v             = v `elem` graph ! v+     in case cycles of+         []    -> Nothing+         (c:_) -> Just (map vertexToNode c)   -- -----------------------------------------------------------------------------@@ -317,6 +419,7 @@     (packageId pkg)     (compilerId (compiler lbi))     copydest+    (hostPlatform lbi)     (installDirTemplates lbi)  -- |See 'InstallDirs.prefixRelativeInstallDirs'@@ -326,6 +429,7 @@   InstallDirs.prefixRelativeInstallDirs     (packageId pkg_descr)     (compilerId (compiler lbi))+    (hostPlatform lbi)     (installDirTemplates lbi)  substPathTemplate :: PackageId -> LocalBuildInfo@@ -335,3 +439,4 @@     where env = initialPathTemplateEnv                    pkgid                    (compilerId (compiler lbi))+                   (hostPlatform lbi)
cabal/Cabal/Distribution/Simple/NHC.hs view
@@ -52,7 +52,7 @@  import Distribution.Package          ( PackageName, PackageIdentifier(..), InstalledPackageId(..)-         , packageId, packageName )+         , packageName ) import Distribution.InstalledPackageInfo          ( InstalledPackageInfo          , InstalledPackageInfo_( InstalledPackageInfo, installedPackageId@@ -98,18 +98,20 @@          ( doesFileExist, doesDirectoryExist, getDirectoryContents          , removeFile, getHomeDirectory ) -import Data.Char ( toLower )-import Data.List ( nub )-import Data.Maybe    ( catMaybes )-import Data.Monoid   ( Monoid(..) )-import Control.Monad ( when, unless )+import Data.Char               ( toLower )+import Data.List               ( nub )+import Data.Maybe              ( catMaybes )+import qualified Data.Map as M ( empty )+import Data.Monoid             ( Monoid(..) )+import Control.Monad           ( when, unless ) import Distribution.Compat.Exception+import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (_nhcProg, nhcVersion, conf') <-@@ -132,9 +134,11 @@   let comp = Compiler {         compilerId         = CompilerId NHC nhcVersion,         compilerLanguages  = nhcLanguages,-        compilerExtensions     = nhcLanguageExtensions+        compilerExtensions = nhcLanguageExtensions,+        compilerProperties = M.empty       }-  return (comp, conf'''')+      compPlatform = Nothing+  return (comp, compPlatform,  conf'''')  nhcLanguages :: [(Language, Flag)] nhcLanguages = [(Haskell98, "-98")]@@ -285,6 +289,10 @@ buildLib :: Verbosity -> PackageDescription -> LocalBuildInfo                       -> Library            -> ComponentLocalBuildInfo -> IO () buildLib verbosity pkg_descr lbi lib clbi = do+  libName <- case componentLibraries clbi of+             [libName] -> return libName+             [] -> die "No library name found when building library"+             _  -> die "Multiple library names found when building library"   let conf = withPrograms lbi       Just nhcProg = lookupProgram nhcProgram conf   let bi = libBuildInfo lib@@ -325,7 +333,7 @@   info verbosity "Linking..."   let --cObjs = [ targetDir </> cFile `replaceExtension` objExtension       --        | cFile <- cSources bi ]-      libFilePath = targetDir </> mkLibName (packageId pkg_descr)+      libFilePath = targetDir </> mkLibName libName       hObjs = [ targetDir </> ModuleName.toFilePath m <.> objExtension               | m <- modules ] @@ -414,11 +422,15 @@               -> FilePath  -- ^Build location               -> PackageIdentifier               -> Library+              -> ComponentLocalBuildInfo               -> IO ()-installLib verbosity pref buildPref pkgid lib+installLib verbosity pref buildPref _pkgid lib clbi     = do let bi = libBuildInfo lib              modules = exposedModules lib ++ otherModules bi          findModuleFiles [buildPref] ["hi"] modules            >>= installOrdinaryFiles verbosity pref-         let libName = mkLibName pkgid-         installOrdinaryFile verbosity (buildPref </> libName) (pref </> libName)+         let libNames = map mkLibName (componentLibraries clbi)+             installLib' libName = installOrdinaryFile verbosity+                                                       (buildPref </> libName)+                                                       (pref </> libName)+         mapM_ installLib' libNames
cabal/Cabal/Distribution/Simple/PackageIndex.hs view
@@ -106,6 +106,8 @@   -- of the same package version. These are unique by InstalledPackageId   -- and are kept in preference order.   --+  -- FIXME: Clarify what "preference order" means. Check that this invariant is+  -- preserved. See #1463 for discussion.   !(Map PackageName (Map Version [InstalledPackageInfo]))    deriving (Show, Read)
cabal/Cabal/Distribution/Simple/PreProcess.hs view
@@ -51,7 +51,7 @@                                 ppSuffixes, PPSuffixHandler, PreProcessor(..),                                 mkSimplePreProcessor, runSimplePreProcessor,                                 ppCpp, ppCpp', ppGreenCard, ppC2hs, ppHsc2hs,-                                ppHappy, ppAlex, ppUnlit+                                ppHappy, ppAlex, ppUnlit, platformDefines                                )     where @@ -71,14 +71,16 @@ import qualified Distribution.InstalledPackageInfo as Installed          ( InstalledPackageInfo_(..) ) import qualified Distribution.Simple.PackageIndex as PackageIndex+import Distribution.Simple.CCompiler+         ( cSourceExtensions ) import Distribution.Simple.Compiler-         ( CompilerFlavor(..), Compiler(..), compilerFlavor, compilerVersion )+         ( CompilerFlavor(..), compilerFlavor, compilerVersion ) import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), Component(..) ) import Distribution.Simple.BuildPaths (autogenModulesDir,cppHeaderName) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , die, setupMessage, intercalate, copyFileVerbose+         , die, setupMessage, intercalate, copyFileVerbose, moreRecentFile          , findFileWithExtension, findFileWithExtension' ) import Distribution.Simple.Program          ( Program(..), ConfiguredProgram(..), programPath@@ -88,7 +90,7 @@          , happyProgram, alexProgram, haddockProgram, ghcProgram, gccProgram ) import Distribution.Simple.Test ( writeSimpleTestStub, stubFilePath, stubName ) import Distribution.System-         ( OS(OSX, Windows), buildOS )+         ( OS(..), buildOS, Arch(..), Platform(..) ) import Distribution.Text import Distribution.Version          ( Version(..), anyVersion, orLaterVersion )@@ -96,7 +98,7 @@  import Data.Maybe (fromMaybe) import Data.List (nub)-import System.Directory (getModificationTime, doesFileExist)+import System.Directory (doesFileExist) import System.Info (os, arch) import System.FilePath (splitExtension, dropExtensions, (</>), (<.>),                         takeDirectory, normalise, replaceExtension)@@ -219,9 +221,11 @@       BenchmarkUnsupported tt -> die $ "No support for preprocessing benchmark "                                  ++ "type " ++ display tt   where-    builtinSuffixes+    builtinHaskellSuffixes       | NHC == compilerFlavor (compiler lbi) = ["hs", "lhs", "gc"]       | otherwise                            = ["hs", "lhs"]+    builtinCSuffixes = cSourceExtensions+    builtinSuffixes = builtinHaskellSuffixes ++ builtinCSuffixes     localHandlers bi = [(ext, h bi lbi) | (ext, h) <- handlers]     pre dirs dir lhndlrs fp =       preprocessFile dirs dir isSrcDist fp verbosity builtinSuffixes lhndlrs@@ -232,7 +236,7 @@     preProcessComponent bi modules exePath dir = do         let biHandlers = localHandlers bi             sourceDirs = hsSourceDirs bi ++ [ autogenModulesDir lbi ]-        sequence_ [ preprocessFile sourceDirs (buildDir lbi) isSrcDist+        sequence_ [ preprocessFile sourceDirs dir isSrcDist                 (ModuleName.toFilePath modu) verbosity builtinSuffixes                 biHandlers                 | modu <- modules ]@@ -294,10 +298,8 @@               ppsrcFiles <- findFileWithExtension builtinSuffixes [buildLoc] baseFile               recomp <- case ppsrcFiles of                           Nothing -> return True-                          Just ppsrcFile -> do-                              btime <- getModificationTime ppsrcFile-                              ptime <- getModificationTime psrcFile-                              return (btime < ptime)+                          Just ppsrcFile ->+                              psrcFile `moreRecentFile` ppsrcFile               when recomp $ do                 let destDir = buildLoc </> dirName srcStem                 createDirectoryIfMissingVerbose verbosity True destDir@@ -445,13 +447,15 @@           -- system's dynamic linker. This is needed because hsc2hs works by           -- compiling a C program and then running it. -       ++ [ "--cflag="   ++ opt | opt <- hcDefines (compiler lbi) ]-       ++ [ "--cflag="   ++ opt | opt <- sysDefines ]+       ++ [ "--cflag="   ++ opt | opt <- platformDefines lbi ]            -- Options from the current package:        ++ [ "--cflag=-I" ++ dir | dir <- PD.includeDirs  bi ]        ++ [ "--cflag="   ++ opt | opt <- PD.ccOptions    bi                                       ++ PD.cppOptions   bi ]+       ++ [ "--cflag="   ++ opt | opt <-+               [ "-I" ++ autogenModulesDir lbi,+                 "-include", autogenModulesDir lbi </> cppHeaderName ] ]        ++ [ "--lflag=-L" ++ opt | opt <- PD.extraLibDirs bi ]        ++ [ "--lflag=-Wl,-R," ++ opt | isELF                                 , opt <- PD.extraLibDirs bi ]@@ -462,9 +466,7 @@        ++ [ "--cflag=" ++ opt           | pkg <- pkgs           , opt <- [ "-I" ++ opt | opt <- Installed.includeDirs pkg ]-                ++ [         opt | opt <- Installed.ccOptions   pkg ]-                ++ [ "-I" ++ autogenModulesDir lbi,-                     "-include", autogenModulesDir lbi </> cppHeaderName ] ]+                ++ [         opt | opt <- Installed.ccOptions   pkg ] ]        ++ [ "--lflag=" ++ opt           | pkg <- pkgs           , opt <- [ "-L" ++ opt | opt <- Installed.libraryDirs    pkg ]@@ -530,43 +532,78 @@ --TODO: remove cc-options from cpphs for cabal-version: >= 1.10 getCppOptions :: BuildInfo -> LocalBuildInfo -> [String] getCppOptions bi lbi-    = hcDefines (compiler lbi)-   ++ sysDefines+    = platformDefines lbi    ++ cppOptions bi    ++ ["-I" ++ dir | dir <- PD.includeDirs bi]    ++ [opt | opt@('-':c:_) <- PD.ccOptions bi, c `elem` "DIU"] -sysDefines :: [String]-sysDefines = ["-D" ++ os   ++ "_" ++ loc ++ "_OS"   | loc <- locations]-          ++ ["-D" ++ arch ++ "_" ++ loc ++ "_ARCH" | loc <- locations]-  where-    locations = ["BUILD", "HOST"]--hcDefines :: Compiler -> [String]-hcDefines comp =+platformDefines :: LocalBuildInfo -> [String]+platformDefines lbi =   case compilerFlavor comp of-    GHC  -> ["-D__GLASGOW_HASKELL__=" ++ versionInt version]+    GHC  ->+      ["-D__GLASGOW_HASKELL__=" ++ versionInt version] +++      ["-D" ++ os   ++ "_BUILD_OS=1"] +++      ["-D" ++ arch ++ "_BUILD_ARCH=1"] +++      map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr +++      map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr     JHC  -> ["-D__JHC__=" ++ versionInt version]     NHC  -> ["-D__NHC__=" ++ versionInt version]     Hugs -> ["-D__HUGS__"]+    HaskellSuite {} ->+      ["-D__HASKELL_SUITE__"] +++        map (\os'   -> "-D" ++ os'   ++ "_HOST_OS=1")   osStr +++        map (\arch' -> "-D" ++ arch' ++ "_HOST_ARCH=1") archStr     _    -> []-  where version = compilerVersion comp---- TODO: move this into the compiler abstraction--- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all the other--- compilers. Check if that's really what they want.-versionInt :: Version -> String-versionInt (Version { versionBranch = [] }) = "1"-versionInt (Version { versionBranch = [n] }) = show n-versionInt (Version { versionBranch = n1:n2:_ })-  = -- 6.8.x -> 608-    -- 6.10.x -> 610-    let s1 = show n1-        s2 = show n2-        middle = case s2 of-                 _ : _ : _ -> ""-                 _         -> "0"-    in s1 ++ middle ++ s2+  where+    comp = compiler lbi+    Platform hostArch hostOS = hostPlatform lbi+    version = compilerVersion comp+    -- TODO: move this into the compiler abstraction+    -- FIXME: this forces GHC's crazy 4.8.2 -> 408 convention on all+    -- the other compilers. Check if that's really what they want.+    versionInt :: Version -> String+    versionInt (Version { versionBranch = [] }) = "1"+    versionInt (Version { versionBranch = [n] }) = show n+    versionInt (Version { versionBranch = n1:n2:_ })+      = -- 6.8.x -> 608+        -- 6.10.x -> 610+        let s1 = show n1+            s2 = show n2+            middle = case s2 of+                     _ : _ : _ -> ""+                     _         -> "0"+        in s1 ++ middle ++ s2+    osStr = case hostOS of+      Linux     -> ["linux"]+      Windows   -> ["mingw32"]+      OSX       -> ["darwin"]+      FreeBSD   -> ["freebsd"]+      OpenBSD   -> ["openbsd"]+      NetBSD    -> ["netbsd"]+      Solaris   -> ["solaris2"]+      AIX       -> ["aix"]+      HPUX      -> ["hpux"]+      IRIX      -> ["irix"]+      HaLVM     -> []+      IOS       -> ["ios"]+      OtherOS _ -> []+    archStr = case hostArch of+      I386        -> ["i386"]+      X86_64      -> ["x86_64"]+      PPC         -> ["powerpc"]+      PPC64       -> ["powerpc64"]+      Sparc       -> ["sparc"]+      Arm         -> ["arm"]+      Mips        -> ["mips"]+      SH          -> []+      IA64        -> ["ia64"]+      S390        -> ["s390"]+      Alpha       -> ["alpha"]+      Hppa        -> ["hppa"]+      Rs6000      -> ["rs6000"]+      M68k        -> ["m68k"]+      Vax         -> ["vax"]+      OtherArch _ -> []  ppHappy :: BuildInfo -> LocalBuildInfo -> PreProcessor ppHappy _ lbi = pp { platformIndependent = True }
cabal/Cabal/Distribution/Simple/Program.hs view
@@ -35,6 +35,8 @@ module Distribution.Simple.Program (     -- * Program and functions for constructing them       Program(..)+    , ProgramSearchPath+    , ProgramSearchPathEntry(..)     , simpleProgram     , findProgramLocation     , findProgramVersion@@ -46,6 +48,7 @@     , ProgramLocation(..)     , runProgram     , getProgramOutput+    , suppressOverrideArgs      -- * Program invocations     , ProgramInvocation(..)@@ -67,6 +70,8 @@     , addKnownPrograms     , lookupKnownProgram     , knownPrograms+    , getProgramSearchPath+    , setProgramSearchPath     , userSpecifyPath     , userSpecifyPaths     , userMaybeSpecifyPath@@ -95,7 +100,6 @@     , ffihugsProgram     , uhcProgram     , gccProgram-    , ranlibProgram     , arProgram     , stripProgram     , happyProgram
cabal/Cabal/Distribution/Simple/Program/Ar.hs view
@@ -1,3 +1,5 @@+{-# LANGUAGE OverloadedStrings #-}+ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.Ar@@ -10,25 +12,44 @@  module Distribution.Simple.Program.Ar (     createArLibArchive,-    multiStageProgramInvocation,+    multiStageProgramInvocation   ) where -import Distribution.Simple.Program.Types-         ( ConfiguredProgram(..) )+import Control.Monad (when, unless)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Char8 as BS8+import Data.Char (isSpace)+import Distribution.Compat.CopyFile (filesEqual)+import Distribution.Simple.Program+         ( ProgramConfiguration, arProgram, requireProgram ) import Distribution.Simple.Program.Run          ( programInvocation, multiStageProgramInvocation          , runProgramInvocation )+import qualified Distribution.Simple.Program.Strip as Strip+         ( stripLib )+import Distribution.Simple.Utils+         ( dieWithLocation, withTempDirectory ) import Distribution.System          ( OS(..), buildOS ) import Distribution.Verbosity          ( Verbosity, deafening, verbose )+import System.Directory (doesFileExist, renameFile)+import System.FilePath ((</>), splitFileName)+import System.IO+         ( Handle, IOMode(ReadWriteMode), SeekMode(AbsoluteSeek)+         , hFileSize, hSeek, withBinaryFile )  -- | Call @ar@ to create a library archive from a bunch of object files. ---createArLibArchive :: Verbosity -> ConfiguredProgram+createArLibArchive :: Verbosity -> ProgramConfiguration -> Bool                    -> FilePath -> [FilePath] -> IO ()-createArLibArchive verbosity ar target files =+createArLibArchive verbosity progConf stripLib targetPath files = do+  (ar, _) <- requireProgram verbosity arProgram progConf +  let (targetDir, targetName) = splitFileName targetPath+  withTempDirectory verbosity targetDir targetName $ \ tmpDir -> do+  let tmpPath = tmpDir </> targetName+   -- The args to use with "ar" are actually rather subtle and system-dependent.   -- In particular we have the following issues:   --@@ -52,19 +73,91 @@              OSX -> ["-q", "-s"]              _   -> ["-q"] -      extraArgs   = verbosityOpts verbosity ++ [target]+      extraArgs   = verbosityOpts verbosity ++ [tmpPath]        simple  = programInvocation ar (simpleArgs  ++ extraArgs)       initial = programInvocation ar (initialArgs ++ extraArgs)       middle  = initial       final   = programInvocation ar (finalArgs   ++ extraArgs) -   in sequence_+  sequence_         [ runProgramInvocation verbosity inv         | inv <- multiStageProgramInvocation                    simple (initial, middle, final) files ] +  when stripLib $ Strip.stripLib verbosity progConf tmpPath+  wipeMetadata tmpPath+  equal <- filesEqual tmpPath targetPath+  unless equal $ renameFile tmpPath targetPath+   where     verbosityOpts v | v >= deafening = ["-v"]                     | v >= verbose   = []                     | otherwise      = ["-c"]++-- | @ar@ by default includes various metadata for each object file in their+-- respective headers, so the output can differ for the same inputs, making+-- it difficult to avoid re-linking. GNU @ar@(1) has a deterministic mode+-- (@-D@) flag that always writes zero for the mtime, UID and GID, and 0644+-- for the file mode. However detecting whether @-D@ is supported seems+-- rather harder than just re-implementing this feature.+wipeMetadata :: FilePath -> IO ()+wipeMetadata path = do+    -- Check for existence first (ReadWriteMode would create one otherwise)+    exists <- doesFileExist path+    unless exists $ wipeError "Temporary file disappeared"+    withBinaryFile path ReadWriteMode $ \ h -> hFileSize h >>= wipeArchive h++  where+    wipeError msg = dieWithLocation path Nothing $+        "Distribution.Simple.Program.Ar.wipeMetadata: " ++ msg+    archLF = "!<arch>\x0a" -- global magic, 8 bytes+    x60LF = "\x60\x0a" -- header magic, 2 bytes+    metadata = BS.concat+        [ "0           " -- mtime, 12 bytes+        , "0     " -- UID, 6 bytes+        , "0     " -- GID, 6 bytes+        , "0644    " -- mode, 8 bytes+        ]+    headerSize = 60++    -- http://en.wikipedia.org/wiki/Ar_(Unix)#File_format_details+    wipeArchive :: Handle -> Integer -> IO ()+    wipeArchive h archiveSize = do+        global <- BS.hGet h (BS.length archLF)+        unless (global == archLF) $ wipeError "Bad global header"+        wipeHeader (toInteger $ BS.length archLF)++      where+        wipeHeader :: Integer -> IO ()+        wipeHeader offset = case compare offset archiveSize of+            EQ -> return ()+            GT -> wipeError (atOffset "Archive truncated")+            LT -> do+                header <- BS.hGet h headerSize+                unless (BS.length header == headerSize) $+                    wipeError (atOffset "Short header")+                let magic = BS.drop 58 header+                unless (magic == x60LF) . wipeError . atOffset $+                    "Bad magic " ++ show magic ++ " in header"++                let name = BS.take 16 header+                let size = BS.take 10 $ BS.drop 48 header+                objSize <- case reads (BS8.unpack size) of+                    [(n, s)] | all isSpace s -> return n+                    _ -> wipeError (atOffset "Bad file size in header")++                let replacement = BS.concat [ name, metadata, size, magic ]+                unless (BS.length replacement == headerSize) $+                    wipeError (atOffset "Something has gone terribly wrong")+                hSeek h AbsoluteSeek offset+                BS.hPut h replacement++                let nextHeader = offset + toInteger headerSize ++                        -- Odd objects are padded with an extra '\x0a'+                        if odd objSize then objSize + 1 else objSize+                hSeek h AbsoluteSeek nextHeader+                wipeHeader nextHeader++          where+            atOffset msg = msg ++ " at offset " ++ show offset
cabal/Cabal/Distribution/Simple/Program/Builtin.hs view
@@ -25,9 +25,10 @@     jhcProgram,     hugsProgram,     ffihugsProgram,+    haskellSuiteProgram,+    haskellSuitePkgProgram,     uhcProgram,     gccProgram,-    ranlibProgram,     arProgram,     stripProgram,     happyProgram,@@ -47,8 +48,10 @@  import Distribution.Simple.Program.Types          ( Program(..), simpleProgram )+import Distribution.Simple.Program.Find+         ( findProgramOnSearchPath ) import Distribution.Simple.Utils-         ( findProgramLocation, findProgramVersion )+         ( findProgramVersion )  -- ------------------------------------------------------------ -- * Known programs@@ -64,6 +67,8 @@     , ghcPkgProgram     , hugsProgram     , ffihugsProgram+    , haskellSuiteProgram+    , haskellSuitePkgProgram     , nhcProgram     , hmakeProgram     , jhcProgram@@ -82,7 +87,6 @@     , greencardProgram     -- platform toolchain     , gccProgram-    , ranlibProgram     , arProgram     , stripProgram     , ldProgram@@ -173,6 +177,39 @@ ffihugsProgram :: Program ffihugsProgram = simpleProgram "ffihugs" +-- This represents a haskell-suite compiler. Of course, the compiler+-- itself probably is not called "haskell-suite", so this is not a real+-- program. (But we don't know statically the name of the actual compiler,+-- so this is the best we can do.)+--+-- Having this Program value serves two purposes:+--+-- 1. We can accept options for the compiler in the form of+--+--   --haskell-suite-option(s)=...+--+-- 2. We can find a program later using this static id (with+-- requireProgram).+--+-- The path to the real compiler is found and recorded in the ProgramDb+-- during the configure phase.+haskellSuiteProgram :: Program+haskellSuiteProgram = (simpleProgram "haskell-suite") {+    -- pretend that the program exists, otherwise it won't be in the+    -- "configured" state+    programFindLocation =+      \_verbosity _searchPath -> return $ Just "haskell-suite-dummy-location"+  }++-- This represent a haskell-suite package manager. See the comments for+-- haskellSuiteProgram.+haskellSuitePkgProgram :: Program+haskellSuitePkgProgram = (simpleProgram "haskell-suite-pkg") {+    programFindLocation =+      \_verbosity _searchPath -> return $ Just "haskell-suite-pkg-dummy-location"+  }++ happyProgram :: Program happyProgram = (simpleProgram "happy") {     programFindVersion = findProgramVersion "--version" $ \str ->@@ -198,9 +235,6 @@     programFindVersion = findProgramVersion "-dumpversion" id   } -ranlibProgram :: Program-ranlibProgram = simpleProgram "ranlib"- arProgram :: Program arProgram = simpleProgram "ar" @@ -233,7 +267,7 @@  hscolourProgram :: Program hscolourProgram = (simpleProgram "hscolour") {-    programFindLocation = \v -> findProgramLocation v "HsColour",+    programFindLocation = \v p -> findProgramOnSearchPath v p "HsColour",     programFindVersion  = findProgramVersion "-version" $ \str ->       -- Invoking "HsColour -version" gives a string like "HsColour 1.7"       case words str of
cabal/Cabal/Distribution/Simple/Program/Db.hs view
@@ -32,6 +32,8 @@     addKnownPrograms,     lookupKnownProgram,     knownPrograms,+    getProgramSearchPath,+    setProgramSearchPath,     userSpecifyPath,     userSpecifyPaths,     userMaybeSpecifyPath,@@ -40,6 +42,7 @@     userSpecifiedArgs,     lookupProgram,     updateProgram,+    configuredPrograms,      -- ** Query and manipulate the program db     configureProgram,@@ -52,10 +55,13 @@  import Distribution.Simple.Program.Types          ( Program(..), ProgArg, ConfiguredProgram(..), ProgramLocation(..) )+import Distribution.Simple.Program.Find+         ( ProgramSearchPath, defaultProgramSearchPath+         , findProgramOnSearchPath, programSearchPathAsPATHVar ) import Distribution.Simple.Program.Builtin          ( builtinPrograms ) import Distribution.Simple.Utils-         ( die, findProgramLocation )+         ( die, doesExecutableExist ) import Distribution.Version          ( Version, VersionRange, isAnyVersion, withinRange ) import Distribution.Text@@ -70,10 +76,7 @@ import qualified Data.Map as Map import Control.Monad          ( join, foldM )-import System.Directory-         ( doesFileExist ) - -- ------------------------------------------------------------ -- * Programs database -- ------------------------------------------------------------@@ -88,6 +91,7 @@ -- 'Program' but also any user-provided arguments and location for the program. data ProgramDb = ProgramDb {         unconfiguredProgs :: UnconfiguredProgs,+        progSearchPath    :: ProgramSearchPath,         configuredProgs   :: ConfiguredProgs     } @@ -97,8 +101,7 @@   emptyProgramDb :: ProgramDb-emptyProgramDb = ProgramDb Map.empty Map.empty-+emptyProgramDb = ProgramDb Map.empty defaultProgramSearchPath Map.empty  defaultProgramDb :: ProgramDb defaultProgramDb = restoreProgramDb builtinPrograms emptyProgramDb@@ -166,7 +169,22 @@   [ (p,p') | (p,_,_) <- Map.elems (unconfiguredProgs conf)            , let p' = Map.lookup (programName p) (configuredProgs conf) ] +-- | Get the current 'ProgramSearchPath' used by the 'ProgramDb'.+-- This is the default list of locations where programs are looked for when+-- configuring them. This can be overriden for specific programs (with+-- 'userSpecifyPath'), and specific known programs can modify or ignore this+-- search path in their own configuration code.+--+getProgramSearchPath :: ProgramDb -> ProgramSearchPath+getProgramSearchPath = progSearchPath +-- | Change the current 'ProgramSearchPath' used by the 'ProgramDb'.+-- This will affect programs that are configured from here on, so you+-- should usually set it before configuring any programs.+--+setProgramSearchPath :: ProgramSearchPath -> ProgramDb -> ProgramDb+setProgramSearchPath searchpath db = db { progSearchPath = searchpath }+ -- |User-specify this path.  Basically override any path information -- for this program in the configuration. If it's not a known -- program ignore it.@@ -248,6 +266,10 @@   Map.insert (programId prog) prog  +-- | List all configured programs.+configuredPrograms :: ProgramDb -> [ConfiguredProgram]+configuredPrograms = Map.elems . configuredProgs+ -- --------------------------- -- Configuring known programs @@ -272,31 +294,32 @@ configureProgram verbosity prog conf = do   let name = programName prog   maybeLocation <- case userSpecifiedPath prog conf of-    Nothing   -> programFindLocation prog verbosity+    Nothing   -> programFindLocation prog verbosity (progSearchPath conf)              >>= return . fmap FoundOnSystem     Just path -> do-      absolute <- doesFileExist path+      absolute <- doesExecutableExist path       if absolute         then return (Just (UserSpecified path))-        else findProgramLocation verbosity path+        else findProgramOnSearchPath verbosity (progSearchPath conf) path          >>= maybe (die notFound) (return . Just . UserSpecified)-      where notFound = "Cannot find the program '" ++ name ++ "' at '"-                     ++ path ++ "' or on the path"+      where notFound = "Cannot find the program '" ++ name+                     ++ "'. User-specified path '"+                     ++ path ++ "' does not refer to an executable and "+                     ++ "the program is not on the system path."   case maybeLocation of     Nothing -> return conf     Just location -> do       version <- programFindVersion prog verbosity (locationPath location)+      newPath <- programSearchPathAsPATHVar (progSearchPath conf)       let configuredProg        = ConfiguredProgram {             programId           = name,             programVersion      = version,             programDefaultArgs  = [],             programOverrideArgs = userSpecifiedArgs prog conf,+            programOverrideEnv  = [("PATH", Just newPath)],             programLocation     = location           }-      extraArgs <- programPostConf prog verbosity configuredProg-      let configuredProg'       = configuredProg {-            programDefaultArgs  = extraArgs-          }+      configuredProg' <- programPostConf prog verbosity configuredProg       return (updateConfiguredProgs (Map.insert name configuredProg') conf)
+ cabal/Cabal/Distribution/Simple/Program/Find.hs view
@@ -0,0 +1,125 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Program.Types+-- Copyright   :  Duncan Coutts 2013+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- A somewhat extended notion of the normal program search path concept.+--+-- Usually when finding executables we just want to look in the usual places+-- using the OS's usual method for doing so. In Haskell the normal OS-specific+-- method is captured by 'findExecutable'. On all common OSs that makes use of+-- a @PATH@ environment variable, (though on Windows it is not just the @PATH@).+--+-- However it is sometimes useful to be able to look in additional locations+-- without having to change the process-global @PATH@ environment variable.+-- So we need an extension of the usual 'findExecutable' that can look in+-- additional locations, either before, after or instead of the normal OS+-- locations.+--+module Distribution.Simple.Program.Find (+    -- * Program search path+    ProgramSearchPath,+    ProgramSearchPathEntry(..),+    defaultProgramSearchPath,+    findProgramOnSearchPath,+    programSearchPathAsPATHVar,+  ) where++import Distribution.Verbosity+         ( Verbosity )+import Distribution.Simple.Utils+         ( debug, doesExecutableExist )+import Distribution.System+         ( OS(..), buildOS )+import System.Directory+         ( findExecutable )+import Distribution.Compat.Environment+         ( getEnvironment )+import System.FilePath+         ( (</>), (<.>), splitSearchPath, searchPathSeparator )+import Data.List+         ( intercalate )+++-- | A search path to use when locating executables. This is analogous+-- to the unix @$PATH@ or win32 @%PATH%@ but with the ability to use+-- the system default method for finding executables ('findExecutable' which+-- on unix is simply looking on the @$PATH@ but on win32 is a bit more+-- complicated).+--+-- The default to use is @[ProgSearchPathDefault]@ but you can add extra dirs+-- either before, after or instead of the default, e.g. here we add an extra+-- dir to search after the usual ones.+--+-- > ['ProgramSearchPathDefault', 'ProgramSearchPathDir' dir]+--+type ProgramSearchPath = [ProgramSearchPathEntry]+data ProgramSearchPathEntry =+         ProgramSearchPathDir FilePath  -- ^ A specific dir+       | ProgramSearchPathDefault       -- ^ The system default++defaultProgramSearchPath :: ProgramSearchPath+defaultProgramSearchPath = [ProgramSearchPathDefault]++findProgramOnSearchPath :: Verbosity -> ProgramSearchPath+                        -> FilePath -> IO (Maybe FilePath)+findProgramOnSearchPath verbosity searchpath prog = do+    debug verbosity $ "Searching for " ++ prog ++ " in path."+    res <- tryPathElems searchpath+    case res of+      Nothing   -> debug verbosity ("Cannot find " ++ prog ++ " on the path")+      Just path -> debug verbosity ("Found " ++ prog ++ " at "++ path)+    return res+  where+    tryPathElems []       = return Nothing+    tryPathElems (pe:pes) = do+      res <- tryPathElem pe+      case res of+        Nothing -> tryPathElems pes+        Just _  -> return res++    tryPathElem (ProgramSearchPathDir dir) =+        findFirstExe [ dir </> prog <.> ext | ext <- extensions ]+      where+        -- Possible improvement: on Windows, read the list of extensions from+        -- the PATHEXT environment variable. By default PATHEXT is ".com; .exe;+        -- .bat; .cmd".+        extensions = case buildOS of+                       Windows -> ["", "exe"]+                       _       -> [""]++    tryPathElem ProgramSearchPathDefault = do+      -- 'findExecutable' doesn't check that the path really refers to an+      -- executable on Windows (at least with GHC < 7.8). See+      -- https://ghc.haskell.org/trac/ghc/ticket/2184+      mExe <- findExecutable prog+      case mExe of+        Just exe -> do+          exeExists <- doesExecutableExist exe+          if exeExists+            then return mExe+            else return Nothing+        _        -> return mExe++    findFirstExe []     = return Nothing+    findFirstExe (f:fs) = do+      isExe <- doesExecutableExist f+      if isExe+        then return (Just f)+        else findFirstExe fs++-- | Interpret a 'ProgramSearchPath' to construct a new @$PATH@ env var.+-- Note that this is close but not perfect because on Windows the search+-- algorithm looks at more than just the @%PATH%@.+programSearchPathAsPATHVar :: ProgramSearchPath -> IO String+programSearchPathAsPATHVar searchpath = do+    ess <- mapM getEntries searchpath+    return (intercalate [searchPathSeparator] (concat ess))+  where+    getEntries (ProgramSearchPathDir dir) = return [dir]+    getEntries ProgramSearchPathDefault   = do+      env <- getEnvironment+      return (maybe [] splitSearchPath (lookup "PATH" env))
cabal/Cabal/Distribution/Simple/Program/GHC.hs view
@@ -2,6 +2,7 @@     GhcOptions(..),     GhcMode(..),     GhcOptimisation(..),+    GhcDynLinkMode(..),      ghcInvocation,     renderGhcOptions,@@ -13,18 +14,18 @@ import Distribution.Package import Distribution.ModuleName import Distribution.Simple.Compiler hiding (Flag)-import Distribution.Simple.Setup    (Flag(..), flagToMaybe, fromFlagOrDefault, flagToList)+import Distribution.Simple.Setup    ( Flag(..), flagToMaybe, fromFlagOrDefault,+                                      flagToList ) --import Distribution.Simple.LocalBuildInfo import Distribution.Simple.Program.Types import Distribution.Simple.Program.Run import Distribution.Text import Distribution.Verbosity import Distribution.Version-import Language.Haskell.Extension ( Language(..), Extension(..) )+import Language.Haskell.Extension   ( Language(..), Extension(..) )  import Data.Monoid - -- | A structured set of GHC options/flags -- data GhcOptions = GhcOptions {@@ -52,6 +53,10 @@   -- | Location for output file; the @ghc -o@ flag.   ghcOptOutputFile    :: Flag FilePath, +  -- | Location for dynamic output file in 'GhcStaticAndDynamic' mode;+  -- the @ghc -dyno@ flag.+  ghcOptOutputDynFile :: Flag FilePath,+   -- | Start with an empty search path for Haskell source files;   -- the @ghc -i@ flag (@-i@ on it's own with no path argument).   ghcOptSourcePathClear :: Flag Bool,@@ -97,6 +102,9 @@   -- | Don't do the link step, useful in make mode; the @ghc -no-link@ flag.   ghcOptNoLink :: Flag Bool, +  -- | Don't link in the normal RTS @main@ entry point; the @ghc -no-hs-main@ flag.+  ghcOptLinkNoHsMain :: Flag Bool,+   --------------------   -- C and CPP stuff @@ -140,6 +148,9 @@   -- | Use the \"split object files\" feature; the @ghc -split-objs@ flag.   ghcOptSplitObjs     :: Flag Bool, +  -- | Run N jobs simultaneously (if possible).+  ghcOptNumJobs       :: Flag Int,+   ----------------   -- GHCi @@ -151,14 +162,17 @@    ghcOptHiSuffix      :: Flag String,   ghcOptObjSuffix     :: Flag String,+  ghcOptDynHiSuffix   :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode+  ghcOptDynObjSuffix  :: Flag String,   -- ^ only in 'GhcStaticAndDynamic' mode   ghcOptHiDir         :: Flag FilePath,   ghcOptObjDir        :: Flag FilePath,+  ghcOptOutputDir     :: Flag FilePath,   ghcOptStubDir       :: Flag FilePath,    --------------------   -- Dynamic linking -  ghcOptDynamic       :: Flag Bool,+  ghcOptDynLinkMode   :: Flag GhcDynLinkMode,   ghcOptShared        :: Flag Bool,   ghcOptFPic          :: Flag Bool,   ghcOptDylibName     :: Flag String,@@ -191,21 +205,28 @@                      | GhcSpecialOptimisation String -- ^ e.g. @-Odph@  deriving (Show, Eq) +data GhcDynLinkMode = GhcStaticOnly       -- ^ @-static@+                    | GhcDynamicOnly      -- ^ @-dynamic@+                    | GhcStaticAndDynamic -- ^ @-static -dynamic-too@+ deriving (Show, Eq) -runGHC :: Verbosity -> ConfiguredProgram -> GhcOptions -> IO ()-runGHC verbosity ghcProg opts = do-  runProgramInvocation verbosity (ghcInvocation ghcProg opts) +runGHC :: Verbosity -> ConfiguredProgram -> Compiler -> GhcOptions -> IO ()+runGHC verbosity ghcProg comp opts = do+  runProgramInvocation verbosity (ghcInvocation ghcProg comp opts) -ghcInvocation :: ConfiguredProgram -> GhcOptions -> ProgramInvocation-ghcInvocation ConfiguredProgram { programVersion = Nothing } _ =-    error "ghcInvocation: the programVersion must not be Nothing"-ghcInvocation prog@ConfiguredProgram { programVersion = Just ver } opts =-    programInvocation prog (renderGhcOptions ver opts) +ghcInvocation :: ConfiguredProgram -> Compiler -> GhcOptions -> ProgramInvocation+ghcInvocation prog comp opts =+    programInvocation prog (renderGhcOptions comp opts) -renderGhcOptions :: Version -> GhcOptions -> [String]-renderGhcOptions version@(Version ver _) opts =++renderGhcOptions :: Compiler -> GhcOptions -> [String]+renderGhcOptions comp opts+  | compilerFlavor comp /= GHC =+    error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "+    ++ "compiler flavor must be 'GHC'!"+  | otherwise =   concat   [ case flagToMaybe (ghcOptMode opts) of        Nothing                 -> []@@ -242,11 +263,22 @@    , [ "-split-objs" | flagBool ghcOptSplitObjs ] ++  , if parmakeSupported comp+    then+      let numJobs = fromFlagOrDefault 1 (ghcOptNumJobs opts)+      in if numJobs > 1 then ["-j" ++ show numJobs] else []+    else []+   --------------------   -- Dynamic linking    , [ "-shared"  | flagBool ghcOptShared  ]-  , [ "-dynamic" | flagBool ghcOptDynamic ]+  , case flagToMaybe (ghcOptDynLinkMode opts) of+      Nothing                  -> []+      Just GhcStaticOnly       -> ["-static"]+      Just GhcDynamicOnly      -> ["-dynamic"]+      Just GhcStaticAndDynamic -> ["-static", "-dynamic-too"]   , [ "-fPIC"    | flagBool ghcOptFPic ]    , concat [ ["-dylib-install-name", libname] | libname <- flag ghcOptDylibName ]@@ -256,6 +288,9 @@    , concat [ ["-osuf",    suf] | suf <- flag ghcOptObjSuffix ]   , concat [ ["-hisuf",   suf] | suf <- flag ghcOptHiSuffix  ]+  , concat [ ["-dynosuf", suf] | suf <- flag ghcOptDynObjSuffix ]+  , concat [ ["-dynhisuf",suf] | suf <- flag ghcOptDynHiSuffix  ]+  , concat [ ["-outputdir", dir] | dir <- flag ghcOptOutputDir, ver >= [6,10] ]   , concat [ ["-odir",    dir] | dir <- flag ghcOptObjDir ]   , concat [ ["-hidir",   dir] | dir <- flag ghcOptHiDir  ]   , concat [ ["-stubdir", dir] | dir <- flag ghcOptStubDir, ver >= [6,8] ]@@ -282,6 +317,7 @@   , ["-l" ++ lib     | lib <- flags ghcOptLinkLibs ]   , ["-L" ++ dir     | dir <- flags ghcOptLinkLibPath ]   , concat [ ["-framework", fmwk] | fmwk <- flags ghcOptLinkFrameworks ]+  , [ "-no-hs-main"  | flagBool ghcOptLinkNoHsMain ]    -------------   -- Packages@@ -306,8 +342,8 @@    , [ case lookup ext (ghcOptExtensionMap opts) of         Just arg -> arg-        Nothing  -> error $ "renderGhcOptions: " ++ display ext-                          ++ " not present in ghcOptExtensionMap."+        Nothing  -> error $ "Distribution.Simple.Program.GHC.renderGhcOptions: "+                          ++ display ext ++ " not present in ghcOptExtensionMap."     | ext <- ghcOptExtensions opts ]    ----------------@@ -322,7 +358,8 @@   , [ display modu | modu <- flags ghcOptInputModules ]   , ghcOptInputFiles opts -  , concat [ [ "-o", out] | out <- flag ghcOptOutputFile ]+  , concat [ [ "-o",    out] | out <- flag ghcOptOutputFile ]+  , concat [ [ "-dyno", out] | out <- flag ghcOptOutputDynFile ]    ---------------   -- Extra@@ -337,6 +374,7 @@     flags    flg = flg opts     flagBool flg = fromFlagOrDefault False (flg opts) +    version@(Version ver _) = compilerVersion comp  verbosityOpts :: Verbosity -> [String] verbosityOpts verbosity@@ -375,6 +413,7 @@     ghcOptInputFiles         = mempty,     ghcOptInputModules       = mempty,     ghcOptOutputFile         = mempty,+    ghcOptOutputDynFile      = mempty,     ghcOptSourcePathClear    = mempty,     ghcOptSourcePath         = mempty,     ghcOptPackageName        = mempty,@@ -387,6 +426,7 @@     ghcOptLinkOptions        = mempty,     ghcOptLinkFrameworks     = mempty,     ghcOptNoLink             = mempty,+    ghcOptLinkNoHsMain       = mempty,     ghcOptCcOptions          = mempty,     ghcOptCppOptions         = mempty,     ghcOptCppIncludePath     = mempty,@@ -398,13 +438,17 @@     ghcOptOptimisation       = mempty,     ghcOptProfilingMode      = mempty,     ghcOptSplitObjs          = mempty,+    ghcOptNumJobs            = mempty,     ghcOptGHCiScripts        = mempty,     ghcOptHiSuffix           = mempty,     ghcOptObjSuffix          = mempty,+    ghcOptDynHiSuffix        = mempty,+    ghcOptDynObjSuffix       = mempty,     ghcOptHiDir              = mempty,     ghcOptObjDir             = mempty,+    ghcOptOutputDir          = mempty,     ghcOptStubDir            = mempty,-    ghcOptDynamic            = mempty,+    ghcOptDynLinkMode        = mempty,     ghcOptShared             = mempty,     ghcOptFPic               = mempty,     ghcOptDylibName          = mempty,@@ -418,6 +462,7 @@     ghcOptInputFiles         = combine ghcOptInputFiles,     ghcOptInputModules       = combine ghcOptInputModules,     ghcOptOutputFile         = combine ghcOptOutputFile,+    ghcOptOutputDynFile      = combine ghcOptOutputDynFile,     ghcOptSourcePathClear    = combine ghcOptSourcePathClear,     ghcOptSourcePath         = combine ghcOptSourcePath,     ghcOptPackageName        = combine ghcOptPackageName,@@ -430,6 +475,7 @@     ghcOptLinkOptions        = combine ghcOptLinkOptions,     ghcOptLinkFrameworks     = combine ghcOptLinkFrameworks,     ghcOptNoLink             = combine ghcOptNoLink,+    ghcOptLinkNoHsMain       = combine ghcOptLinkNoHsMain,     ghcOptCcOptions          = combine ghcOptCcOptions,     ghcOptCppOptions         = combine ghcOptCppOptions,     ghcOptCppIncludePath     = combine ghcOptCppIncludePath,@@ -441,13 +487,17 @@     ghcOptOptimisation       = combine ghcOptOptimisation,     ghcOptProfilingMode      = combine ghcOptProfilingMode,     ghcOptSplitObjs          = combine ghcOptSplitObjs,+    ghcOptNumJobs            = combine ghcOptNumJobs,     ghcOptGHCiScripts        = combine ghcOptGHCiScripts,     ghcOptHiSuffix           = combine ghcOptHiSuffix,     ghcOptObjSuffix          = combine ghcOptObjSuffix,+    ghcOptDynHiSuffix        = combine ghcOptDynHiSuffix,+    ghcOptDynObjSuffix       = combine ghcOptDynObjSuffix,     ghcOptHiDir              = combine ghcOptHiDir,     ghcOptObjDir             = combine ghcOptObjDir,+    ghcOptOutputDir          = combine ghcOptOutputDir,     ghcOptStubDir            = combine ghcOptStubDir,-    ghcOptDynamic            = combine ghcOptDynamic,+    ghcOptDynLinkMode        = combine ghcOptDynLinkMode,     ghcOptShared             = combine ghcOptShared,     ghcOptFPic               = combine ghcOptFPic,     ghcOptDylibName          = combine ghcOptDylibName,
cabal/Cabal/Distribution/Simple/Program/HcPkg.hs view
@@ -1,7 +1,7 @@ ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Program.HcPkg--- Copyright   :  Duncan Coutts 2009+-- Copyright   :  Duncan Coutts 2009, 2013 -- -- Maintainer  :  cabal-devel@haskell.org -- Portability :  portable@@ -11,12 +11,14 @@  module Distribution.Simple.Program.HcPkg (     init,+    invoke,     register,     reregister,     unregister,     expose,     hide,     dump,+    list,      -- * Program invocations     initInvocation,@@ -26,6 +28,7 @@     exposeInvocation,     hideInvocation,     dumpInvocation,+    listInvocation,   ) where  import Prelude hiding (init)@@ -46,7 +49,7 @@ import Distribution.Version          ( Version(..) ) import Distribution.Text-         ( display )+         ( display, simpleParse ) import Distribution.Simple.Utils          ( die ) import Distribution.Verbosity@@ -74,6 +77,15 @@   runProgramInvocation verbosity     (initInvocation hcPkg verbosity path) +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+invoke :: Verbosity -> ConfiguredProgram -> PackageDBStack -> [String] -> IO ()+invoke verbosity hcPkg dbStack extraArgs =+  runProgramInvocation verbosity invocation+  where+    args       = packageDbStackOpts hcPkg dbStack ++ extraArgs+    invocation = programInvocation hcPkg args+ -- | Call @hc-pkg@ to register a package. -- -- > hc-pkg register {filename | -} [--user | --global | --package-db]@@ -130,7 +142,8 @@     (hideInvocation hcPkg verbosity packagedb pkgid)  --- | Call @hc-pkg@ to get all the installed packages.+-- | Call @hc-pkg@ to get all the details of all the packages in the given+-- package database. -- dump :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [InstalledPackageInfo] dump verbosity hcPkg packagedb = do@@ -236,6 +249,33 @@ setInstalledPackageId pkginfo = pkginfo  +-- | Call @hc-pkg@ to get the source package Id of all the packages in the+-- given package database.+--+-- This is much less information than with 'dump', but also rather quicker.+-- Note in particular that it does not include the 'InstalledPackageId', just+-- the source 'PackageId' which is not necessarily unique in any package db.+--+list :: Verbosity -> ConfiguredProgram -> PackageDB -> IO [PackageId]+list verbosity hcPkg packagedb = do++  output <- getProgramInvocationOutput verbosity+              (listInvocation hcPkg verbosity packagedb)+    `catchExit` \_ -> die $ programId hcPkg ++ " list failed"++  case parsePackageIds output of+    Just ok -> return ok+    _       -> die $ "failed to parse output of '"+                  ++ programId hcPkg ++ " list'"++  where+    parsePackageIds str =+      let parsed = map simpleParse (words str)+       in case [ () | Nothing <- parsed ] of+            [] -> Just [ pkgid | Just pkgid <- parsed ]+            _  -> Nothing++ -------------------------- -- The program invocations --@@ -315,6 +355,18 @@     }   where     args = ["dump", packageDbOpts hcPkg packagedb]+        ++ verbosityOpts hcPkg silent+           -- We use verbosity level 'silent' because it is important that we+           -- do not contaminate the output with info/debug messages.++listInvocation :: ConfiguredProgram+               -> Verbosity -> PackageDB -> ProgramInvocation+listInvocation hcPkg _verbosity packagedb =+    (programInvocation hcPkg args) {+      progInvokeOutputEncoding = IOEncodingUTF8+    }+  where+    args = ["list", "--simple-output", packageDbOpts hcPkg packagedb]         ++ verbosityOpts hcPkg silent            -- We use verbosity level 'silent' because it is important that we            -- do not contaminate the output with info/debug messages.
cabal/Cabal/Distribution/Simple/Program/Hpc.hs view
@@ -16,34 +16,61 @@ import Distribution.ModuleName ( ModuleName ) import Distribution.Simple.Program.Run          ( ProgramInvocation, programInvocation, runProgramInvocation )-import Distribution.Simple.Program.Types ( ConfiguredProgram )+import Distribution.Simple.Program.Types ( ConfiguredProgram(..) ) import Distribution.Text ( display )+import Distribution.Simple.Utils ( warn ) import Distribution.Verbosity ( Verbosity )+import Distribution.Version ( Version(..), orLaterVersion, withinRange ) +-- | Invoke hpc with the given parameters.+--+-- Prior to HPC version 0.7 (packaged with GHC 7.8), hpc did not handle+-- multiple .mix paths correctly, so we print a warning, and only pass it the+-- first path in the list. This means that e.g. test suites that import their+-- library as a dependency can still work, but those that include the library+-- modules directly (in other-modules) don't. markup :: ConfiguredProgram+       -> Version        -> Verbosity        -> FilePath            -- ^ Path to .tix file-       -> FilePath            -- ^ Path to directory with .mix files+       -> [FilePath]          -- ^ Paths to .mix file directories        -> FilePath            -- ^ Path where html output should be located        -> [ModuleName]        -- ^ List of modules to exclude from report        -> IO ()-markup hpc verbosity tixFile hpcDir destDir excluded =+markup hpc hpcVer verbosity tixFile hpcDirs destDir excluded = do+    hpcDirs' <- if withinRange hpcVer (orLaterVersion version07)+        then return hpcDirs+        else do+            warn verbosity $ "Your version of HPC (" ++ display hpcVer+                ++ ") does not properly handle multiple search paths. "+                ++ "Coverage report generation may fail unexpectedly. These "+                ++ "issues are addressed in version 0.7 or later (GHC 7.8 or "+                ++ "later)."+                ++ if null droppedDirs+                    then ""+                    else " The following search paths have been abandoned: "+                        ++ show droppedDirs+            return passedDirs+     runProgramInvocation verbosity-      (markupInvocation hpc tixFile hpcDir destDir excluded)+      (markupInvocation hpc tixFile hpcDirs' destDir excluded)+  where+    version07 = Version { versionBranch = [0, 7], versionTags = [] }+    (passedDirs, droppedDirs) = splitAt 1 hpcDirs  markupInvocation :: ConfiguredProgram                  -> FilePath            -- ^ Path to .tix file-                 -> FilePath            -- ^ Path to directory with .mix files+                 -> [FilePath]          -- ^ Paths to .mix file directories                  -> FilePath            -- ^ Path where html output should be                                         -- located                  -> [ModuleName]        -- ^ List of modules to exclude from                                         -- report                  -> ProgramInvocation-markupInvocation hpc tixFile hpcDir destDir excluded =+markupInvocation hpc tixFile hpcDirs destDir excluded =     let args = [ "markup", tixFile-               , "--hpcdir=" ++ hpcDir                , "--destdir=" ++ destDir                ]+            ++ map ("--hpcdir=" ++) hpcDirs             ++ ["--exclude=" ++ display moduleName                | moduleName <- excluded ]     in programInvocation hpc args
cabal/Cabal/Distribution/Simple/Program/Run.hs view
@@ -20,22 +20,26 @@     runProgramInvocation,     getProgramInvocationOutput, +    getEffectiveEnvironment,   ) where  import Distribution.Simple.Program.Types          ( ConfiguredProgram(..), programPath ) import Distribution.Simple.Utils-         ( die, rawSystemExit, rawSystemStdInOut+         ( die, rawSystemExit, rawSystemIOWithEnv, rawSystemStdInOut          , toUTF8, fromUTF8, normaliseLineEndings ) import Distribution.Verbosity          ( Verbosity )  import Data.List          ( foldl', unfoldr )+import qualified Data.Map as Map import Control.Monad          ( when ) import System.Exit-         ( ExitCode(..) )+         ( ExitCode(..), exitWith )+import Distribution.Compat.Environment+         ( getEnvironment )  -- | Represents a specific invocation of a specific program. --@@ -47,7 +51,7 @@ data ProgramInvocation = ProgramInvocation {        progInvokePath  :: FilePath,        progInvokeArgs  :: [String],-       progInvokeEnv   :: [(String, String)],+       progInvokeEnv   :: [(String, Maybe String)],        progInvokeCwd   :: Maybe FilePath,        progInvokeInput :: Maybe String,        progInvokeInputEncoding  :: IOEncoding,@@ -82,7 +86,8 @@     progInvokePath = programPath prog,     progInvokeArgs = programDefaultArgs prog                   ++ args-                  ++ programOverrideArgs prog+                  ++ programOverrideArgs prog,+    progInvokeEnv  = programOverrideEnv prog   }  @@ -101,23 +106,39 @@   ProgramInvocation {     progInvokePath  = path,     progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,+    progInvokeInput = Nothing+  } = do+    menv <- getEffectiveEnvironment envOverrides+    exitCode <- rawSystemIOWithEnv verbosity+                                   path args+                                   mcwd menv+                                   Nothing Nothing Nothing+    when (exitCode /= ExitSuccess) $+      exitWith exitCode++runProgramInvocation verbosity+  ProgramInvocation {+    progInvokePath  = path,+    progInvokeArgs  = args,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,     progInvokeInput = Just inputStr,     progInvokeInputEncoding = encoding   } = do+    menv <- getEffectiveEnvironment envOverrides     (_, errors, exitCode) <- rawSystemStdInOut verbosity                                     path args-                                    (Just input) False+                                    mcwd menv+                                    (Just input) True     when (exitCode /= ExitSuccess) $       die errors   where     input = case encoding of               IOEncodingText -> (inputStr, False)-              IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8--runProgramInvocation _ _ =-   die "runProgramInvocation: not yet implemented for this form of invocation"+              IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for+                                                        -- utf8   getProgramInvocationOutput :: Verbosity -> ProgramInvocation -> IO String@@ -125,25 +146,43 @@   ProgramInvocation {     progInvokePath  = path,     progInvokeArgs  = args,-    progInvokeEnv   = [],-    progInvokeCwd   = Nothing,-    progInvokeInput = Nothing,+    progInvokeEnv   = envOverrides,+    progInvokeCwd   = mcwd,+    progInvokeInput = minputStr,     progInvokeOutputEncoding = encoding   } = do-  let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False-      decode | utf8      = fromUTF8 . normaliseLineEndings-             | otherwise = id-  (output, errors, exitCode) <- rawSystemStdInOut verbosity-                                  path args-                                  Nothing utf8-  when (exitCode /= ExitSuccess) $-    die errors-  return (decode output)+    let utf8 = case encoding of IOEncodingUTF8 -> True; _ -> False+        decode | utf8      = fromUTF8 . normaliseLineEndings+               | otherwise = id+    menv <- getEffectiveEnvironment envOverrides+    (output, errors, exitCode) <- rawSystemStdInOut verbosity+                                    path args+                                    mcwd menv+                                    input utf8+    when (exitCode /= ExitSuccess) $+      die errors+    return (decode output)+  where+    input =+      case minputStr of+        Nothing       -> Nothing+        Just inputStr -> Just $+          case encoding of+            IOEncodingText -> (inputStr, False)+            IOEncodingUTF8 -> (toUTF8 inputStr, True) -- use binary mode for utf8  -getProgramInvocationOutput _ _ =-   die "getProgramInvocationOutput: not yet implemented for this form of invocation"-+-- | Return the current environment extended with the given overrides.+--+getEffectiveEnvironment :: [(String, Maybe String)]+                        -> IO (Maybe [(String, String)])+getEffectiveEnvironment []        = return Nothing+getEffectiveEnvironment overrides =+    fmap (Just . Map.toList . apply overrides . Map.fromList) getEnvironment+  where+    apply os env = foldl' (flip update) env os+    update (var, Nothing)  = Map.delete var+    update (var, Just val) = Map.insert var val  -- | Like the unix xargs program. Useful for when we've got very long command -- lines that might overflow an OS limit on command line length and so you
cabal/Cabal/Distribution/Simple/Program/Script.hs view
@@ -44,8 +44,7 @@     progInvokeInput = minput   } = unlines $           [ "#!/bin/sh" ]-       ++ [ "export " ++ var ++ "=" ++ quote val-          | (var,val) <- envExtra ]+       ++ concatMap setEnv envExtra        ++ [ "cd " ++ quote cwd | cwd <- maybeToList mcwd ]        ++ [ (case minput of               Nothing    -> ""@@ -53,6 +52,9 @@          ++ unwords (map quote $ path : args) ++ " \"$@\""]    where+    setEnv (var, Nothing)  = ["unset " ++ var, "export " ++ var]+    setEnv (var, Just val) = ["export " ++ var ++ "=" ++ quote val]+     quote :: String -> String     quote s = "'" ++ escape s ++ "'" @@ -73,7 +75,7 @@     progInvokeInput = minput   } = unlines $           [ "@echo off" ]-       ++ [ "set " ++ var ++ "=" ++ escape val | (var,val) <- envExtra ]+       ++ map setEnv envExtra        ++ [ "cd \"" ++ cwd ++ "\"" | cwd <- maybeToList mcwd ]        ++ case minput of             Nothing    ->@@ -87,6 +89,9 @@                ++ concatMap (\arg -> ' ':quote arg) args ]    where+    setEnv (var, Nothing)  = "set " ++ var ++ "="+    setEnv (var, Just val) = "set " ++ var ++ "=" ++ escape val+     quote :: String -> String     quote s = "\"" ++ escapeQ s ++ "\""
+ cabal/Cabal/Distribution/Simple/Program/Strip.hs view
@@ -0,0 +1,48 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Simple.Program.Strip+--+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- This module provides an library interface to the @strip@ program.++module Distribution.Simple.Program.Strip (stripLib, stripExe)+       where++import Distribution.Simple.Program (ProgramConfiguration, lookupProgram+                                   ,rawSystemProgram, stripProgram)+import Distribution.Simple.Utils   (warn)+import Distribution.System         (OS (..), buildOS)+import Distribution.Verbosity      (Verbosity)++import Control.Monad               (unless)+import System.FilePath             (takeBaseName)++runStrip :: Verbosity -> ProgramConfiguration -> FilePath -> [String] -> IO ()+runStrip verbosity progConf path args =+  case lookupProgram stripProgram progConf of+    Just strip -> rawSystemProgram verbosity strip (path:args)+    Nothing    -> unless (buildOS == Windows) $+                  -- Don't bother warning on windows, we don't expect them to+                  -- have the strip program anyway.+                  warn verbosity $ "Unable to strip executable or library '"+                                   ++ (takeBaseName path)+                                   ++ "' (missing the 'strip' program)"++stripExe :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()+stripExe verbosity conf path =+  runStrip verbosity conf path args+  where+    args = case buildOS of+       OSX -> ["-x"] -- By default, stripping the ghc binary on at least+                     -- some OS X installations causes:+                     --     HSbase-3.0.o: unknown symbol `_environ'"+                     -- The -x flag fixes that.+       _   -> []++stripLib :: Verbosity -> ProgramConfiguration -> FilePath -> IO ()+stripLib verbosity conf path = do+  runStrip verbosity conf path args+  where+    args = ["--strip-unneeded"]
cabal/Cabal/Distribution/Simple/Program/Types.hs view
@@ -17,18 +17,22 @@ module Distribution.Simple.Program.Types (     -- * Program and functions for constructing them     Program(..),+    ProgramSearchPath,+    ProgramSearchPathEntry(..),     simpleProgram,      -- * Configured program and related functions     ConfiguredProgram(..),     programPath,+    suppressOverrideArgs,     ProgArg,     ProgramLocation(..),     simpleConfiguredProgram,   ) where -import Distribution.Simple.Utils-         ( findProgramLocation )+import Distribution.Simple.Program.Find+         ( ProgramSearchPath, ProgramSearchPathEntry(..)+         , findProgramOnSearchPath ) import Distribution.Version          ( Version ) import Distribution.Verbosity@@ -43,19 +47,23 @@        -- | The simple name of the program, eg. ghc        programName :: String, -       -- | A function to search for the program if it's location was not-       -- specified by the user. Usually this will just be a-       programFindLocation :: Verbosity -> IO (Maybe FilePath),+       -- | A function to search for the program if its location was not+       -- specified by the user. Usually this will just be a call to+       -- 'findProgramOnSearchPath'.+       --+       -- It is supplied with the prevailing search path which will typically+       -- just be used as-is, but can be extended or ignored as needed.+       programFindLocation :: Verbosity -> ProgramSearchPath+                              -> IO (Maybe FilePath),         -- | Try to find the version of the program. For many programs this is        -- not possible or is not necessary so it's ok to return Nothing.        programFindVersion :: Verbosity -> FilePath -> IO (Maybe Version),         -- | A function to do any additional configuration after we have-       -- located the program (and perhaps identified its version). It is-       -- allowed to return additional flags that will be passed to the-       -- program on every invocation.-       programPostConf :: Verbosity -> ConfiguredProgram -> IO [ProgArg]+       -- located the program (and perhaps identified its version). For example+       -- it could add args, or environment vars.+       programPostConf :: Verbosity -> ConfiguredProgram -> IO ConfiguredProgram      }  type ProgArg = String@@ -83,6 +91,11 @@        -- all earlier flags.        programOverrideArgs :: [String], +       -- | Override environment variables for this program.+       -- These env vars will extend\/override the prevailing environment of+       -- the current to form the environment for the new process.+       programOverrideEnv :: [(String, Maybe String)],+        -- | Location of the program. eg. @\/usr\/bin\/ghc-6.4@        programLocation :: ProgramLocation      } deriving (Read, Show, Eq)@@ -101,6 +114,10 @@ programPath :: ConfiguredProgram -> FilePath programPath = locationPath . programLocation +-- | Suppress any extra arguments added by the user.+suppressOverrideArgs :: ConfiguredProgram -> ConfiguredProgram+suppressOverrideArgs prog = prog { programOverrideArgs = [] }+ -- | Make a simple named program. -- -- By default we'll just search for it in the path and not try to find the@@ -111,9 +128,9 @@ simpleProgram :: String -> Program simpleProgram name = Program {     programName         = name,-    programFindLocation = \v   -> findProgramLocation v name,+    programFindLocation = \v p -> findProgramOnSearchPath v p name,     programFindVersion  = \_ _ -> return Nothing,-    programPostConf     = \_ _ -> return []+    programPostConf     = \_ p -> return p   }  -- | Make a simple 'ConfiguredProgram'.@@ -126,5 +143,6 @@      programVersion      = Nothing,      programDefaultArgs  = [],      programOverrideArgs = [],+     programOverrideEnv  = [],      programLocation     = loc   }
cabal/Cabal/Distribution/Simple/Register.hs view
@@ -58,6 +58,7 @@     unregister,      initPackageDB,+    invokeHcPkg,     registerPackage,     generateRegistrationInfo,     inplaceInstalledPackageInfo,@@ -67,12 +68,15 @@  import Distribution.Simple.LocalBuildInfo          ( LocalBuildInfo(..), ComponentLocalBuildInfo(..)+         , ComponentName(..), getComponentLocalBuildInfo+         , LibraryName(..)          , InstallDirs(..), absoluteInstallDirs ) import Distribution.Simple.BuildPaths (haddockName) import qualified Distribution.Simple.GHC  as GHC import qualified Distribution.Simple.LHC  as LHC import qualified Distribution.Simple.Hugs as Hugs import qualified Distribution.Simple.UHC  as UHC+import qualified Distribution.Simple.HaskellSuite as HaskellSuite import Distribution.Simple.Compiler          ( compilerVersion, Compiler, CompilerFlavor(..), compilerFlavor          , PackageDBStack, registrationPackageDB )@@ -123,10 +127,9 @@ register :: PackageDescription -> LocalBuildInfo          -> RegisterFlags -- ^Install in the user's database?; verbose          -> IO ()-register pkg@PackageDescription { library       = Just lib  }-         lbi@LocalBuildInfo     { libraryConfig = Just clbi } regFlags+register pkg@PackageDescription { library       = Just lib  } lbi regFlags   = do-+    let clbi = getComponentLocalBuildInfo lbi CLibName     installedPkgInfo <- generateRegistrationInfo                            verbosity pkg lib lbi clbi inplace distPref @@ -212,8 +215,20 @@ initPackageDB verbosity comp conf dbPath =   case (compilerFlavor comp) of     GHC -> GHC.initPackageDB verbosity conf dbPath-    _   -> die "initPackageDB is not implemented for this compiler"+    HaskellSuite {} -> HaskellSuite.initPackageDB verbosity conf dbPath+    _   -> die "Distribution.Simple.Register.initPackageDB: \+               \not implemented for this compiler" +-- | Run @hc-pkg@ using a given package DB stack, directly forwarding the+-- provided command-line arguments to it.+invokeHcPkg :: Verbosity -> Compiler -> ProgramConfiguration -> PackageDBStack+                -> [String] -> IO ()+invokeHcPkg verbosity comp conf dbStack extraArgs =+    case (compilerFlavor comp) of+      GHC -> GHC.invokeHcPkg verbosity conf dbStack extraArgs+      _   -> die "Distribution.Simple.Register.invokeHcPkg: \+                 \not implemented for this compiler"+ registerPackage :: Verbosity                 -> InstalledPackageInfo                 -> PackageDescription@@ -233,6 +248,8 @@     UHC  -> UHC.registerPackage  verbosity installedPkgInfo pkg lbi inplace packageDbs     JHC  -> notice verbosity "Registering for jhc (nothing to do)"     NHC  -> notice verbosity "Registering for nhc98 (nothing to do)"+    HaskellSuite {} ->+      HaskellSuite.registerPackage verbosity installedPkgInfo pkg lbi inplace packageDbs     _    -> die "Registering is not implemented for this compiler"  @@ -293,7 +310,9 @@     IPI.libraryDirs        = if hasLibrary                                then libdir installDirs : extraLibDirs bi                                else                      extraLibDirs bi,-    IPI.hsLibraries        = [ "HS" ++ display (packageId pkg) | hasLibrary ],+    IPI.hsLibraries        = [ libname+                             | LibraryName libname <- componentLibraries clbi+                             , hasLibrary ],     IPI.extraLibraries     = extraLibs bi,     IPI.extraGHCiLibraries = [],     IPI.includeDirs        = absinc ++ adjustRelIncDirs relinc,
cabal/Cabal/Distribution/Simple/Setup.hs view
@@ -56,26 +56,32 @@ (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -} +{-# LANGUAGE CPP #-}+ module Distribution.Simple.Setup (    GlobalFlags(..),   emptyGlobalFlags,   defaultGlobalFlags,   globalCommand,   ConfigFlags(..),   emptyConfigFlags,   defaultConfigFlags,   configureCommand,+  configAbsolutePaths, readPackageDbList, showPackageDbList,   CopyFlags(..),     emptyCopyFlags,     defaultCopyFlags,     copyCommand,   InstallFlags(..),  emptyInstallFlags,  defaultInstallFlags,  installCommand,   HaddockFlags(..),  emptyHaddockFlags,  defaultHaddockFlags,  haddockCommand,   HscolourFlags(..), emptyHscolourFlags, defaultHscolourFlags, hscolourCommand,   BuildFlags(..),    emptyBuildFlags,    defaultBuildFlags,    buildCommand,   buildVerbose,+  ReplFlags(..),                         defaultReplFlags,     replCommand,   CleanFlags(..),    emptyCleanFlags,    defaultCleanFlags,    cleanCommand,   RegisterFlags(..), emptyRegisterFlags, defaultRegisterFlags, registerCommand,                                                                unregisterCommand,   SDistFlags(..),    emptySDistFlags,    defaultSDistFlags,    sdistCommand,   TestFlags(..),     emptyTestFlags,     defaultTestFlags,     testCommand,   TestShowDetails(..),-  BenchmarkFlags(..), emptyBenchmarkFlags, defaultBenchmarkFlags, benchmarkCommand,+  BenchmarkFlags(..), emptyBenchmarkFlags,+  defaultBenchmarkFlags, benchmarkCommand,   CopyDest(..),   configureArgs, configureOptions, configureCCompiler, configureLinker,   buildOptions, installDirsOptions,+  programConfigurationOptions, programConfigurationPaths',    defaultDistPref, @@ -85,7 +91,7 @@   fromFlagOrDefault,   flagToMaybe,   flagToList,-  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity ) where+  boolOpt, boolOpt', trueArg, falseArg, optionVerbosity, optionNumJobs ) where  import Distribution.Compiler () import Distribution.ReadE@@ -93,14 +99,17 @@          ( Text(..), display ) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp-import Distribution.Package ( Dependency(..) )+import Distribution.Package ( Dependency(..)+                            , PackageName+                            , InstalledPackageId ) import Distribution.PackageDescription          ( FlagName(..), FlagAssignment ) import Distribution.Simple.Command hiding (boolOpt, boolOpt') import qualified Distribution.Simple.Command as Command import Distribution.Simple.Compiler          ( CompilerFlavor(..), defaultCompilerFlavor, PackageDB(..)-         , OptimisationLevel(..), flagToOptimisationLevel )+         , OptimisationLevel(..), flagToOptimisationLevel+         , absolutePackageDBPath ) import Distribution.Simple.Utils          ( wrapLine, lowercase, intercalate ) import Distribution.Simple.Program (Program(..), ProgramConfiguration,@@ -114,6 +123,7 @@            PathTemplate, toPathTemplate, fromPathTemplate ) import Distribution.Verbosity +import Control.Monad (liftM) import Data.List   ( sort ) import Data.Char   ( isSpace, isAlpha ) import Data.Monoid ( Monoid(..) )@@ -152,7 +162,7 @@ instance Monoid (Flag a) where   mempty = NoFlag   _ `mappend` f@(Flag _) = f-  f `mappend` NoFlag    = f+  f `mappend` NoFlag     = f  instance Bounded a => Bounded (Flag a) where   minBound = toFlag minBound@@ -189,6 +199,9 @@ flagToList (Flag x) = [x] flagToList NoFlag   = [] +allFlags :: [Flag Bool] -> Flag Bool+allFlags flags = toFlag $ all (\f -> fromFlagOrDefault False f) flags+ -- ------------------------------------------------------------ -- * Global flags -- ------------------------------------------------------------@@ -261,23 +274,30 @@     -- because the type of configure is constrained by the UserHooks.     -- when we change UserHooks next we should pass the initial     -- ProgramConfiguration directly and not via ConfigFlags-    configPrograms      :: ProgramConfiguration, -- ^All programs that cabal may run+    configPrograms      :: ProgramConfiguration, -- ^All programs that cabal may+                                                 -- run      configProgramPaths  :: [(String, FilePath)], -- ^user specifed programs paths     configProgramArgs   :: [(String, [String])], -- ^user specifed programs args-    configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the compiler, sugh as GHC or Hugs.+    configProgramPathExtra :: [FilePath],        -- ^Extend the $PATH+    configHcFlavor      :: Flag CompilerFlavor, -- ^The \"flavor\" of the+                                                -- compiler, sugh as GHC or+                                                -- Hugs.     configHcPath        :: Flag FilePath, -- ^given compiler location     configHcPkg         :: Flag FilePath, -- ^given hc-pkg location     configVanillaLib    :: Flag Bool,     -- ^Enable vanilla library     configProfLib       :: Flag Bool,     -- ^Enable profiling in the library     configSharedLib     :: Flag Bool,     -- ^Build shared library-    configDynExe        :: Flag Bool,     -- ^Enable dynamic linking of the executables.-    configProfExe       :: Flag Bool,     -- ^Enable profiling in the executables.+    configDynExe        :: Flag Bool,     -- ^Enable dynamic linking of the+                                          -- executables.+    configProfExe       :: Flag Bool,     -- ^Enable profiling in the+                                          -- executables.     configConfigureArgs :: [String],      -- ^Extra arguments to @configure@     configOptimization  :: Flag OptimisationLevel,  -- ^Enable optimization.     configProgPrefix    :: Flag PathTemplate, -- ^Installed executable prefix.     configProgSuffix    :: Flag PathTemplate, -- ^Installed executable suffix.-    configInstallDirs   :: InstallDirs (Flag PathTemplate), -- ^Installation paths+    configInstallDirs   :: InstallDirs (Flag PathTemplate), -- ^Installation+                                                            -- paths     configScratchDir    :: Flag FilePath,     configExtraLibDirs  :: [FilePath],   -- ^ path to search for extra libraries     configExtraIncludeDirs :: [FilePath],   -- ^ path to search for header files@@ -289,22 +309,35 @@     configGHCiLib   :: Flag Bool,      -- ^Enable compiling library for GHCi     configSplitObjs :: Flag Bool,      -- ^Enable -split-objs with GHC     configStripExes :: Flag Bool,      -- ^Enable executable stripping+    configStripLibs :: Flag Bool,      -- ^Enable library stripping     configConstraints :: [Dependency], -- ^Additional constraints for-                                       -- dependencies+                                       -- dependencies.+    configDependencies :: [(PackageName, InstalledPackageId)],+      -- ^The packages depended on.     configConfigurationsFlags :: FlagAssignment,-    configTests :: Flag Bool,     -- ^Enable test suite compilation-    configBenchmarks :: Flag Bool,     -- ^Enable benchmark compilation-    configLibCoverage :: Flag Bool    -- ^ Enable test suite program coverage+    configTests               :: Flag Bool, -- ^Enable test suite compilation+    configBenchmarks          :: Flag Bool, -- ^Enable benchmark compilation+    configLibCoverage         :: Flag Bool,+      -- ^Enable test suite program coverage.+    configExactConfiguration  :: Flag Bool+      -- ^All direct dependencies and flags are provided on the command line by+      -- the user via the '--dependency' and '--flags' options.   }   deriving (Read,Show) +configAbsolutePaths :: ConfigFlags -> IO ConfigFlags+configAbsolutePaths f =+  (\v -> f { configPackageDBs = v })+  `liftM` mapM (maybe (return Nothing) (liftM Just . absolutePackageDBPath))+  (configPackageDBs f)+ defaultConfigFlags :: ProgramConfiguration -> ConfigFlags defaultConfigFlags progConf = emptyConfigFlags {     configPrograms     = progConf,     configHcFlavor     = maybe NoFlag Flag defaultCompilerFlavor,     configVanillaLib   = Flag True,     configProfLib      = Flag False,-    configSharedLib    = Flag False,+    configSharedLib    = NoFlag,     configDynExe       = Flag False,     configProfExe      = Flag False,     configOptimization = Flag NormalOptimisation,@@ -313,16 +346,24 @@     configDistPref     = Flag defaultDistPref,     configVerbosity    = Flag normal,     configUserInstall  = Flag False,           --TODO: reverse this+#if defined(mingw32_HOST_OS)+    -- See #1589.+    configGHCiLib      = Flag True,+#else     configGHCiLib      = Flag False,+#endif     configSplitObjs    = Flag False, -- takes longer, so turn off by default     configStripExes    = Flag True,-    configTests  = Flag False,+    configStripLibs    = Flag True,+    configTests        = Flag False,     configBenchmarks   = Flag False,-    configLibCoverage = Flag False+    configLibCoverage  = Flag False,+    configExactConfiguration = Flag False   }  configureCommand :: ProgramConfiguration -> CommandUI ConfigFlags-configureCommand progConf = makeCommand name shortDesc longDesc defaultFlags options+configureCommand progConf = makeCommand name shortDesc+                            longDesc defaultFlags options   where     name       = "configure"     shortDesc  = "Prepare to build the package."@@ -332,13 +373,15 @@          configureOptions showOrParseArgs       ++ programConfigurationPaths   progConf showOrParseArgs            configProgramPaths (\v fs -> fs { configProgramPaths = v })+      ++ programConfigurationOption progConf showOrParseArgs+           configProgramArgs (\v fs -> fs { configProgramArgs = v })       ++ programConfigurationOptions progConf showOrParseArgs            configProgramArgs (\v fs -> fs { configProgramArgs = v }) - configureOptions :: ShowOrParseArgs -> [OptionField ConfigFlags] configureOptions showOrParseArgs =-      [optionVerbosity configVerbosity (\v flags -> flags { configVerbosity = v })+      [optionVerbosity configVerbosity+       (\v flags -> flags { configVerbosity = v })       ,optionDistPref          configDistPref (\d flags -> flags { configDistPref = d })          showOrParseArgs@@ -350,8 +393,13 @@                     , (Flag JHC, ([] , ["jhc"]), "compile with JHC")                     , (Flag LHC, ([] , ["lhc"]), "compile with LHC")                     , (Flag Hugs,([] , ["hugs"]), "compile with Hugs")-                    , (Flag UHC, ([] , ["uhc"]), "compile with UHC")])+                    , (Flag UHC, ([] , ["uhc"]), "compile with UHC") +                    -- "haskell-suite" compiler id string will be replaced+                    -- by a more specific one during the configure stage+                    , (Flag (HaskellSuite "haskell-suite"), ([] , ["haskell-suite"]),+                        "compile with a haskell-suite compiler")])+       ,option "w" ["with-compiler"]          "give the path to a particular compiler"          configHcPath (\v flags -> flags { configHcPath = v })@@ -435,6 +483,11 @@          configStripExes (\v flags -> flags { configStripExes = v })          (boolOpt [] []) +      ,option "" ["library-stripping"]+         "strip libraries upon installation to reduce binary sizes"+         configStripLibs (\v flags -> flags { configStripLibs = v })+         (boolOpt [] [])+       ,option "" ["configure-option"]          "Extra option for configure"          configConfigureArgs (\v flags -> flags { configConfigureArgs = v })@@ -464,20 +517,42 @@          "A list of directories to search for external libraries"          configExtraLibDirs (\v flags -> flags {configExtraLibDirs = v})          (reqArg' "PATH" (\x -> [x]) id)++      ,option "" ["extra-prog-path"]+         "A list of directories to search for required programs (in addition to the normal search locations)"+         configProgramPathExtra (\v flags -> flags {configProgramPathExtra = v})+         (reqArg' "PATH" (\x -> [x]) id)+       ,option "" ["constraint"]          "A list of additional constraints on the dependencies."          configConstraints (\v flags -> flags { configConstraints = v})          (reqArg "DEPENDENCY"                  (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parse))                  (map (\x -> display x)))++      ,option "" ["dependency"]+         "A list of exact dependencies. E.g., --dependency=\"void=void-0.5.8-177d5cdf20962d0581fe2e4932a6c309\""+         configDependencies (\v flags -> flags { configDependencies = v})+         (reqArg "NAME=ID"+                 (readP_to_E (const "dependency expected") ((\x -> [x]) `fmap` parseDependency))+                 (map (\x -> display (fst x) ++ "=" ++ display (snd x))))+       ,option "" ["tests"]          "dependency checking and compilation for test suites listed in the package description file."          configTests (\v flags -> flags { configTests = v })          (boolOpt [] [])+       ,option "" ["library-coverage"]          "build library and test suites with Haskell Program Coverage enabled. (GHC only)"          configLibCoverage (\v flags -> flags { configLibCoverage = v })          (boolOpt [] [])++      ,option "" ["exact-configuration"]+         "All direct dependencies and flags are provided on the command line."+         configExactConfiguration+         (\v flags -> flags { configExactConfiguration = v })+         trueArg+       ,option "" ["benchmarks"]          "dependency checking and compilation for benchmarks listed in the package description file."          configBenchmarks (\v flags -> flags { configBenchmarks = v })@@ -493,20 +568,6 @@     showFlagList fs = [ if not set then '-':fname else fname                       | (FlagName fname, set) <- fs] -    readPackageDbList :: String -> [Maybe PackageDB]-    readPackageDbList "clear"  = [Nothing]-    readPackageDbList "global" = [Just GlobalPackageDB]-    readPackageDbList "user"   = [Just UserPackageDB]-    readPackageDbList other    = [Just (SpecificPackageDB other)]--    showPackageDbList :: [Maybe PackageDB] -> [String]-    showPackageDbList = map showPackageDb-      where-        showPackageDb Nothing                       = "clear"-        showPackageDb (Just GlobalPackageDB)        = "global"-        showPackageDb (Just UserPackageDB)          = "user"-        showPackageDb (Just (SpecificPackageDB db)) = db-     liftInstallDirs =       liftOption configInstallDirs (\v flags -> flags { configInstallDirs = v }) @@ -514,6 +575,28 @@       reqArgFlag title _sf _lf d         (fmap fromPathTemplate . get) (set . fmap toPathTemplate) +readPackageDbList :: String -> [Maybe PackageDB]+readPackageDbList "clear"  = [Nothing]+readPackageDbList "global" = [Just GlobalPackageDB]+readPackageDbList "user"   = [Just UserPackageDB]+readPackageDbList other    = [Just (SpecificPackageDB other)]++showPackageDbList :: [Maybe PackageDB] -> [String]+showPackageDbList = map showPackageDb+  where+    showPackageDb Nothing                       = "clear"+    showPackageDb (Just GlobalPackageDB)        = "global"+    showPackageDb (Just UserPackageDB)          = "user"+    showPackageDb (Just (SpecificPackageDB db)) = db+++parseDependency :: Parse.ReadP r (PackageName, InstalledPackageId)+parseDependency = do+  x <- parse+  _ <- Parse.char '='+  y <- parse+  return (x, y)+ installDirsOptions :: [OptionField (InstallDirs (Flag PathTemplate))] installDirsOptions =   [ option "" ["prefix"]@@ -565,6 +648,11 @@       "installation directory for haddock interfaces"       haddockdir (\v flags -> flags { haddockdir = v })       installDirArg++  , option "" ["sysconfdir"]+      "installation directory for configuration files"+      sysconfdir (\v flags -> flags { sysconfdir = v })+      installDirArg   ]   where     installDirArg _sf _lf d get set =@@ -579,6 +667,7 @@     configPrograms      = error "FIXME: remove configPrograms",     configProgramPaths  = mempty,     configProgramArgs   = mempty,+    configProgramPathExtra = mempty,     configHcFlavor      = mempty,     configHcPath        = mempty,     configHcPkg         = mempty,@@ -600,18 +689,22 @@     configGHCiLib       = mempty,     configSplitObjs     = mempty,     configStripExes     = mempty,+    configStripLibs     = mempty,     configExtraLibDirs  = mempty,     configConstraints   = mempty,+    configDependencies  = mempty,     configExtraIncludeDirs    = mempty,     configConfigurationsFlags = mempty,-    configTests   = mempty,-    configLibCoverage = mempty,-    configBenchmarks    = mempty+    configTests               = mempty,+    configLibCoverage         = mempty,+    configExactConfiguration  = mempty,+    configBenchmarks          = mempty   }   mappend a b =  ConfigFlags {     configPrograms      = configPrograms b,     configProgramPaths  = combine configProgramPaths,     configProgramArgs   = combine configProgramArgs,+    configProgramPathExtra = combine configProgramPathExtra,     configHcFlavor      = combine configHcFlavor,     configHcPath        = combine configHcPath,     configHcPkg         = combine configHcPkg,@@ -633,13 +726,16 @@     configGHCiLib       = combine configGHCiLib,     configSplitObjs     = combine configSplitObjs,     configStripExes     = combine configStripExes,+    configStripLibs     = combine configStripLibs,     configExtraLibDirs  = combine configExtraLibDirs,     configConstraints   = combine configConstraints,+    configDependencies  = combine configDependencies,     configExtraIncludeDirs    = combine configExtraIncludeDirs,     configConfigurationsFlags = combine configConfigurationsFlags,-    configTests = combine configTests,-    configLibCoverage = combine configLibCoverage,-    configBenchmarks    = combine configBenchmarks+    configTests               = combine configTests,+    configLibCoverage         = combine configLibCoverage,+    configExactConfiguration  = combine configExactConfiguration,+    configBenchmarks          = combine configBenchmarks   }     where combine field = field a `mappend` field b @@ -782,19 +878,21 @@  -- | Flags to @sdist@: (snapshot, verbosity) data SDistFlags = SDistFlags {-    sDistSnapshot  :: Flag Bool,-    sDistDirectory :: Flag FilePath,-    sDistDistPref  :: Flag FilePath,-    sDistVerbosity :: Flag Verbosity+    sDistSnapshot    :: Flag Bool,+    sDistDirectory   :: Flag FilePath,+    sDistDistPref    :: Flag FilePath,+    sDistListSources :: Flag FilePath,+    sDistVerbosity   :: Flag Verbosity   }   deriving Show  defaultSDistFlags :: SDistFlags defaultSDistFlags = SDistFlags {-    sDistSnapshot  = Flag False,-    sDistDirectory = mempty,-    sDistDistPref  = Flag defaultDistPref,-    sDistVerbosity = Flag normal+    sDistSnapshot    = Flag False,+    sDistDirectory   = mempty,+    sDistDistPref    = Flag defaultDistPref,+    sDistListSources = mempty,+    sDistVerbosity   = Flag normal   }  sdistCommand :: CommandUI SDistFlags@@ -809,13 +907,19 @@          sDistDistPref (\d flags -> flags { sDistDistPref = d })          showOrParseArgs +     ,option "" ["list-sources"]+         "Just write a list of the package's sources to a file"+         sDistListSources (\v flags -> flags { sDistListSources = v })+         (reqArgFlag "FILE")+       ,option "" ["snapshot"]          "Produce a snapshot source distribution"          sDistSnapshot (\v flags -> flags { sDistSnapshot = v })          trueArg        ,option "" ["output-directory"]-         "Generate a source distribution in the given directory"+       ("Generate a source distribution in the given directory, "+        ++ "without creating a tarball")          sDistDirectory (\v flags -> flags { sDistDirectory = v })          (reqArgFlag "DIR")       ]@@ -825,16 +929,18 @@  instance Monoid SDistFlags where   mempty = SDistFlags {-    sDistSnapshot  = mempty,-    sDistDirectory = mempty,-    sDistDistPref  = mempty,-    sDistVerbosity = mempty+    sDistSnapshot    = mempty,+    sDistDirectory   = mempty,+    sDistDistPref    = mempty,+    sDistListSources = mempty,+    sDistVerbosity   = mempty   }   mappend a b = SDistFlags {-    sDistSnapshot  = combine sDistSnapshot,-    sDistDirectory = combine sDistDirectory,-    sDistDistPref  = combine sDistDistPref,-    sDistVerbosity = combine sDistVerbosity+    sDistSnapshot    = combine sDistSnapshot,+    sDistDirectory   = combine sDistDirectory,+    sDistDistPref    = combine sDistDistPref,+    sDistListSources = combine sDistListSources,+    sDistVerbosity   = combine sDistVerbosity   }     where combine field = field a `mappend` field b @@ -865,7 +971,8 @@   }  registerCommand :: CommandUI RegisterFlags-registerCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+registerCommand = makeCommand name shortDesc longDesc+                  defaultRegisterFlags options   where     name       = "register"     shortDesc  = "Register this package with the compiler."@@ -900,7 +1007,8 @@       ]  unregisterCommand :: CommandUI RegisterFlags-unregisterCommand = makeCommand name shortDesc longDesc defaultRegisterFlags options+unregisterCommand = makeCommand name shortDesc+                    longDesc defaultRegisterFlags options   where     name       = "unregister"     shortDesc  = "Unregister this package with the compiler."@@ -953,6 +1061,8 @@ data HscolourFlags = HscolourFlags {     hscolourCSS         :: Flag FilePath,     hscolourExecutables :: Flag Bool,+    hscolourTestSuites  :: Flag Bool,+    hscolourBenchmarks  :: Flag Bool,     hscolourDistPref    :: Flag FilePath,     hscolourVerbosity   :: Flag Verbosity   }@@ -965,6 +1075,8 @@ defaultHscolourFlags = HscolourFlags {     hscolourCSS         = NoFlag,     hscolourExecutables = Flag False,+    hscolourTestSuites  = Flag False,+    hscolourBenchmarks  = Flag False,     hscolourDistPref    = Flag defaultDistPref,     hscolourVerbosity   = Flag normal   }@@ -973,25 +1085,31 @@   mempty = HscolourFlags {     hscolourCSS         = mempty,     hscolourExecutables = mempty,+    hscolourTestSuites  = mempty,+    hscolourBenchmarks  = mempty,     hscolourDistPref    = mempty,     hscolourVerbosity   = mempty   }   mappend a b = HscolourFlags {     hscolourCSS         = combine hscolourCSS,     hscolourExecutables = combine hscolourExecutables,+    hscolourTestSuites  = combine hscolourTestSuites,+    hscolourBenchmarks  = combine hscolourBenchmarks,     hscolourDistPref    = combine hscolourDistPref,     hscolourVerbosity   = combine hscolourVerbosity   }     where combine field = field a `mappend` field b  hscolourCommand :: CommandUI HscolourFlags-hscolourCommand = makeCommand name shortDesc longDesc defaultHscolourFlags options+hscolourCommand = makeCommand name shortDesc longDesc+                  defaultHscolourFlags options   where     name       = "hscolour"     shortDesc  = "Generate HsColour colourised code, in HTML format."     longDesc   = Just (\_ -> "Requires hscolour.\n")     options showOrParseArgs =-      [optionVerbosity hscolourVerbosity (\v flags -> flags { hscolourVerbosity = v })+      [optionVerbosity hscolourVerbosity+       (\v flags -> flags { hscolourVerbosity = v })       ,optionDistPref          hscolourDistPref (\d flags -> flags { hscolourDistPref = d })          showOrParseArgs@@ -1001,6 +1119,26 @@          hscolourExecutables (\v flags -> flags { hscolourExecutables = v })          trueArg +      ,option "" ["tests"]+         "Run hscolour for Test Suite targets"+         hscolourTestSuites (\v flags -> flags { hscolourTestSuites = v })+         trueArg++      ,option "" ["benchmarks"]+         "Run hscolour for Benchmark targets"+         hscolourBenchmarks (\v flags -> flags { hscolourBenchmarks = v })+         trueArg++      ,option "" ["all"]+         "Run hscolour for all targets"+         (\f -> allFlags [ hscolourExecutables f+                         , hscolourTestSuites  f+                         , hscolourBenchmarks  f])+         (\v flags -> flags { hscolourExecutables = v+                            , hscolourTestSuites  = v+                            , hscolourBenchmarks  = v })+         trueArg+       ,option "" ["css"]          "Use a cascading style sheet"          hscolourCSS (\v flags -> flags { hscolourCSS = v })@@ -1018,12 +1156,15 @@     haddockHtml         :: Flag Bool,     haddockHtmlLocation :: Flag String,     haddockExecutables  :: Flag Bool,+    haddockTestSuites   :: Flag Bool,+    haddockBenchmarks   :: Flag Bool,     haddockInternal     :: Flag Bool,     haddockCss          :: Flag FilePath,     haddockHscolour     :: Flag Bool,     haddockHscolourCss  :: Flag FilePath,     haddockContents     :: Flag PathTemplate,     haddockDistPref     :: Flag FilePath,+    haddockKeepTempFiles:: Flag Bool,     haddockVerbosity    :: Flag Verbosity   }   deriving Show@@ -1036,12 +1177,15 @@     haddockHtml         = Flag False,     haddockHtmlLocation = NoFlag,     haddockExecutables  = Flag False,+    haddockTestSuites   = Flag False,+    haddockBenchmarks   = Flag False,     haddockInternal     = Flag False,     haddockCss          = NoFlag,     haddockHscolour     = Flag False,     haddockHscolourCss  = NoFlag,     haddockContents     = NoFlag,     haddockDistPref     = Flag defaultDistPref,+    haddockKeepTempFiles= Flag False,     haddockVerbosity    = Flag normal   } @@ -1052,11 +1196,17 @@     shortDesc  = "Generate Haddock HTML documentation."     longDesc   = Just $ \_ -> "Requires the program haddock, either version 0.x or 2.x.\n"     options showOrParseArgs =-      [optionVerbosity haddockVerbosity (\v flags -> flags { haddockVerbosity = v })+      [optionVerbosity haddockVerbosity+       (\v flags -> flags { haddockVerbosity = v })       ,optionDistPref          haddockDistPref (\d flags -> flags { haddockDistPref = d })          showOrParseArgs +      ,option "" ["keep-temp-files"]+         "Keep temporary files"+         haddockKeepTempFiles (\b flags -> flags { haddockKeepTempFiles = b })+         trueArg+       ,option "" ["hoogle"]          "Generate a hoogle database"          haddockHoogle (\v flags -> flags { haddockHoogle = v })@@ -1077,6 +1227,26 @@          haddockExecutables (\v flags -> flags { haddockExecutables = v })          trueArg +      ,option "" ["tests"]+         "Run haddock for Test Suite targets"+         haddockTestSuites (\v flags -> flags { haddockTestSuites = v })+         trueArg++      ,option "" ["benchmarks"]+         "Run haddock for Benchmark targets"+         haddockBenchmarks (\v flags -> flags { haddockBenchmarks = v })+         trueArg++      ,option "" ["all"]+         "Run haddock for all targets"+         (\f -> allFlags [ haddockExecutables f+                         , haddockTestSuites  f+                         , haddockBenchmarks  f])+         (\v flags -> flags { haddockExecutables = v+                            , haddockTestSuites  = v+                            , haddockBenchmarks  = v })+         trueArg+       ,option "" ["internal"]          "Run haddock for internal modules and include all symbols"          haddockInternal (\v flags -> flags { haddockInternal = v })@@ -1096,7 +1266,7 @@          "Use PATH as the HsColour stylesheet"          haddockHscolourCss (\v flags -> flags { haddockHscolourCss = v })          (reqArgFlag "PATH")-      +       ,option "" ["contents-location"]          "Bake URL in as the location for the contents page"          haddockContents (\v flags -> flags { haddockContents = v })@@ -1106,6 +1276,8 @@       ]       ++ programConfigurationPaths   progConf ParseArgs              haddockProgramPaths (\v flags -> flags { haddockProgramPaths = v})+      ++ programConfigurationOption  progConf showOrParseArgs+             haddockProgramArgs (\v fs -> fs { haddockProgramArgs = v })       ++ programConfigurationOptions progConf ParseArgs              haddockProgramArgs  (\v flags -> flags { haddockProgramArgs = v})     progConf = addKnownProgram haddockProgram@@ -1123,12 +1295,15 @@     haddockHtml         = mempty,     haddockHtmlLocation = mempty,     haddockExecutables  = mempty,+    haddockTestSuites   = mempty,+    haddockBenchmarks   = mempty,     haddockInternal     = mempty,     haddockCss          = mempty,     haddockHscolour     = mempty,     haddockHscolourCss  = mempty,     haddockContents     = mempty,     haddockDistPref     = mempty,+    haddockKeepTempFiles= mempty,     haddockVerbosity    = mempty   }   mappend a b = HaddockFlags {@@ -1138,12 +1313,15 @@     haddockHtml         = combine haddockHoogle,     haddockHtmlLocation = combine haddockHtmlLocation,     haddockExecutables  = combine haddockExecutables,+    haddockTestSuites   = combine haddockTestSuites,+    haddockBenchmarks   = combine haddockBenchmarks,     haddockInternal     = combine haddockInternal,     haddockCss          = combine haddockCss,     haddockHscolour     = combine haddockHscolour,     haddockHscolourCss  = combine haddockHscolourCss,     haddockContents     = combine haddockContents,     haddockDistPref     = combine haddockDistPref,+    haddockKeepTempFiles= combine haddockKeepTempFiles,     haddockVerbosity    = combine haddockVerbosity   }     where combine field = field a `mappend` field b@@ -1208,7 +1386,11 @@     buildProgramPaths :: [(String, FilePath)],     buildProgramArgs :: [(String, [String])],     buildDistPref    :: Flag FilePath,-    buildVerbosity   :: Flag Verbosity+    buildVerbosity   :: Flag Verbosity,+    buildNumJobs     :: Flag (Maybe Int),+    -- TODO: this one should not be here, it's just that the silly+    -- UserHooks stop us from passing extra info in other ways+    buildArgs :: [String]   }   deriving Show @@ -1221,7 +1403,9 @@     buildProgramPaths = mempty,     buildProgramArgs = [],     buildDistPref    = Flag defaultDistPref,-    buildVerbosity   = Flag normal+    buildVerbosity   = Flag normal,+    buildNumJobs     = mempty,+    buildArgs        = []   }  buildCommand :: ProgramConfiguration -> CommandUI BuildFlags@@ -1229,22 +1413,44 @@                         defaultBuildFlags (buildOptions progConf)   where     name       = "build"-    shortDesc  = "Make this package ready for installation."-    longDesc   = Nothing+    shortDesc  = "Compile all targets or specific targets."+    longDesc   = Just $ \pname ->+       "Examples:\n"+        ++ "  " ++ pname ++ " build           "+        ++ "    All the components in the package\n"+        ++ "  " ++ pname ++ " build foo       "+        ++ "    A component (i.e. lib, exe, test suite)\n"+--TODO: re-enable once we have support for module/file targets+--        ++ "  " ++ pname ++ " build Foo.Bar   "+--        ++ "    A module\n"+--        ++ "  " ++ pname ++ " build Foo/Bar.hs"+--        ++ "    A file\n\n"+--        ++ "If a target is ambigious it can be qualified with the component "+--        ++ "name, e.g.\n"+--        ++ "  " ++ pname ++ " build foo:Foo.Bar\n"+--        ++ "  " ++ pname ++ " build testsuite1:Foo/Bar.hs\n"  buildOptions :: ProgramConfiguration -> ShowOrParseArgs                 -> [OptionField BuildFlags] buildOptions progConf showOrParseArgs =-  optionVerbosity buildVerbosity (\v flags -> flags { buildVerbosity = v })-  : optionDistPref-  buildDistPref (\d flags -> flags { buildDistPref = d })-  showOrParseArgs+  [ optionVerbosity+      buildVerbosity (\v flags -> flags { buildVerbosity = v }) -  : programConfigurationPaths   progConf showOrParseArgs-  buildProgramPaths (\v flags -> flags { buildProgramPaths = v})+  , optionDistPref+      buildDistPref (\d flags -> flags { buildDistPref = d }) showOrParseArgs +  , optionNumJobs+      buildNumJobs (\v flags -> flags { buildNumJobs = v })+  ]++  ++ programConfigurationPaths progConf showOrParseArgs+       buildProgramPaths (\v flags -> flags { buildProgramPaths = v})++  ++ programConfigurationOption progConf showOrParseArgs+       buildProgramArgs (\v fs -> fs { buildProgramArgs = v })+   ++ programConfigurationOptions progConf showOrParseArgs-  buildProgramArgs (\v flags -> flags { buildProgramArgs = v})+       buildProgramArgs (\v flags -> flags { buildProgramArgs = v})  emptyBuildFlags :: BuildFlags emptyBuildFlags = mempty@@ -1254,17 +1460,107 @@     buildProgramPaths = mempty,     buildProgramArgs = mempty,     buildVerbosity   = mempty,-    buildDistPref    = mempty+    buildDistPref    = mempty,+    buildNumJobs     = mempty,+    buildArgs        = mempty   }   mappend a b = BuildFlags {     buildProgramPaths = combine buildProgramPaths,     buildProgramArgs = combine buildProgramArgs,     buildVerbosity   = combine buildVerbosity,-    buildDistPref    = combine buildDistPref+    buildDistPref    = combine buildDistPref,+    buildNumJobs     = combine buildNumJobs,+    buildArgs        = combine buildArgs   }     where combine field = field a `mappend` field b  -- ------------------------------------------------------------+-- * Repl Flags+-- ------------------------------------------------------------++data ReplFlags = ReplFlags {+    replProgramPaths :: [(String, FilePath)],+    replProgramArgs :: [(String, [String])],+    replDistPref    :: Flag FilePath,+    replVerbosity   :: Flag Verbosity,+    replReload      :: Flag Bool+  }+  deriving Show++defaultReplFlags :: ReplFlags+defaultReplFlags  = ReplFlags {+    replProgramPaths = mempty,+    replProgramArgs = [],+    replDistPref    = Flag defaultDistPref,+    replVerbosity   = Flag normal,+    replReload      = Flag False+  }++instance Monoid ReplFlags where+  mempty = ReplFlags {+    replProgramPaths = mempty,+    replProgramArgs = mempty,+    replVerbosity   = mempty,+    replDistPref    = mempty,+    replReload      = mempty+  }+  mappend a b = ReplFlags {+    replProgramPaths = combine replProgramPaths,+    replProgramArgs = combine replProgramArgs,+    replVerbosity   = combine replVerbosity,+    replDistPref    = combine replDistPref,+    replReload      = combine replReload+  }+    where combine field = field a `mappend` field b++replCommand :: ProgramConfiguration -> CommandUI ReplFlags+replCommand progConf = CommandUI {+    commandName         = "repl",+    commandSynopsis     = "Open an interpreter session for the given target.",+    commandDescription  = Just $ \pname ->+       "Examples:\n"+        ++ "  " ++ pname ++ " repl           "+        ++ "    The first component in the package\n"+        ++ "  " ++ pname ++ " repl foo       "+        ++ "    A named component (i.e. lib, exe, test suite)\n",+--TODO: re-enable once we have support for module/file targets+--        ++ "  " ++ pname ++ " repl Foo.Bar   "+--        ++ "    A module\n"+--        ++ "  " ++ pname ++ " repl Foo/Bar.hs"+--        ++ "    A file\n\n"+--        ++ "If a target is ambigious it can be qualified with the component "+--        ++ "name, e.g.\n"+--        ++ "  " ++ pname ++ " repl foo:Foo.Bar\n"+--        ++ "  " ++ pname ++ " repl testsuite1:Foo/Bar.hs\n"++    commandUsage =  \pname -> "Usage: " ++ pname ++ " repl [FILENAME] [FLAGS]\n",+    commandDefaultFlags = defaultReplFlags,+    commandOptions = \showOrParseArgs ->+      optionVerbosity replVerbosity (\v flags -> flags { replVerbosity = v })+      : optionDistPref+          replDistPref (\d flags -> flags { replDistPref = d })+          showOrParseArgs++      : programConfigurationPaths   progConf showOrParseArgs+          replProgramPaths (\v flags -> flags { replProgramPaths = v})++     ++ programConfigurationOption progConf showOrParseArgs+          replProgramArgs (\v flags -> flags { replProgramArgs = v})++     ++ programConfigurationOptions progConf showOrParseArgs+          replProgramArgs (\v flags -> flags { replProgramArgs = v})++     ++ case showOrParseArgs of+          ParseArgs ->+            [ option "" ["reload"]+              "Used from within an interpreter to update files."+              replReload (\v flags -> flags { replReload = v })+              trueArg+            ]+          _ -> []+    }++-- ------------------------------------------------------------ -- * Test flags -- ------------------------------------------------------------ @@ -1291,28 +1587,29 @@     mappend a b = if a < b then b else a  data TestFlags = TestFlags {-    testDistPref  :: Flag FilePath,-    testVerbosity :: Flag Verbosity,-    testHumanLog :: Flag PathTemplate,-    testMachineLog :: Flag PathTemplate,+    testDistPref    :: Flag FilePath,+    testVerbosity   :: Flag Verbosity,+    testHumanLog    :: Flag PathTemplate,+    testMachineLog  :: Flag PathTemplate,     testShowDetails :: Flag TestShowDetails,-    testKeepTix :: Flag Bool,-    --TODO: eliminate the test list and pass it directly as positional args to the testHook-    testList :: Flag [String],+    testKeepTix     :: Flag Bool,+    --TODO: eliminate the test list and pass it directly as positional args to+    --the testHook+    testList        :: Flag [String],     -- TODO: think about if/how options are passed to test exes-    testOptions :: [PathTemplate]+    testOptions     :: [PathTemplate]   }  defaultTestFlags :: TestFlags defaultTestFlags  = TestFlags {-    testDistPref  = Flag defaultDistPref,-    testVerbosity = Flag normal,-    testHumanLog = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",-    testMachineLog = toFlag $ toPathTemplate $ "$pkgid.log",+    testDistPref    = Flag defaultDistPref,+    testVerbosity   = Flag normal,+    testHumanLog    = toFlag $ toPathTemplate $ "$pkgid-$test-suite.log",+    testMachineLog  = toFlag $ toPathTemplate $ "$pkgid.log",     testShowDetails = toFlag Failures,-    testKeepTix = toFlag False,-    testList = Flag [],-    testOptions = []+    testKeepTix     = toFlag False,+    testList        = Flag [],+    testOptions     = []   }  testCommand :: CommandUI TestFlags@@ -1377,24 +1674,24 @@  instance Monoid TestFlags where   mempty = TestFlags {-    testDistPref  = mempty,-    testVerbosity = mempty,-    testHumanLog = mempty,-    testMachineLog = mempty,+    testDistPref    = mempty,+    testVerbosity   = mempty,+    testHumanLog    = mempty,+    testMachineLog  = mempty,     testShowDetails = mempty,-    testKeepTix = mempty,-    testList = mempty,-    testOptions = mempty+    testKeepTix     = mempty,+    testList        = mempty,+    testOptions     = mempty   }   mappend a b = TestFlags {-    testDistPref  = combine testDistPref,-    testVerbosity = combine testVerbosity,-    testHumanLog = combine testHumanLog,-    testMachineLog = combine testMachineLog,+    testDistPref    = combine testDistPref,+    testVerbosity   = combine testVerbosity,+    testHumanLog    = combine testHumanLog,+    testMachineLog  = combine testMachineLog,     testShowDetails = combine testShowDetails,-    testKeepTix = combine testKeepTix,-    testList = combine testList,-    testOptions = combine testOptions+    testKeepTix     = combine testKeepTix,+    testList        = combine testList,+    testOptions     = combine testOptions   }     where combine field = field a `mappend` field b @@ -1405,24 +1702,26 @@ data BenchmarkFlags = BenchmarkFlags {     benchmarkDistPref  :: Flag FilePath,     benchmarkVerbosity :: Flag Verbosity,-    benchmarkOptions :: [PathTemplate]+    benchmarkOptions   :: [PathTemplate]   }  defaultBenchmarkFlags :: BenchmarkFlags defaultBenchmarkFlags  = BenchmarkFlags {     benchmarkDistPref  = Flag defaultDistPref,     benchmarkVerbosity = Flag normal,-    benchmarkOptions = []+    benchmarkOptions   = []   }  benchmarkCommand :: CommandUI BenchmarkFlags-benchmarkCommand = makeCommand name shortDesc longDesc defaultBenchmarkFlags options+benchmarkCommand = makeCommand name shortDesc+                   longDesc defaultBenchmarkFlags options   where     name       = "bench"     shortDesc  = "Run the benchmark, if any (configure with UserHooks)."     longDesc   = Nothing     options showOrParseArgs =-      [ optionVerbosity benchmarkVerbosity (\v flags -> flags { benchmarkVerbosity = v })+      [ optionVerbosity benchmarkVerbosity+        (\v flags -> flags { benchmarkVerbosity = v })       , optionDistPref             benchmarkDistPref (\d flags -> flags { benchmarkDistPref = d })             showOrParseArgs@@ -1450,12 +1749,12 @@   mempty = BenchmarkFlags {     benchmarkDistPref  = mempty,     benchmarkVerbosity = mempty,-    benchmarkOptions = mempty+    benchmarkOptions   = mempty   }   mappend a b = BenchmarkFlags {     benchmarkDistPref  = combine benchmarkDistPref,     benchmarkVerbosity = combine benchmarkVerbosity,-    benchmarkOptions = combine benchmarkOptions+    benchmarkOptions   = combine benchmarkOptions   }     where combine field = field a `mappend` field b @@ -1471,6 +1770,8 @@      [ programName prog | (prog, _) <- knownPrograms progConf ]   ++ "\n" +-- | For each known program @PROG@ in 'progConf', produce a @with-PROG@+-- 'OptionField'. programConfigurationPaths   :: ProgramConfiguration   -> ShowOrParseArgs@@ -1478,54 +1779,85 @@   -> ([(String, FilePath)] -> (flags -> flags))   -> [OptionField flags] programConfigurationPaths progConf showOrParseArgs get set =+  programConfigurationPaths' ("with-" ++) progConf showOrParseArgs get set++-- | Like 'programConfigurationPaths', but allows to customise the option name.+programConfigurationPaths'+  :: (String -> String)+  -> ProgramConfiguration+  -> ShowOrParseArgs+  -> (flags -> [(String, FilePath)])+  -> ([(String, FilePath)] -> (flags -> flags))+  -> [OptionField flags]+programConfigurationPaths' mkName progConf showOrParseArgs get set =   case showOrParseArgs of     -- we don't want a verbose help text list so we just show a generic one:     ShowArgs  -> [withProgramPath "PROG"]-    ParseArgs -> map (withProgramPath . programName . fst) (knownPrograms progConf)+    ParseArgs -> map (withProgramPath . programName . fst)+                 (knownPrograms progConf)   where     withProgramPath prog =-      option "" ["with-" ++ prog]+      option "" [mkName prog]         ("give the path to " ++ prog)         get set         (reqArg' "PATH" (\path -> [(prog, path)])           (\progPaths -> [ path | (prog', path) <- progPaths, prog==prog' ])) -programConfigurationOptions+-- | For each known program @PROG@ in 'progConf', produce a @PROG-option@+-- 'OptionField'.+programConfigurationOption   :: ProgramConfiguration   -> ShowOrParseArgs   -> (flags -> [(String, [String])])   -> ([(String, [String])] -> (flags -> flags))   -> [OptionField flags]-programConfigurationOptions progConf showOrParseArgs get set =+programConfigurationOption progConf showOrParseArgs get set =   case showOrParseArgs of     -- we don't want a verbose help text list so we just show a generic one:-    ShowArgs  -> [programOptions  "PROG", programOption   "PROG"]-    ParseArgs -> map (programOptions . programName . fst) (knownPrograms progConf)-              ++ map (programOption  . programName . fst) (knownPrograms progConf)+    ShowArgs  -> [programOption "PROG"]+    ParseArgs -> map (programOption  . programName . fst)+                 (knownPrograms progConf)   where-    programOptions prog =-      option "" [prog ++ "-options"]-        ("give extra options to " ++ prog)-        get set-        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))-     programOption prog =       option "" [prog ++ "-option"]         ("give an extra option to " ++ prog ++          " (no need to quote options containing spaces)")         get set         (reqArg' "OPT" (\arg -> [(prog, [arg])])-           (\progArgs -> concat [ args | (prog', args) <- progArgs, prog==prog' ]))+           (\progArgs -> concat [ args+                                | (prog', args) <- progArgs, prog==prog' ])) +-- | For each known program @PROG@ in 'progConf', produce a @PROG-options@+-- 'OptionField'.+programConfigurationOptions+  :: ProgramConfiguration+  -> ShowOrParseArgs+  -> (flags -> [(String, [String])])+  -> ([(String, [String])] -> (flags -> flags))+  -> [OptionField flags]+programConfigurationOptions progConf showOrParseArgs get set =+  case showOrParseArgs of+    -- we don't want a verbose help text list so we just show a generic one:+    ShowArgs  -> [programOptions  "PROG"]+    ParseArgs -> map (programOptions . programName . fst)+                 (knownPrograms progConf)+  where+    programOptions prog =+      option "" [prog ++ "-options"]+        ("give extra options to " ++ prog)+        get set+        (reqArg' "OPTS" (\args -> [(prog, splitArgs args)]) (const []))  -- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------ -boolOpt :: SFlags -> SFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt :: SFlags -> SFlags+           -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a boolOpt  = Command.boolOpt  flagToMaybe Flag -boolOpt' :: OptFlags -> OptFlags -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a+boolOpt' :: OptFlags -> OptFlags+            -> MkOptDescr (a -> Flag Bool) (Flag Bool -> a -> a) a boolOpt' = Command.boolOpt' flagToMaybe Flag  trueArg, falseArg :: SFlags -> LFlags -> Description -> (b -> Flag Bool) ->@@ -1562,6 +1894,28 @@                 (Flag verbose) -- default Value if no n is given                 (fmap (Just . showForCabal) . flagToList)) +optionNumJobs :: (flags -> Flag (Maybe Int))+              -> (Flag (Maybe Int) -> flags -> flags)+              -> OptionField flags+optionNumJobs get set =+  option "j" ["jobs"]+    "Run NUM jobs simultaneously (or '$ncpus' if no NUM is given)."+    get set+    (optArg "NUM" (fmap Flag numJobsParser)+                  (Flag Nothing)+                  (map (Just . maybe "$ncpus" show) . flagToList))+  where+    numJobsParser :: ReadE (Maybe Int)+    numJobsParser = ReadE $ \s ->+      case s of+        "$ncpus" -> Right Nothing+        _        -> case reads s of+          [(n, "")]+            | n < 1     -> Left "The number of jobs should be 1 or more."+            | n > 64    -> Left "You probably don't want that many jobs."+            | otherwise -> Right (Just n)+          _             -> Left "The jobs value should be a number or '$ncpus'"+ -- ------------------------------------------------------------ -- * Other Utils -- ------------------------------------------------------------@@ -1577,6 +1931,7 @@  ++ optFlag' "libdir"      libdir  ++ optFlag' "libexecdir"  libexecdir  ++ optFlag' "datadir"     datadir+ ++ optFlag' "sysconfdir"  sysconfdir  ++ configConfigureArgs flags   where         hc_flag = case (configHcFlavor flags, configHcPath flags) of@@ -1594,13 +1949,15 @@                                                  . config_field                                                  . configInstallDirs) -configureCCompiler :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String])+configureCCompiler :: Verbosity -> ProgramConfiguration+                      -> IO (FilePath, [String]) configureCCompiler verbosity lbi = configureProg verbosity lbi gccProgram  configureLinker :: Verbosity -> ProgramConfiguration -> IO (FilePath, [String]) configureLinker verbosity lbi = configureProg verbosity lbi ldProgram -configureProg :: Verbosity -> ProgramConfiguration -> Program -> IO (FilePath, [String])+configureProg :: Verbosity -> ProgramConfiguration -> Program+                 -> IO (FilePath, [String]) configureProg verbosity programConfig prog = do     (p, _) <- requireProgram verbosity prog programConfig     let pInv = programInvocation p []
cabal/Cabal/Distribution/Simple/SrcDist.hs view
@@ -64,6 +64,10 @@   snapshotPackage,   snapshotVersion,   dateToSnapshotNumber,++  -- * Extracting the source files+  listPackageSources+   )  where  import Distribution.PackageDescription@@ -80,67 +84,79 @@          ( Version(versionBranch) ) import Distribution.Simple.Utils          ( createDirectoryIfMissingVerbose, withUTF8FileContents, writeUTF8File-         , installOrdinaryFile, installOrdinaryFiles, setFileExecutable+         , installOrdinaryFiles, installMaybeExecutableFiles          , findFile, findFileWithExtension, matchFileGlob          , withTempDirectory, defaultPackageDesc          , die, warn, notice, setupMessage )-import Distribution.Simple.Setup (SDistFlags(..), fromFlag, flagToMaybe)-import Distribution.Simple.PreProcess (PPSuffixHandler, ppSuffixes, preprocessComponent)-import Distribution.Simple.LocalBuildInfo ( LocalBuildInfo(..), withComponentsLBI )+import Distribution.Simple.Setup ( Flag(..), SDistFlags(..)+                                 , fromFlag, flagToMaybe)+import Distribution.Simple.PreProcess ( PPSuffixHandler, ppSuffixes+                                      , preprocessComponent )+import Distribution.Simple.LocalBuildInfo+         ( LocalBuildInfo(..), withAllComponentsInBuildOrder ) import Distribution.Simple.BuildPaths ( autogenModuleName ) import Distribution.Simple.Program ( defaultProgramConfiguration, requireProgram,                               rawSystemProgram, tarProgram ) import Distribution.Text          ( display ) -import Control.Monad(when, unless)+import Control.Monad(when, unless, forM) import Data.Char (toLower) import Data.List (partition, isPrefixOf) import Data.Maybe (isNothing, catMaybes)-import System.Time (getClockTime, toCalendarTime, CalendarTime(..))-import System.Directory-         ( doesFileExist, Permissions(executable), getPermissions )+import Data.Time (UTCTime, getCurrentTime, toGregorian, utctDay)+import System.Directory ( doesFileExist )+import System.IO (IOMode(WriteMode), hPutStrLn, withFile) import Distribution.Verbosity (Verbosity) import System.FilePath-         ( (</>), (<.>), takeDirectory, dropExtension, isAbsolute )+         ( (</>), (<.>), dropExtension, isAbsolute )  -- |Create a source distribution.-sdist :: PackageDescription -- ^information from the tarball-      -> Maybe LocalBuildInfo -- ^Information from configure-      -> SDistFlags -- ^verbosity & snapshot+sdist :: PackageDescription     -- ^information from the tarball+      -> Maybe LocalBuildInfo   -- ^Information from configure+      -> SDistFlags             -- ^verbosity & snapshot       -> (FilePath -> FilePath) -- ^build prefix (temp dir)-      -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)+      -> [PPSuffixHandler]      -- ^ extra preprocessors (includes suffixes)       -> IO ()-sdist pkg mb_lbi flags mkTmpDir pps = do+sdist pkg mb_lbi flags mkTmpDir pps = -  -- do some QA-  printPackageProblems verbosity pkg+  -- When given --list-sources, just output the list of sources to a file.+  case (sDistListSources flags) of+    Flag path -> withFile path WriteMode $ \outHandle -> do+      (ordinary, maybeExecutable) <- listPackageSources verbosity pkg pps+      mapM_ (hPutStrLn outHandle) ordinary+      mapM_ (hPutStrLn outHandle) maybeExecutable+      notice verbosity $ "List of package sources written to file '"+                         ++ path ++ "'"+    NoFlag    -> do+      -- do some QA+      printPackageProblems verbosity pkg -  when (isNothing mb_lbi) $-    warn verbosity "Cannot run preprocessors. Run 'configure' command first."+      when (isNothing mb_lbi) $+        warn verbosity "Cannot run preprocessors. Run 'configure' command first." -  date <- toCalendarTime =<< getClockTime-  let pkg' | snapshot  = snapshotPackage date pkg-           | otherwise = pkg+      date <- getCurrentTime+      let pkg' | snapshot  = snapshotPackage date pkg+               | otherwise = pkg -  case flagToMaybe (sDistDirectory flags) of-    Just targetDir -> do-      generateSourceDir targetDir pkg'-      notice verbosity $ "Source directory created: " ++ targetDir+      case flagToMaybe (sDistDirectory flags) of+        Just targetDir -> do+          generateSourceDir targetDir pkg'+          notice verbosity $ "Source directory created: " ++ targetDir -    Nothing -> do-      createDirectoryIfMissingVerbose verbosity True tmpTargetDir-      withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do-        let targetDir = tmpDir </> tarBallName pkg'-        generateSourceDir targetDir pkg'-        targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref-        notice verbosity $ "Source tarball created: " ++ targzFile+        Nothing -> do+          createDirectoryIfMissingVerbose verbosity True tmpTargetDir+          withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do+            let targetDir = tmpDir </> tarBallName pkg'+            generateSourceDir targetDir pkg'+            targzFile <- createArchive verbosity pkg' mb_lbi tmpDir targetPref+            notice verbosity $ "Source tarball created: " ++ targzFile    where     generateSourceDir targetDir pkg' = do        setupMessage verbosity "Building source dist for" (packageId pkg')-      prepareTree verbosity pkg' mb_lbi distPref targetDir pps+      prepareTree verbosity pkg' mb_lbi targetDir pps       when snapshot $         overwriteSnapshotPackageDesc verbosity pkg' targetDir @@ -151,136 +167,204 @@     targetPref   = distPref     tmpTargetDir = mkTmpDir distPref +-- | List all source files of a package. Returns a tuple of lists: first+-- component is a list of ordinary files, second one is a list of those files+-- that may be executable.+listPackageSources :: Verbosity          -- ^ verbosity+                   -> PackageDescription -- ^ info from the cabal file+                   -> [PPSuffixHandler]  -- ^ extra preprocessors (include+                                         -- suffixes)+                   -> IO ([FilePath], [FilePath])+listPackageSources verbosity pkg_descr0 pps = do+  -- Call helpers that actually do all work.+  ordinary        <- listPackageSourcesOrdinary        verbosity pkg_descr pps+  maybeExecutable <- listPackageSourcesMaybeExecutable pkg_descr+  return (ordinary, maybeExecutable)+  where+    pkg_descr = filterAutogenModule pkg_descr0 --- |Prepare a directory tree of source files.-prepareTree :: Verbosity          -- ^verbosity-            -> PackageDescription -- ^info from the cabal file-            -> Maybe LocalBuildInfo-            -> FilePath           -- ^dist dir-            -> FilePath           -- ^source tree to populate-            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)-            -> IO ()-prepareTree verbosity pkg_descr0 mb_lbi distPref targetDir pps = do-  createDirectoryIfMissingVerbose verbosity True targetDir+-- | List those source files that may be executable (e.g. the configure script).+listPackageSourcesMaybeExecutable :: PackageDescription -> IO [FilePath]+listPackageSourcesMaybeExecutable pkg_descr =+  -- Extra source files.+  fmap concat . forM (extraSrcFiles pkg_descr) $ \fpath -> matchFileGlob fpath -  -- maybe move the library files into place-  withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->-    prepareDir verbosity pkg_descr distPref targetDir pps modules libBi+-- | List those source files that should be copied with ordinary permissions.+listPackageSourcesOrdinary :: Verbosity+                           -> PackageDescription+                           -> [PPSuffixHandler]+                           -> IO [FilePath]+listPackageSourcesOrdinary verbosity pkg_descr pps =+  fmap concat . sequence $+  [+    -- Library sources.+    withLib $ \Library { exposedModules = modules, libBuildInfo = libBi } ->+     allSourcesBuildInfo libBi pps modules -  -- move the executables into place-  withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do-    prepareDir verbosity pkg_descr distPref targetDir pps [] exeBi-    srcMainFile <- do-      ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi) (dropExtension mainPath)-      case ppFile of-        Nothing -> findFile (hsSourceDirs exeBi) mainPath-        Just pp -> return pp-    copyFileTo verbosity targetDir srcMainFile+    -- Executables sources.+  , fmap concat+    . withExe $ \Executable { modulePath = mainPath, buildInfo = exeBi } -> do+       biSrcs  <- allSourcesBuildInfo exeBi pps []+       mainSrc <- findMainExeFile exeBi pps mainPath+       return (mainSrc:biSrcs) -  -- move the test suites into place-  withTest $ \t -> do-    let bi = testBuildInfo t-        prep = prepareDir verbosity pkg_descr distPref targetDir pps-    case testInterface t of-        TestSuiteExeV10 _ mainPath -> do-            prep [] bi-            srcMainFile <- do-                ppFile <- findFileWithExtension (ppSuffixes pps)-                                                (hsSourceDirs bi)-                                                (dropExtension mainPath)-                case ppFile of-                    Nothing -> findFile (hsSourceDirs bi) mainPath-                    Just pp -> return pp-            copyFileTo verbosity targetDir srcMainFile-        TestSuiteLibV09 _ m -> do-            prep [m] bi-        TestSuiteUnsupported tp -> die $ "Unsupported test suite type: " ++ show tp+    -- Test suites sources.+  , fmap concat+    . withTest $ \t -> do+       let bi  = testBuildInfo t+       case testInterface t of+         TestSuiteExeV10 _ mainPath -> do+           biSrcs <- allSourcesBuildInfo bi pps []+           srcMainFile <- do+             ppFile <- findFileWithExtension (ppSuffixes pps)+                       (hsSourceDirs bi) (dropExtension mainPath)+             case ppFile of+               Nothing -> findFile (hsSourceDirs bi) mainPath+               Just pp -> return pp+           return (srcMainFile:biSrcs)+         TestSuiteLibV09 _ m ->+           allSourcesBuildInfo bi pps [m]+         TestSuiteUnsupported tp -> die $ "Unsupported test suite type: "+                                   ++ show tp -  -- move the benchmarks into place-  withBenchmark $ \bm -> do-    let bi = benchmarkBuildInfo bm-        prep = prepareDir verbosity pkg_descr distPref targetDir pps-    case benchmarkInterface bm of-        BenchmarkExeV10 _ mainPath -> do-            prep [] bi-            srcMainFile <- do-                ppFile <- findFileWithExtension (ppSuffixes pps)-                                                (hsSourceDirs bi)-                                                (dropExtension mainPath)-                case ppFile of-                    Nothing -> findFile (hsSourceDirs bi) mainPath-                    Just pp -> return pp-            copyFileTo verbosity targetDir srcMainFile-        BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: " ++ show tp+    -- Benchmarks sources.+  , fmap concat+    . withBenchmark $ \bm -> do+       let  bi = benchmarkBuildInfo bm+       case benchmarkInterface bm of+         BenchmarkExeV10 _ mainPath -> do+           biSrcs <- allSourcesBuildInfo bi pps []+           srcMainFile <- do+             ppFile <- findFileWithExtension (ppSuffixes pps)+                       (hsSourceDirs bi) (dropExtension mainPath)+             case ppFile of+               Nothing -> findFile (hsSourceDirs bi) mainPath+               Just pp -> return pp+           return (srcMainFile:biSrcs)+         BenchmarkUnsupported tp -> die $ "Unsupported benchmark type: "+                                    ++ show tp -  flip mapM_ (dataFiles pkg_descr) $ \ filename -> do-    files <- matchFileGlob (dataDir pkg_descr </> filename)-    let dir = takeDirectory (dataDir pkg_descr </> filename)-    createDirectoryIfMissingVerbose verbosity True (targetDir </> dir)-    sequence_ [ installOrdinaryFile verbosity file (targetDir </> file)-              | file <- files ]+    -- Data files.+  , fmap concat+    . forM (dataFiles pkg_descr) $ \filename ->+       matchFileGlob (dataDir pkg_descr </> filename) -  when (not (null (licenseFile pkg_descr))) $-    copyFileTo verbosity targetDir (licenseFile pkg_descr)-  flip mapM_ (extraSrcFiles pkg_descr) $ \ fpath -> do-    files <- matchFileGlob fpath-    sequence_-      [ do copyFileTo verbosity targetDir file-           -- preserve executable bit on extra-src-files like ./configure-           perms <- getPermissions file-           when (executable perms) --only checks user x bit-                (setFileExecutable (targetDir </> file))-      | file <- files ]+    -- Extra doc files.+  , fmap concat+    . forM (extraDocFiles pkg_descr) $ \ filename ->+      matchFileGlob filename -  -- copy the install-include files-  withLib $ \ l -> do-    let lbi = libBuildInfo l-        relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)-    incs <- mapM (findInc relincdirs) (installIncludes lbi)-    flip mapM_ incs $ \(_,fpath) ->-       copyFileTo verbosity targetDir fpath+    -- License file.+  , return $ case [licenseFile pkg_descr]+             of [[]] -> []+                l    -> l -  -- if the package was configured then we can run platform independent-  -- pre-processors and include those generated files+    -- Install-include files.+  , withLib $ \ l -> do+       let lbi = libBuildInfo l+           relincdirs = "." : filter (not.isAbsolute) (includeDirs lbi)+       mapM (fmap snd . findIncludeFile relincdirs) (installIncludes lbi)++    -- Setup script, if it exists.+  , fmap (maybe [] (\f -> [f])) $ findSetupFile ""++    -- The .cabal file itself.+  , fmap (\d -> [d]) (defaultPackageDesc verbosity)++  ]+  where+    -- We have to deal with all libs and executables, so we have local+    -- versions of these functions that ignore the 'buildable' attribute:+    withLib       action = maybe (return []) action (library pkg_descr)+    withExe       action = mapM action (executables pkg_descr)+    withTest      action = mapM action (testSuites pkg_descr)+    withBenchmark action = mapM action (benchmarks pkg_descr)+++-- |Prepare a directory tree of source files.+prepareTree :: Verbosity          -- ^verbosity+            -> PackageDescription -- ^info from the cabal file+            -> Maybe LocalBuildInfo+            -> FilePath           -- ^source tree to populate+            -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)+            -> IO ()+prepareTree verbosity pkg_descr0 mb_lbi targetDir pps = do+  -- If the package was configured then we can run platform independent+  -- pre-processors and include those generated files.   case mb_lbi of     Just lbi | not (null pps) -> do-      let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }   -      withComponentsLBI pkg_descr lbi' $ \c _ ->+      let lbi' = lbi{ buildDir = targetDir </> buildDir lbi }+      withAllComponentsInBuildOrder pkg_descr lbi' $ \c _ ->         preprocessComponent pkg_descr c lbi' True verbosity pps     _ -> return () -  -- setup isn't listed in the description file.-  hsExists <- doesFileExist "Setup.hs"-  lhsExists <- doesFileExist "Setup.lhs"-  if hsExists then copyFileTo verbosity targetDir "Setup.hs"-    else if lhsExists then copyFileTo verbosity targetDir "Setup.lhs"-    else writeUTF8File (targetDir </> "Setup.hs") $ unlines [-                "import Distribution.Simple",-                "main = defaultMain"]-  -- the description file itself-  descFile <- defaultPackageDesc verbosity-  installOrdinaryFile verbosity descFile (targetDir </> descFile)+  (ordinary, mExecutable)  <- listPackageSources verbosity pkg_descr0 pps+  installOrdinaryFiles        verbosity targetDir (zip (repeat []) ordinary)+  installMaybeExecutableFiles verbosity targetDir (zip (repeat []) mExecutable)+  maybeCreateDefaultSetupScript targetDir    where-    pkg_descr = mapAllBuildInfo filterAutogenModule pkg_descr0-    filterAutogenModule bi = bi {-      otherModules = filter (/=autogenModule) (otherModules bi)-    }-    autogenModule = autogenModuleName pkg_descr0+    pkg_descr = filterAutogenModule pkg_descr0 -    findInc [] f = die ("can't find include file " ++ f)-    findInc (d:ds) f = do-      let path = (d </> f)-      b <- doesFileExist path-      if b then return (f,path) else findInc ds f+-- | Find the setup script file, if it exists.+findSetupFile :: FilePath -> IO (Maybe FilePath)+findSetupFile targetDir = do+  hsExists  <- doesFileExist setupHs+  lhsExists <- doesFileExist setupLhs+  if hsExists+    then return (Just setupHs)+    else if lhsExists+         then return (Just setupLhs)+         else return Nothing+    where+      setupHs  = targetDir </> "Setup.hs"+      setupLhs = targetDir </> "Setup.lhs" -    -- We have to deal with all libs and executables, so we have local-    -- versions of these functions that ignore the 'buildable' attribute:-    withLib action = maybe (return ()) action (library pkg_descr)-    withExe action = mapM_ action (executables pkg_descr)-    withTest action = mapM_ action (testSuites pkg_descr)-    withBenchmark action = mapM_ action (benchmarks pkg_descr)+-- | Create a default setup script in the target directory, if it doesn't exist.+maybeCreateDefaultSetupScript :: FilePath -> IO ()+maybeCreateDefaultSetupScript targetDir = do+  mSetupFile <- findSetupFile targetDir+  case mSetupFile of+    Just _setupFile -> return ()+    Nothing         -> do+      writeUTF8File (targetDir </> "Setup.hs") $ unlines [+        "import Distribution.Simple",+        "main = defaultMain"] +-- | Find the main executable file.+findMainExeFile :: BuildInfo -> [PPSuffixHandler] -> FilePath -> IO FilePath+findMainExeFile exeBi pps mainPath = do+  ppFile <- findFileWithExtension (ppSuffixes pps) (hsSourceDirs exeBi)+            (dropExtension mainPath)+  case ppFile of+    Nothing -> findFile (hsSourceDirs exeBi) mainPath+    Just pp -> return pp++-- | Given a list of include paths, try to find the include file named+-- @f@. Return the name of the file and the full path, or exit with error if+-- there's no such file.+findIncludeFile :: [FilePath] -> String -> IO (String, FilePath)+findIncludeFile [] f = die ("can't find include file " ++ f)+findIncludeFile (d:ds) f = do+  let path = (d </> f)+  b <- doesFileExist path+  if b then return (f,path) else findIncludeFile ds f++-- | Remove the auto-generated module ('Paths_*') from 'exposed-modules' and+-- 'other-modules'.+filterAutogenModule :: PackageDescription -> PackageDescription+filterAutogenModule pkg_descr0 = mapLib filterAutogenModuleLib $+                                 mapAllBuildInfo filterAutogenModuleBI pkg_descr0+  where+    mapLib f pkg = pkg { library = fmap f (library pkg) }+    filterAutogenModuleLib lib = lib {+      exposedModules = filter (/=autogenModule) (exposedModules lib)+    }+    filterAutogenModuleBI bi = bi {+      otherModules   = filter (/=autogenModule) (otherModules bi)+    }+    autogenModule = autogenModuleName pkg_descr0+ -- | Prepare a directory tree of source files for a snapshot version. -- It is expected that the appropriate snapshot version has already been set -- in the package description, eg using 'snapshotPackage' or 'snapshotVersion'.@@ -288,12 +372,12 @@ prepareSnapshotTree :: Verbosity          -- ^verbosity                     -> PackageDescription -- ^info from the cabal file                     -> Maybe LocalBuildInfo-                    -> FilePath           -- ^dist dir                     -> FilePath           -- ^source tree to populate-                    -> [PPSuffixHandler]  -- ^extra preprocessors (includes suffixes)+                    -> [PPSuffixHandler]  -- ^extra preprocessors (includes+                                          -- suffixes)                     -> IO ()-prepareSnapshotTree verbosity pkg mb_lbi distPref targetDir pps = do-  prepareTree verbosity pkg mb_lbi distPref targetDir pps+prepareSnapshotTree verbosity pkg mb_lbi targetDir pps = do+  prepareTree verbosity pkg mb_lbi targetDir pps   overwriteSnapshotPackageDesc verbosity pkg targetDir  overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity@@ -318,7 +402,7 @@ -- | Modifies a 'PackageDescription' by appending a snapshot number -- corresponding to the given date. ---snapshotPackage :: CalendarTime -> PackageDescription -> PackageDescription+snapshotPackage :: UTCTime -> PackageDescription -> PackageDescription snapshotPackage date pkg =   pkg {     package = pkgid { pkgVersion = snapshotVersion date (pkgVersion pkgid) }@@ -328,7 +412,7 @@ -- | Modifies a 'Version' by appending a snapshot number corresponding -- to the given date. ---snapshotVersion :: CalendarTime -> Version -> Version+snapshotVersion :: UTCTime -> Version -> Version snapshotVersion date version = version {     versionBranch = versionBranch version                  ++ [dateToSnapshotNumber date]@@ -337,70 +421,62 @@ -- | Given a date produce a corresponding integer representation. -- For example given a date @18/03/2008@ produce the number @20080318@. ---dateToSnapshotNumber :: CalendarTime -> Int-dateToSnapshotNumber date = year  * 10000-                          + month * 100-                          + day-  where-    year  = ctYear date-    month = fromEnum (ctMonth date) + 1-    day   = ctDay date+dateToSnapshotNumber :: UTCTime -> Int+dateToSnapshotNumber date = case toGregorian (utctDay date) of+                            (year, month, day) ->+                                fromIntegral year * 10000+                              + month             * 100+                              + day --- |Create an archive from a tree of source files, and clean up the tree.-createArchive :: Verbosity            -- ^verbosity-              -> PackageDescription   -- ^info from cabal file-              -> Maybe LocalBuildInfo -- ^info from configure-              -> FilePath             -- ^source tree to archive-              -> FilePath             -- ^name of archive to create-              -> IO FilePath+-- | Callback type for use by sdistWith.+type CreateArchiveFun = Verbosity               -- ^verbosity+                        -> PackageDescription   -- ^info from cabal file+                        -> Maybe LocalBuildInfo -- ^info from configure+                        -> FilePath             -- ^source tree to archive+                        -> FilePath             -- ^name of archive to create+                        -> IO FilePath +-- | Create an archive from a tree of source files, and clean up the tree.+createArchive :: CreateArchiveFun createArchive verbosity pkg_descr mb_lbi tmpDir targetPref = do   let tarBallFilePath = targetPref </> tarBallName pkg_descr <.> "tar.gz"    (tarProg, _) <- requireProgram verbosity tarProgram                     (maybe defaultProgramConfiguration withPrograms mb_lbi) -   -- Hmm: I could well be skating on thinner ice here by using the -C option (=> GNU tar-specific?)-   -- [The prev. solution used pipes and sub-command sequences to set up the paths correctly,-   -- which is problematic in a Windows setting.]+   -- Hmm: I could well be skating on thinner ice here by using the -C option+   -- (=> GNU tar-specific?)  [The prev. solution used pipes and sub-command+   -- sequences to set up the paths correctly, which is problematic in a Windows+   -- setting.]   rawSystemProgram verbosity tarProg            ["-C", tmpDir, "-czf", tarBallFilePath, tarBallName pkg_descr]   return tarBallFilePath --- |Move the sources into place based on buildInfo-prepareDir :: Verbosity -- ^verbosity-           -> PackageDescription -- ^info from the cabal file-           -> FilePath           -- ^dist dir-           -> FilePath  -- ^TargetPrefix-           -> [PPSuffixHandler]  -- ^ extra preprocessors (includes suffixes)-           -> [ModuleName]  -- ^Exposed modules-           -> BuildInfo-           -> IO ()-prepareDir verbosity _pkg _distPref inPref pps modules bi-    = do let searchDirs = hsSourceDirs bi-         sources <- sequence-           [ let file = ModuleName.toFilePath module_-              in findFileWithExtension suffixes searchDirs file-             >>= maybe (notFound module_) return-           | module_ <- modules ++ otherModules bi ]-         bootFiles <- sequence-           [ let file = ModuleName.toFilePath module_-                 fileExts = ["hs-boot", "lhs-boot"]-              in findFileWithExtension fileExts (hsSourceDirs bi) file-           | module_ <- modules ++ otherModules bi ]+-- | Given a buildinfo, return the names of all source files.+allSourcesBuildInfo :: BuildInfo+                       -> [PPSuffixHandler] -- ^ Extra preprocessors+                       -> [ModuleName]      -- ^ Exposed modules+                       -> IO [FilePath]+allSourcesBuildInfo bi pps modules = do+  let searchDirs = hsSourceDirs bi+  sources <- sequence+    [ let file = ModuleName.toFilePath module_+      in findFileWithExtension suffixes searchDirs file+         >>= maybe (notFound module_) return+    | module_ <- modules ++ otherModules bi ]+  bootFiles <- sequence+    [ let file = ModuleName.toFilePath module_+          fileExts = ["hs-boot", "lhs-boot"]+      in findFileWithExtension fileExts (hsSourceDirs bi) file+    | module_ <- modules ++ otherModules bi ] -         let allSources = sources ++ catMaybes bootFiles ++ cSources bi-         installOrdinaryFiles verbosity inPref (zip (repeat []) allSources)+  return $ sources ++ catMaybes bootFiles ++ cSources bi -    where suffixes = ppSuffixes pps ++ ["hs", "lhs"]-          notFound m = die $ "Error: Could not find module: " ++ display m-                          ++ " with any suffix: " ++ show suffixes+  where+    suffixes = ppSuffixes pps ++ ["hs", "lhs"]+    notFound m = die $ "Error: Could not find module: " ++ display m+                 ++ " with any suffix: " ++ show suffixes -copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()-copyFileTo verbosity dir file = do-  let targetFile = dir </> file-  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)-  installOrdinaryFile verbosity file targetFile  printPackageProblems :: Verbosity -> PackageDescription -> IO () printPackageProblems verbosity pkg_descr = do
cabal/Cabal/Distribution/Simple/Test.hs view
@@ -71,13 +71,13 @@ import qualified Distribution.Simple.LocalBuildInfo as LBI     ( LocalBuildInfo(..) ) import Distribution.Simple.Setup ( TestFlags(..), TestShowDetails(..), fromFlag )-import Distribution.Simple.Utils ( die, notice )+import Distribution.Simple.Utils ( die, notice, rawSystemIOWithEnv ) import Distribution.TestSuite     ( OptionDescr(..), Options, Progress(..), Result(..), TestInstance(..)     , Test(..) ) import Distribution.Text import Distribution.Verbosity ( normal, Verbosity )-import Distribution.System ( buildPlatform, Platform )+import Distribution.System ( Platform )  import Control.Exception ( bracket ) import Control.Monad ( when, unless, filterM )@@ -86,12 +86,11 @@ import System.Directory     ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist     , getCurrentDirectory, getDirectoryContents, removeDirectoryRecursive-    , removeFile )-import System.Environment ( getEnvironment )+    , removeFile, setCurrentDirectory )+import Distribution.Compat.Environment ( getEnvironment ) import System.Exit ( ExitCode(..), exitFailure, exitWith ) import System.FilePath ( (</>), (<.>) ) import System.IO ( hClose, IOMode(..), openFile )-import System.Process ( runProcess, waitForProcess )  -- | Logs all test results for a package, broken down first by test suite and -- then by test case.@@ -108,7 +107,7 @@ localPackageLog pkg_descr lbi = PackageLog     { package = PD.package pkg_descr     , compiler = compilerId $ LBI.compiler lbi-    , platform = buildPlatform+    , platform = LBI.hostPlatform lbi     , testSuites = []     } @@ -191,10 +190,10 @@     pwd <- getCurrentDirectory     existingEnv <- getEnvironment     let dataDirPath = pwd </> PD.dataDir pkg_descr-        shellEnv = Just $ (pkgPathEnvVar pkg_descr "datadir", dataDirPath)-                        : ("HPCTIXFILE", (</>) pwd-                            $ tixFilePath distPref $ PD.testName suite)-                        : existingEnv+        shellEnv = (pkgPathEnvVar pkg_descr "datadir", dataDirPath)+                   : ("HPCTIXFILE", (</>) pwd+                       $ tixFilePath distPref $ PD.testName suite)+                   : existingEnv      bracket (openCabalTemp testLogDir) deleteIfExists $ \tempLog ->         bracket (openCabalTemp testLogDir) deleteIfExists $ \tempInput -> do@@ -223,10 +222,9 @@             exit <- do               hLog <- openFile tempLog AppendMode               hIn  <- openFile tempInput ReadMode-              -- these handles get closed by runProcess-              proc <- runProcess cmd opts Nothing shellEnv-                        (Just hIn) (Just hLog) (Just hLog)-              waitForProcess proc+              -- these handles get closed by rawSystemIOWithEnv+              rawSystemIOWithEnv verbosity cmd opts Nothing (Just shellEnv)+                                 (Just hIn) (Just hLog) (Just hLog)              -- Generate TestSuiteLog from executable exit code and a machine-             -- readable test log@@ -432,6 +430,7 @@     where         env = initialPathTemplateEnv                 (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+                (LBI.hostPlatform lbi)                 ++  [ (TestSuiteNameVar, toPathTemplate $ testSuiteName testLog)                     , (TestSuiteResultVar, result)                     ]@@ -448,7 +447,8 @@     fromPathTemplate $ substPathTemplate env template   where     env = initialPathTemplateEnv-          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi) +++          (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+          (LBI.hostPlatform lbi) ++           [(TestSuiteNameVar, toPathTemplate $ PD.testName suite)]  packageLogPath :: PathTemplate@@ -460,6 +460,7 @@     where         env = initialPathTemplateEnv                 (PD.package pkg_descr) (compilerId $ LBI.compiler lbi)+                (LBI.hostPlatform lbi)  -- | The filename of the source file for the stub executable associated with a -- library 'TestSuite'.@@ -498,7 +499,10 @@ stubMain :: IO [Test] -> IO () stubMain tests = do     (f, n) <- fmap read getContents-    tests >>= stubRunTests >>= stubWriteLog f n+    dir <- getCurrentDirectory+    results <- tests >>= stubRunTests+    setCurrentDirectory dir+    stubWriteLog f n results  -- | The test runner used in library "TestSuite" stub executables.  Runs a list -- of 'Test's.  An executable calling this function is meant to be invoked as@@ -541,4 +545,3 @@     when (suiteError testLog) $ exitWith $ ExitFailure 2     when (suiteFailed testLog) $ exitWith $ ExitFailure 1     exitWith ExitSuccess-
cabal/Cabal/Distribution/Simple/UHC.hs view
@@ -53,6 +53,7 @@  import Control.Monad import Data.List+import qualified Data.Map as M ( empty ) import Distribution.Compat.ReadP import Distribution.InstalledPackageInfo import Distribution.Package@@ -69,12 +70,13 @@ import Language.Haskell.Extension import System.Directory import System.FilePath+import Distribution.System ( Platform )  -- ----------------------------------------------------------------------------- -- Configuring  configure :: Verbosity -> Maybe FilePath -> Maybe FilePath-          -> ProgramConfiguration -> IO (Compiler, ProgramConfiguration)+          -> ProgramConfiguration -> IO (Compiler, Maybe Platform, ProgramConfiguration) configure verbosity hcPath _hcPkgPath conf = do    (_uhcProg, uhcVersion, conf') <-@@ -83,11 +85,13 @@     (userMaybeSpecifyPath "uhc" hcPath conf)    let comp = Compiler {-               compilerId          =  CompilerId UHC uhcVersion,-               compilerLanguages   =  uhcLanguages,-               compilerExtensions  =  uhcLanguageExtensions+               compilerId         =  CompilerId UHC uhcVersion,+               compilerLanguages  =  uhcLanguages,+               compilerExtensions =  uhcLanguageExtensions,+               compilerProperties =  M.empty              }-  return (comp, conf')+      compPlatform = Nothing+  return (comp, compPlatform, conf')  uhcLanguages :: [(Language, C.Flag)] uhcLanguages = [(Haskell98, "")]
cabal/Cabal/Distribution/Simple/UserHooks.hs view
@@ -64,7 +64,7 @@ import Distribution.Simple.Command    (noExtraFlags) import Distribution.Simple.PreProcess (PPSuffixHandler) import Distribution.Simple.Setup-         (ConfigFlags, BuildFlags, CleanFlags, CopyFlags,+         (ConfigFlags, BuildFlags, ReplFlags, CleanFlags, CopyFlags,           InstallFlags, SDistFlags, RegisterFlags, HscolourFlags,           HaddockFlags, TestFlags, BenchmarkFlags) import Distribution.Simple.LocalBuildInfo (LocalBuildInfo)@@ -105,6 +105,13 @@     -- |Hook to run after build command.  Second arg indicates verbosity level.     postBuild :: Args -> BuildFlags -> PackageDescription -> LocalBuildInfo -> IO (), +    -- |Hook to run before repl command.  Second arg indicates verbosity level.+    preRepl  :: Args -> ReplFlags -> IO HookedBuildInfo,+    -- |Over-ride this hook to get different behavior during interpretation.+    replHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> ReplFlags -> [String] -> IO (),+    -- |Hook to run after repl command.  Second arg indicates verbosity level.+    postRepl :: Args -> ReplFlags -> PackageDescription -> LocalBuildInfo -> IO (),+     -- |Hook to run before clean command.  Second arg indicates verbosity level.     preClean  :: Args -> CleanFlags -> IO HookedBuildInfo,     -- |Over-ride this hook to get different behavior during clean.@@ -144,7 +151,7 @@      -- |Hook to run before unregister command     preUnreg  :: Args -> RegisterFlags -> IO HookedBuildInfo,-    -- |Over-ride this hook to get different behavior during registration.+    -- |Over-ride this hook to get different behavior during unregistration.     unregHook :: PackageDescription -> LocalBuildInfo -> UserHooks -> RegisterFlags -> IO (),     -- |Hook to run after unregister command     postUnreg :: Args -> RegisterFlags -> PackageDescription -> LocalBuildInfo -> IO (),@@ -191,9 +198,12 @@       preConf   = rn,       confHook  = (\_ _ -> return (error "No local build info generated during configure. Over-ride empty configure hook.")),       postConf  = ru,-      preBuild  = rn,+      preBuild  = rn',       buildHook = ru,       postBuild = ru,+      preRepl   = \_ _ -> return emptyHookedBuildInfo,+      replHook  = \_ _ _ _ _ -> return (),+      postRepl  = ru,       preClean  = rn,       cleanHook = ru,       postClean = ru,@@ -218,14 +228,13 @@       preHaddock   = rn,       haddockHook  = ru,       postHaddock  = ru,-      preTest = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without-                                                     -- noExtraFlags+      preTest  = rn',       testHook = ru,       postTest = ru,-      preBench = \_ _ -> return emptyHookedBuildInfo, -- same as rn, but without-                                                      -- noExtraFlags+      preBench = rn',       benchHook = \_ -> ru,       postBench = ru     }-    where rn args  _ = noExtraFlags args >> return emptyHookedBuildInfo+    where rn  args _ = noExtraFlags args >> return emptyHookedBuildInfo+          rn' _    _ = return emptyHookedBuildInfo           ru _ _ _ _ = return ()
cabal/Cabal/Distribution/Simple/Utils.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Simple.Utils@@ -52,9 +50,9 @@         -- * logging and errors         die,         dieWithLocation,-        topHandler,+        topHandler, topHandlerWith,         warn, notice, setupMessage, info, debug,-        chattyTry,+        debugNoWrap, chattyTry,          -- * running programs         rawSystemExit,@@ -62,6 +60,7 @@         rawSystemExitWithEnv,         rawSystemStdout,         rawSystemStdInOut,+        rawSystemIOWithEnv,         maybeExit,         xargs,         findProgramLocation,@@ -73,14 +72,19 @@         copyFileVerbose,         copyDirectoryRecursiveVerbose,         copyFiles,+        copyFileTo,          -- * installing files         installOrdinaryFile,         installExecutableFile,+        installMaybeExecutableFile,         installOrdinaryFiles,+        installExecutableFiles,+        installMaybeExecutableFiles,         installDirectoryContents,          -- * File permissions+        doesExecutableExist,         setFileOrdinary,         setFileExecutable, @@ -96,19 +100,28 @@         findModuleFiles,         getDirectoryContentsRecursive, +        -- * environment variables+        isInSearchPath,+         -- * simple file globbing         matchFileGlob,         matchDirFileGlob,         parseFileGlob,         FileGlob(..), +        -- * modification time+        moreRecentFile,+        existsAndIsMoreRecentThan,+         -- * temp files and dirs-        withTempFile,-        withTempDirectory,+        TempFileOptions(..), defaultTempFileOptions,+        withTempFile, withTempFileEx,+        withTempDirectory, withTempDirectoryEx,          -- * .cabal and .buildinfo files         defaultPackageDesc,         findPackageDesc,+        tryFindPackageDesc,         defaultHookedPackageDesc,         findHookedPackageDesc, @@ -136,13 +149,11 @@   ) where  import Control.Monad-    ( when, unless, filterM )-#ifdef __GLASGOW_HASKELL__+    ( join, when, unless, filterM ) import Control.Concurrent.MVar     ( newEmptyMVar, putMVar, takeMVar )-#endif import Data.List-    ( nub, unfoldr, isPrefixOf, tails, intersperse )+  ( nub, unfoldr, isPrefixOf, tails, intercalate ) import Data.Char as Char     ( toLower, chr, ord ) import Data.Bits@@ -151,30 +162,28 @@ import qualified Data.ByteString.Lazy.Char8 as BS.Char8  import System.Directory-    ( getDirectoryContents, doesDirectoryExist, doesFileExist, removeFile-    , findExecutable )+    ( Permissions(executable), getDirectoryContents, getPermissions+    , doesDirectoryExist, doesFileExist, removeFile, findExecutable+    , getModificationTime ) import System.Environment     ( getProgName )-import System.Cmd-    ( rawSystem ) import System.Exit     ( exitWith, ExitCode(..) ) import System.FilePath-    ( normalise, (</>), (<.>), takeDirectory, splitFileName+    ( normalise, (</>), (<.>)+    , getSearchPath, takeDirectory, splitFileName     , splitExtension, splitExtensions, splitDirectories ) import System.Directory     ( createDirectory, renameFile, removeDirectoryRecursive ) import System.IO     ( Handle, openFile, openBinaryFile, openBinaryTempFile     , IOMode(ReadMode), hSetBinaryMode-    , hGetContents, stderr, stdout, hPutStr, hFlush, hClose )+    , hGetContents, stdin, stderr, stdout, hPutStr, hFlush, hClose ) import System.IO.Error as IO.Error     ( isDoesNotExistError, isAlreadyExistsError     , ioeSetFileName, ioeGetFileName, ioeGetErrorString )-#if !(defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)) import System.IO.Error     ( ioeSetLocation, ioeGetLocation )-#endif import System.IO.Unsafe     ( unsafeInterleaveIO ) import qualified Control.Exception as Exception@@ -188,15 +197,22 @@ import Distribution.Version     (Version(..)) -import Control.Exception (evaluate)-import System.Process (runProcess)+import Control.Exception (IOException, evaluate, throwIO)+import System.Process (rawSystem)+import qualified System.Process as Process (CreateProcess(..)) -#ifdef __GLASGOW_HASKELL__ import Control.Concurrent (forkIO)-import System.Process (runInteractiveProcess, waitForProcess)+import System.Process (runInteractiveProcess, waitForProcess, proc,+                       StdStream(..))+#if __GLASGOW_HASKELL__ >= 702+import System.Process (showCommandForUser)+#endif++#ifndef mingw32_HOST_OS+import System.Posix.Signals (installHandler, sigINT, sigQUIT, Handler(..))+import System.Process.Internals (defaultSignal, runGenProcess_) #else-import System.Cmd (system)-import System.Directory (getTemporaryDirectory)+import System.Process (createProcess) #endif  import Distribution.Compat.CopyFile@@ -205,7 +221,7 @@ import Distribution.Compat.TempFile          ( openTempFile, createTempDirectory ) import Distribution.Compat.Exception-         ( IOException, throwIOIO, tryIO, catchIO, catchExit )+         ( tryIO, catchIO, catchExit ) import Distribution.Verbosity  #ifdef VERSION_base@@ -231,38 +247,33 @@           . flip ioeSetFileName (normalise filename)           $ userError msg   where-#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)-    setLocation _        err = err-#else     setLocation Nothing  err = err     setLocation (Just n) err = ioeSetLocation err (show n)-#endif  die :: String -> IO a die msg = ioError (userError msg) -topHandler :: IO a -> IO a-topHandler prog = catchIO prog handle+topHandlerWith :: (Exception.IOException -> IO a) -> IO a -> IO a+topHandlerWith cont prog = catchIO prog handle   where     handle ioe = do       hFlush stdout       pname <- getProgName       hPutStr stderr (mesage pname)-      exitWith (ExitFailure 1)+      cont ioe       where         mesage pname = wrapText (pname ++ ": " ++ file ++ detail)         file         = case ioeGetFileName ioe of                          Nothing   -> ""                          Just path -> path ++ location ++ ": "-#if defined(__HUGS__) || (defined(__GLASGOW_HASKELL__) && __GLASGOW_HASKELL__ < 608)-        location     = ""-#else         location     = case ioeGetLocation ioe of                          l@(n:_) | n >= '0' && n <= '9' -> ':' : l                          _                              -> ""-#endif         detail       = ioeGetErrorString ioe +topHandler :: IO a -> IO a+topHandler prog = topHandlerWith (const $ exitWith (ExitFailure 1)) prog+ -- | Non fatal conditions that may be indicative of an error or problem. -- -- We display these at the 'normal' verbosity level.@@ -308,6 +319,14 @@     putStr (wrapText msg)     hFlush stdout +-- | A variant of 'debug' that doesn't perform the automatic line+-- wrapping. Produces better output in some cases.+debugNoWrap :: Verbosity -> String -> IO ()+debugNoWrap verbosity msg =+  when (verbosity >= deafening) $ do+    putStrLn msg+    hFlush stdout+ -- | Perform an IO action, catching any IO exceptions and printing an error --   if one occurs. chattyTry :: String  -- ^ a description of the action we were attempting@@ -323,9 +342,10 @@ -- | Wraps text to the default line width. Existing newlines are preserved. wrapText :: String -> String wrapText = unlines-         . concatMap (map unwords-                    . wrapLine 79-                    . words)+         . map (intercalate "\n"+              . map unwords+              . wrapLine 79+              . words)          . lines  -- | Wraps a list of words to a list of lines of words of a particular width.@@ -354,7 +374,12 @@ printRawCommandAndArgs :: Verbosity -> FilePath -> [String] -> IO () printRawCommandAndArgs verbosity path args  | verbosity >= deafening = print (path, args)- | verbosity >= verbose   = putStrLn $ unwords (path : args)+ | verbosity >= verbose   =+#if __GLASGOW_HASKELL__ >= 702+                            putStrLn $ showCommandForUser path args+#else+                            putStrLn $ unwords (path : args)+#endif  | otherwise              = return ()  printRawCommandAndArgsAndEnv :: Verbosity@@ -368,6 +393,40 @@  | verbosity >= verbose   = putStrLn $ unwords (path : args)  | otherwise              = return () ++-- This is taken directly from the process package.+-- The reason we need it is that runProcess doesn't handle ^C in the same+-- way that rawSystem handles it, but rawSystem doesn't allow us to pass+-- an environment.+syncProcess :: String -> Process.CreateProcess -> IO ExitCode+#if mingw32_HOST_OS+syncProcess _fun c = do+  (_,_,_,p) <- createProcess c+  waitForProcess p+#else+syncProcess fun c = do+  -- The POSIX version of system needs to do some manipulation of signal+  -- handlers.  Since we're going to be synchronously waiting for the child,+  -- we want to ignore ^C in the parent, but handle it the default way+  -- in the child (using SIG_DFL isn't really correct, it should be the+  -- original signal handler, but the GHC RTS will have already set up+  -- its own handler and we don't want to use that).+  r <- Exception.bracket (installHandlers) (restoreHandlers) $+       (\_ -> do (_,_,_,p) <- runGenProcess_ fun c+                              (Just defaultSignal) (Just defaultSignal)+                 waitForProcess p)+  return r+    where+      installHandlers = do+        old_int  <- installHandler sigINT  Ignore Nothing+        old_quit <- installHandler sigQUIT Ignore Nothing+        return (old_int, old_quit)+      restoreHandlers (old_int, old_quit) = do+        _ <- installHandler sigINT  old_int Nothing+        _ <- installHandler sigQUIT old_quit Nothing+        return ()+#endif  /* mingw32_HOST_OS */+ -- Exit with the same exitcode if the subcommand fails rawSystemExit :: Verbosity -> FilePath -> [String] -> IO () rawSystemExit verbosity path args = do@@ -395,12 +454,47 @@ rawSystemExitWithEnv verbosity path args env = do     printRawCommandAndArgsAndEnv verbosity path args env     hFlush stdout-    ph <- runProcess path args Nothing (Just env) Nothing Nothing Nothing-    exitcode <- waitForProcess ph+    exitcode <- syncProcess "rawSystemExitWithEnv" (proc path args)+                { Process.env = Just env }     unless (exitcode == ExitSuccess) $ do         debug verbosity $ path ++ " returned " ++ show exitcode         exitWith exitcode +-- Closes the passed in handles before returning.+rawSystemIOWithEnv :: Verbosity+                   -> FilePath+                   -> [String]+                   -> Maybe FilePath           -- ^ New working dir or inherit+                   -> Maybe [(String, String)] -- ^ New environment or inherit+                   -> Maybe Handle  -- ^ stdin+                   -> Maybe Handle  -- ^ stdout+                   -> Maybe Handle  -- ^ stderr+                   -> IO ExitCode+rawSystemIOWithEnv verbosity path args mcwd menv inp out err = do+    maybe (printRawCommandAndArgs       verbosity path args)+          (printRawCommandAndArgsAndEnv verbosity path args) menv+    hFlush stdout+    exitcode <- syncProcess "rawSystemIOWithEnv" (proc path args)+                { Process.cwd     = mcwd+                , Process.env     = menv+                , Process.std_in  = mbToStd inp+                , Process.std_out = mbToStd out+                , Process.std_err = mbToStd err }+                `Exception.finally` (mapM_ maybeClose [inp, out, err])+    unless (exitcode == ExitSuccess) $ do+      debug verbosity $ path ++ " returned " ++ show exitcode+    return exitcode+  where+  -- Also taken from System.Process+  maybeClose :: Maybe Handle -> IO ()+  maybeClose (Just  hdl)+    | hdl /= stdin && hdl /= stdout && hdl /= stderr = hClose hdl+  maybeClose _ = return ()++  mbToStd :: Maybe Handle -> StdStream+  mbToStd Nothing    = Inherit+  mbToStd (Just hdl) = UseHandle hdl+ -- | Run a command and return its output. -- -- The output is assumed to be text in the locale encoding.@@ -408,6 +502,7 @@ rawSystemStdout :: Verbosity -> FilePath -> [String] -> IO String rawSystemStdout verbosity path args = do   (output, errors, exitCode) <- rawSystemStdInOut verbosity path args+                                                  Nothing Nothing                                                   Nothing False   when (exitCode /= ExitSuccess) $     die errors@@ -418,16 +513,18 @@ -- mode of the input and output. -- rawSystemStdInOut :: Verbosity-                  -> FilePath -> [String]-                  -> Maybe (String, Bool) -- ^ input text and binary mode-                  -> Bool                 -- ^ output in binary mode+                  -> FilePath                 -- ^ Program location+                  -> [String]                 -- ^ Arguments+                  -> Maybe FilePath           -- ^ New working dir or inherit+                  -> Maybe [(String, String)] -- ^ New environment or inherit+                  -> Maybe (String, Bool)     -- ^ input text and binary mode+                  -> Bool                     -- ^ output in binary mode                   -> IO (String, String, ExitCode) -- ^ output, errors, exit-rawSystemStdInOut verbosity path args input outputBinary = do+rawSystemStdInOut verbosity path args mcwd menv input outputBinary = do   printRawCommandAndArgs verbosity path args -#ifdef __GLASGOW_HASKELL__   Exception.bracket-     (runInteractiveProcess path args Nothing Nothing)+     (runInteractiveProcess path args mcwd menv)      (\(inh,outh,errh,_) -> hClose inh >> hClose outh >> hClose errh)     $ \(inh,outh,errh,pid) -> do @@ -470,37 +567,14 @@         debug verbosity $ path ++ " returned " ++ show exitcode                        ++ if null err then "" else                           " with error message:\n" ++ err+                       ++ case input of+                            Nothing       -> ""+                            Just ("",  _) -> ""+                            Just (inp, _) -> "\nstdin input:\n" ++ inp        return (out, err, exitcode)-#else-  tmpDir <- getTemporaryDirectory-  withTempFile tmpDir ".cmd.stdout" $ \outName outHandle ->-   withTempFile tmpDir ".cmd.stdin" $ \inName inHandle -> do-    hClose outHandle -    case input of-      Nothing -> return ()-      Just (inputStr, inputBinary) -> do-        hSetBinaryMode inHandle inputBinary-        hPutStr inHandle inputStr-    hClose inHandle -    let quote name = "'" ++ name ++ "'"-        cmd = unwords (map quote (path:args))-           ++ " <" ++ quote inName-           ++ " >" ++ quote outName-    exitcode <- system cmd--    unless (exitcode == ExitSuccess) $-      debug verbosity $ path ++ " returned " ++ show exitcode--    Exception.bracket (openFile outName ReadMode) hClose $ \hnd -> do-      hSetBinaryMode hnd outputBinary-      output <- hGetContents hnd-      length output `seq` return (output, "", exitcode)-#endif-- -- | Look for a program on the path. findProgramLocation :: Verbosity -> FilePath -> IO (Maybe FilePath) findProgramLocation verbosity prog = do@@ -659,7 +733,8 @@       return (files ++ files')        where-        collect files dirs' []              = return (reverse files, reverse dirs')+        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@@ -673,6 +748,13 @@         ignore ['.', '.'] = True         ignore _          = False +------------------------+-- Environment variables++-- | Is this directory in the system search path?+isInSearchPath :: FilePath -> IO Bool+isInSearchPath path = fmap (elem path) getSearchPath+ ---------------- -- File globbing @@ -715,6 +797,31 @@                     ++ "' does not match any files."       matches -> return matches +--------------------+-- Modification time++-- | Compare the modification times of two files to see if the first is newer+-- than the second. The first file must exist but the second need not.+-- The expected use case is when the second file is generated using the first.+-- In this use case, if the result is True then the second file is out of date.+--+moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile a b = do+  exists <- doesFileExist b+  if not exists+    then return True+    else do tb <- getModificationTime b+            ta <- getModificationTime a+            return (ta > tb)++-- | Like 'moreRecentFile', but also checks that the first file exists.+existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool+existsAndIsMoreRecentThan a b = do+  exists <- doesFileExist a+  if not exists+    then return False+    else a `moreRecentFile` b+ ---------------------------------------- -- Copying and installing files and dirs @@ -731,11 +838,11 @@     parents = reverse . scanl1 (</>) . splitDirectories . normalise      createDirs []         = return ()-    createDirs (dir:[])   = createDir dir throwIOIO+    createDirs (dir:[])   = createDir dir throwIO     createDirs (dir:dirs) =       createDir dir $ \_ -> do         createDirs dirs-        createDir dir throwIOIO+        createDir dir throwIO      createDir :: FilePath -> (IOException -> IO ()) -> IO ()     createDir dir notExistHandler = do@@ -754,9 +861,9 @@           | isAlreadyExistsError e -> (do               isDir <- doesDirectoryExist dir               if isDir then return ()-                       else throwIOIO e+                       else throwIO e               ) `catchIO` ((\_ -> return ()) :: IOException -> IO ())-          | otherwise              -> throwIOIO e+          | otherwise              -> throwIO e  createDirectoryVerbose :: Verbosity -> FilePath -> IO () createDirectoryVerbose verbosity dir = do@@ -792,6 +899,38 @@   info verbosity ("Installing executable " ++ src ++ " to " ++ dest)   copyExecutableFile src dest +-- | Install a file that may or not be executable, preserving permissions.+installMaybeExecutableFile :: Verbosity -> FilePath -> FilePath -> IO ()+installMaybeExecutableFile verbosity src dest = do+  perms <- getPermissions src+  if (executable perms) --only checks user x bit+    then installExecutableFile verbosity src dest+    else installOrdinaryFile   verbosity src dest++-- | Given a relative path to a file, copy it to the given directory, preserving+-- the relative path and creating the parent directories if needed.+copyFileTo :: Verbosity -> FilePath -> FilePath -> IO ()+copyFileTo verbosity dir file = do+  let targetFile = dir </> file+  createDirectoryIfMissingVerbose verbosity True (takeDirectory targetFile)+  installOrdinaryFile verbosity file targetFile++-- | Common implementation of 'copyFiles', 'installOrdinaryFiles',+-- 'installExecutableFiles' and 'installMaybeExecutableFiles'.+copyFilesWith :: (Verbosity -> FilePath -> FilePath -> IO ())+              -> Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()+copyFilesWith doCopy verbosity targetDir srcFiles = do++  -- Create parent directories for everything+  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles+  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs++  -- Copy all the files+  sequence_ [ let src  = srcBase   </> srcFile+                  dest = targetDir </> srcFile+               in doCopy verbosity src dest+            | (srcBase, srcFile) <- srcFiles ]+ -- | Copies a bunch of files to a target directory, preserving the directory -- structure in the target location. The target directories are created if they -- do not exist.@@ -814,32 +953,24 @@ -- anything goes wrong. -- copyFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-copyFiles verbosity targetDir srcFiles = do--  -- Create parent directories for everything-  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles-  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs--  -- Copy all the files-  sequence_ [ let src  = srcBase   </> srcFile-                  dest = targetDir </> srcFile-               in copyFileVerbose verbosity src dest-            | (srcBase, srcFile) <- srcFiles ]+copyFiles = copyFilesWith copyFileVerbose  -- | This is like 'copyFiles' but uses 'installOrdinaryFile'. -- installOrdinaryFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)] -> IO ()-installOrdinaryFiles verbosity targetDir srcFiles = do+installOrdinaryFiles = copyFilesWith installOrdinaryFile -  -- Create parent directories for everything-  let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles-  mapM_ (createDirectoryIfMissingVerbose verbosity True) dirs+-- | This is like 'copyFiles' but uses 'installExecutableFile'.+--+installExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]+                          -> IO ()+installExecutableFiles = copyFilesWith installExecutableFile -  -- Copy all the files-  sequence_ [ let src  = srcBase   </> srcFile-                  dest = targetDir </> srcFile-               in installOrdinaryFile verbosity src dest-            | (srcBase, srcFile) <- srcFiles ]+-- | This is like 'copyFiles' but uses 'installMaybeExecutableFile'.+--+installMaybeExecutableFiles :: Verbosity -> FilePath -> [(FilePath, FilePath)]+                               -> IO ()+installMaybeExecutableFiles = copyFilesWith installMaybeExecutableFile  -- | This installs all the files in a directory to a target location, -- preserving the directory layout. All the files are assumed to be ordinary@@ -851,6 +982,18 @@   srcFiles <- getDirectoryContentsRecursive srcDir   installOrdinaryFiles verbosity destDir [ (srcDir, f) | f <- srcFiles ] +-------------------+-- File permissions++-- | Like 'doesFileExist', but also checks that the file is executable.+doesExecutableExist :: FilePath -> IO Bool+doesExecutableExist f = do+  exists <- doesFileExist f+  if exists+    then do perms <- getPermissions f+            return (executable perms)+    else return False+ --------------------------------- -- Deprecated file copy functions @@ -873,15 +1016,33 @@ --------------------------- -- Temporary files and dirs +-- | Advanced options for 'withTempFile' and 'withTempDirectory'.+data TempFileOptions = TempFileOptions {+  optKeepTempFiles :: Bool  -- ^ Keep temporary files?+  }++defaultTempFileOptions :: TempFileOptions+defaultTempFileOptions = TempFileOptions { optKeepTempFiles = False }+ -- | Use a temporary filename that doesn't already exist. ---withTempFile :: FilePath -- ^ Temp dir to create the file in-             -> String   -- ^ File name template. See 'openTempFile'.-             -> (FilePath -> Handle -> IO a) -> IO a+withTempFile :: FilePath    -- ^ Temp dir to create the file in+                -> String   -- ^ File name template. See 'openTempFile'.+                -> (FilePath -> Handle -> IO a) -> IO a withTempFile tmpDir template action =+  withTempFileEx defaultTempFileOptions tmpDir template action++-- | A version of 'withTempFile' that additionally takes a 'TempFileOptions'+-- argument.+withTempFileEx :: TempFileOptions+                 -> FilePath -- ^ Temp dir to create the file in+                 -> String   -- ^ File name template. See 'openTempFile'.+                 -> (FilePath -> Handle -> IO a) -> IO a+withTempFileEx opts tmpDir template action =   Exception.bracket     (openTempFile tmpDir template)-    (\(name, handle) -> hClose handle >> removeFile name)+    (\(name, handle) -> do hClose handle+                           unless (optKeepTempFiles opts) $ removeFile name)     (uncurry action)  -- | Create and use a temporary directory.@@ -894,11 +1055,20 @@ -- The @tmpDir@ will be a new subdirectory of the given directory, e.g. -- @src/sdist.342@. ---withTempDirectory :: Verbosity -> FilePath -> String -> (FilePath -> IO a) -> IO a-withTempDirectory _verbosity targetDir template =+withTempDirectory :: Verbosity+                     -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectory verbosity targetDir template =+  withTempDirectoryEx verbosity defaultTempFileOptions targetDir template++-- | A version of 'withTempDirectory' that additionally takes a+-- 'TempFileOptions' argument.+withTempDirectoryEx :: Verbosity+                       -> TempFileOptions+                       -> FilePath -> String -> (FilePath -> IO a) -> IO a+withTempDirectoryEx _verbosity opts targetDir template =   Exception.bracket     (createTempDirectory targetDir template)-    (removeDirectoryRecursive)+    (unless (optKeepTempFiles opts) . removeDirectoryRecursive)  ----------------------------------- -- Safely reading and writing files@@ -936,6 +1106,7 @@ -- the same as the existing content then leave the file as is so that we do not -- update the file's modification time. --+-- NB: the file is assumed to be ASCII-encoded. rewriteFile :: FilePath -> String -> IO () rewriteFile path newContent =   flip catchIO mightNotExist $ do@@ -960,12 +1131,12 @@  -- |Package description file (/pkgname/@.cabal@) defaultPackageDesc :: Verbosity -> IO FilePath-defaultPackageDesc _verbosity = findPackageDesc currentDir+defaultPackageDesc _verbosity = tryFindPackageDesc currentDir  -- |Find a package description file in the given directory.  Looks for -- @.cabal@ files.-findPackageDesc :: FilePath    -- ^Where to look-                -> IO FilePath -- ^<pkgname>.cabal+findPackageDesc :: FilePath                    -- ^Where to look+                -> IO (Either String FilePath) -- ^<pkgname>.cabal findPackageDesc dir  = do files <- getDirectoryContents dir       -- to make sure we do not mistake a ~/.cabal/ dir for a <pkgname>.cabal@@ -976,20 +1147,24 @@                        , let (name, ext) = splitExtension file                        , not (null name) && ext == ".cabal" ]       case cabalFiles of-        []          -> noDesc-        [cabalFile] -> return cabalFile-        multiple    -> multiDesc multiple+        []          -> return (Left  noDesc)+        [cabalFile] -> return (Right cabalFile)+        multiple    -> return (Left  $ multiDesc multiple)    where-    noDesc :: IO a-    noDesc = die $ "No cabal file found.\n"-                ++ "Please create a package description file <pkgname>.cabal"+    noDesc :: String+    noDesc = "No cabal file found.\n"+             ++ "Please create a package description file <pkgname>.cabal" -    multiDesc :: [String] -> IO a-    multiDesc l = die $ "Multiple cabal files found.\n"-                    ++ "Please use only one of: "-                    ++ intercalate ", " l+    multiDesc :: [String] -> String+    multiDesc l = "Multiple cabal files found.\n"+                  ++ "Please use only one of: "+                  ++ intercalate ", " l +-- |Like 'findPackageDesc', but calls 'die' in case of error.+tryFindPackageDesc :: FilePath -> IO FilePath+tryFindPackageDesc dir = join . fmap (either die return) $ findPackageDesc dir+ -- |Optional auxiliary package information file (/pkgname/@.buildinfo@) defaultHookedPackageDesc :: IO (Maybe FilePath) defaultHookedPackageDesc = findHookedPackageDesc currentDir@@ -1132,9 +1307,6 @@  isInfixOf :: String -> String -> Bool isInfixOf needle haystack = any (isPrefixOf needle) (tails haystack)--intercalate :: [a] -> [[a]] -> [a]-intercalate sep = concat . intersperse sep  lowercase :: String -> String lowercase = map Char.toLower
cabal/Cabal/Distribution/System.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.System@@ -25,11 +26,15 @@   -- * Platform is a pair of arch and OS   Platform(..),   buildPlatform,+  platformFromTriple   ) where  import qualified System.Info (os, arch) import qualified Data.Char as Char (toLower, isAlphaNum) +import Data.Data (Data)+import Data.Typeable (Typeable)+import Data.Maybe (fromMaybe, listToMaybe) import Distribution.Text (Text(..), display) import qualified Distribution.Compat.ReadP as Parse import qualified Text.PrettyPrint as Disp@@ -58,12 +63,13 @@ -- * Operating System -- ------------------------------------------------------------ -data OS = Linux | Windows | OSX        -- teir 1 desktop OSs+data OS = Linux | Windows | OSX        -- tier 1 desktop OSs         | FreeBSD | OpenBSD | NetBSD   -- other free unix OSs         | Solaris | AIX | HPUX | IRIX  -- ageing Unix OSs         | HaLVM                        -- bare metal / VMs / hypervisors+        | IOS                          -- iOS         | OtherOS String-  deriving (Eq, Ord, Show, Read)+  deriving (Eq, Ord, Show, Read, Typeable, Data)  --TODO: decide how to handle Android and iOS. -- They are like Linux and OSX but with some differences.@@ -74,12 +80,14 @@ knownOSs = [Linux, Windows, OSX            ,FreeBSD, OpenBSD, NetBSD            ,Solaris, AIX, HPUX, IRIX-           ,HaLVM]+           ,HaLVM+           ,IOS]  osAliases :: ClassificationStrictness -> OS -> [String] osAliases Permissive Windows = ["mingw32", "cygwin32"] osAliases Compat     Windows = ["mingw32", "win32"] osAliases _          OSX     = ["darwin"]+osAliases _          IOS     = ["ios"] osAliases Permissive FreeBSD = ["kfreebsdgnu"] osAliases Permissive Solaris = ["solaris2"] osAliases _          _       = []@@ -92,9 +100,7 @@  classifyOS :: ClassificationStrictness -> String -> OS classifyOS strictness s =-  case lookup (lowercase s) osMap of-    Just os -> os-    Nothing -> OtherOS s+  fromMaybe (OtherOS s) $ lookup (lowercase s) osMap   where     osMap = [ (name, os)             | os <- knownOSs@@ -113,7 +119,7 @@           | Alpha | Hppa   | Rs6000           | M68k  | Vax           | OtherArch String-  deriving (Eq, Ord, Show, Read)+  deriving (Eq, Ord, Show, Read, Typeable, Data)  knownArches :: [Arch] knownArches = [I386, X86_64, PPC, PPC64, Sparc@@ -140,9 +146,7 @@  classifyArch :: ClassificationStrictness -> String -> Arch classifyArch strictness s =-  case lookup (lowercase s) archMap of-    Just arch -> arch-    Nothing   -> OtherArch s+  fromMaybe (OtherArch s) $ lookup (lowercase s) archMap   where     archMap = [ (name, arch)               | arch <- knownArches@@ -156,7 +160,7 @@ -- ------------------------------------------------------------  data Platform = Platform Arch OS-  deriving (Eq, Ord, Show, Read)+  deriving (Eq, Ord, Show, Read, Typeable, Data)  instance Text Platform where   disp (Platform arch os) = disp arch <> Disp.char '-' <> disp os@@ -166,6 +170,9 @@     os   <- parse     return (Platform arch os) +-- | The platform Cabal was compiled on. In most cases,+-- @LocalBuildInfo.hostPlatform@ should be used instead (the platform we're+-- targeting). buildPlatform :: Platform buildPlatform = Platform buildArch buildOS @@ -177,3 +184,16 @@  lowercase :: String -> String lowercase = map Char.toLower++platformFromTriple :: String -> Maybe Platform+platformFromTriple triple =+  fmap fst (listToMaybe $ Parse.readP_to_S parseTriple triple)+  where parseWord = Parse.munch1 (\c -> Char.isAlphaNum c || c == '_')+        parseTriple = do+          arch <- fmap (classifyArch Strict) parseWord+          _ <- Parse.char '-'+          _ <- parseWord -- Skip vendor+          _ <- Parse.char '-'+          os <- fmap (classifyOS Compat) ident -- OS may have hyphens, like+                                               -- 'nto-qnx'+          return $ Platform arch os
cabal/Cabal/Distribution/Version.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE CPP, DeriveDataTypeable, StandaloneDeriving #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Version@@ -68,6 +68,9 @@   foldVersionRange,   foldVersionRange', +  -- ** Modification+  removeUpperBound,+   -- * Version intervals view   asVersionIntervals,   VersionInterval,@@ -92,6 +95,7 @@   ) where +import Data.Data        ( Data ) import Data.Typeable    ( Typeable ) import Data.Version     ( Version(..) ) @@ -118,8 +122,13 @@   | UnionVersionRanges     VersionRange VersionRange   | IntersectVersionRanges VersionRange VersionRange   | VersionRangeParens     VersionRange -- just '(exp)' parentheses syntax-  deriving (Show,Read,Eq,Typeable)+  deriving (Show,Read,Eq,Typeable,Data) +#if __GLASGOW_HASKELL__ < 707+-- starting with ghc-7.7/base-4.7 this instance is provided in "Data.Data"+deriving instance Data Version+#endif+ {-# DEPRECATED AnyVersion "Use 'anyVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED ThisVersion "use 'thisVersion', 'foldVersionRange' or 'asVersionIntervals'" #-} {-# DEPRECATED LaterVersion "use 'laterVersion', 'foldVersionRange' or 'asVersionIntervals'" #-}@@ -229,9 +238,20 @@   IntersectVersionRanges (orLaterVersion v1) (orEarlierVersion v2)  {-# DEPRECATED betweenVersionsInclusive-    "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds"-  #-}+    "In practice this is not very useful because we normally use inclusive lower bounds and exclusive upper bounds" #-} +-- | Given a version range, remove the highest upper bound. Example: @(>= 1 && <+-- 3) || (>= 4 && < 5)@ is converted to @(>= 1 && < 3) || (>= 4)@.+removeUpperBound :: VersionRange -> VersionRange+removeUpperBound = fromVersionIntervals . relaxLastInterval . toVersionIntervals+  where+    relaxLastInterval (VersionIntervals intervals) =+      VersionIntervals (relaxLastInterval' intervals)++    relaxLastInterval' []      = []+    relaxLastInterval' [(l,_)] = [(l, NoUpperBound)]+    relaxLastInterval' (i:is)  = i : relaxLastInterval' is+ -- | Fold over the basic syntactic structure of a 'VersionRange'. -- -- This provides a syntacic view of the expression defining the version range.@@ -410,7 +430,7 @@ --  wildcardUpperBound :: Version -> Version-wildcardUpperBound (Version lowerBound ts) = (Version upperBound ts)+wildcardUpperBound (Version lowerBound ts) = Version upperBound ts   where     upperBound = init lowerBound ++ [last lowerBound + 1]
cabal/Cabal/Language/Haskell/Extension.hs view
@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveDataTypeable #-} ----------------------------------------------------------------------------- -- | -- Module      :  Language.Haskell.Extension@@ -53,6 +54,8 @@ import qualified Text.PrettyPrint as Disp import qualified Data.Char as Char (isAlphaNum) import Data.Array (Array, accumArray, bounds, Ix(inRange), (!))+import Data.Data (Data)+import Data.Typeable (Typeable)  -- ------------------------------------------------------------ -- * Language@@ -75,7 +78,7 @@    -- | An unknown language, identified by its name.   | UnknownLanguage String-  deriving (Show, Read, Eq)+  deriving (Show, Read, Eq, Typeable, Data)  knownLanguages :: [Language] knownLanguages = [Haskell98, Haskell2010]@@ -110,8 +113,7 @@ -- in some special mode. -- -- Where applicable, references are given to an implementation's--- official documentation, e.g. \"GHC &#xa7; 7.2.1\" for an extension--- documented in section 7.2.1 of the GHC User's Guide.+-- official documentation.  data Extension =   -- | Enable a known extension@@ -124,261 +126,399 @@   -- pragma.   | UnknownExtension String -  deriving (Show, Read, Eq)+  deriving (Show, Read, Eq, Typeable, Data)  data KnownExtension = -  -- | [GHC &#xa7; 7.6.3.4] Allow overlapping class instances,-  -- provided there is a unique most specific instance for each use.+  -- | Allow overlapping class instances, provided there is a unique+  -- most specific instance for each use.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>     OverlappingInstances -  -- | [GHC &#xa7; 7.6.3.3] Ignore structural rules guaranteeing the-  -- termination of class instance resolution.  Termination is-  -- guaranteed by a fixed-depth recursion stack, and compilation-  -- may fail if this depth is exceeded.+  -- | Ignore structural rules guaranteeing the termination of class+  -- instance resolution.  Termination is guaranteed by a fixed-depth+  -- recursion stack, and compilation may fail if this depth is+  -- exceeded.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#undecidable-instances>   | UndecidableInstances -  -- | [GHC &#xa7; 7.6.3.4] Implies 'OverlappingInstances'.  Allow the-  -- implementation to choose an instance even when it is possible-  -- that further instantiation of types will lead to a more specific-  -- instance being applicable.+  -- | Implies 'OverlappingInstances'.  Allow the implementation to+  -- choose an instance even when it is possible that further+  -- instantiation of types will lead to a more specific instance+  -- being applicable.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-overlap>   | IncoherentInstances -  -- | [GHC &#xa7; 7.3.8] Allows recursive bindings in @do@ blocks,-  -- using the @rec@ keyword.+  -- | /(deprecated)/ Allows recursive bindings in @do@ blocks, using the @rec@+  -- keyword. See also 'RecursiveDo'.   | DoRec -  -- | [GHC &#xa7; 7.3.8.2] Deprecated in GHC.  Allows recursive bindings-  -- using @mdo@, a variant of @do@.  @DoRec@ provides a different,-  -- preferred syntax.+  -- | Allows recursive bindings using @mdo@, a variant of @do@.+  -- @DoRec@ provides a different, preferred syntax.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#recursive-do-notation>   | RecursiveDo -  -- | [GHC &#xa7; 7.3.9] Provide syntax for writing list-  -- comprehensions which iterate over several lists together, like-  -- the 'zipWith' family of functions.+  -- | Provide syntax for writing list comprehensions which iterate+  -- over several lists together, like the 'zipWith' family of+  -- functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#parallel-list-comprehensions>   | ParallelListComp -  -- | [GHC &#xa7; 7.6.1.1] Allow multiple parameters in a type class.+  -- | Allow multiple parameters in a type class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#multi-param-type-classes>   | MultiParamTypeClasses -  -- | [GHC &#xa7; 7.17] Enable the dreaded monomorphism restriction.+  -- | Enable the dreaded monomorphism restriction.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html>   | MonomorphismRestriction -  -- | [GHC &#xa7; 7.6.2] Allow a specification attached to a-  -- multi-parameter type class which indicates that some parameters-  -- are entirely determined by others. The implementation will check-  -- that this property holds for the declared instances, and will use-  -- this property to reduce ambiguity in instance resolution.+  -- | Allow a specification attached to a multi-parameter type class+  -- which indicates that some parameters are entirely determined by+  -- others. The implementation will check that this property holds+  -- for the declared instances, and will use this property to reduce+  -- ambiguity in instance resolution.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#functional-dependencies>   | FunctionalDependencies -  -- | [GHC &#xa7; 7.8.5] Like 'RankNTypes' but does not allow a-  -- higher-rank type to itself appear on the left of a function-  -- arrow.+  -- | Like 'RankNTypes' but does not allow a higher-rank type to+  -- itself appear on the left of a function arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>   | Rank2Types -  -- | [GHC &#xa7; 7.8.5] Allow a universally-quantified type to occur on-  -- the left of a function arrow.+  -- | Allow a universally-quantified type to occur on the left of a+  -- function arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>   | RankNTypes -  -- | [GHC &#xa7; 7.8.5] Allow data constructors to have polymorphic-  -- arguments.  Unlike 'RankNTypes', does not allow this for ordinary-  -- functions.+  -- | Allow data constructors to have polymorphic arguments.  Unlike+  -- 'RankNTypes', does not allow this for ordinary functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#universal-quantification>   | PolymorphicComponents -  -- | [GHC &#xa7; 7.4.4] Allow existentially-quantified data constructors.+  -- | Allow existentially-quantified data constructors.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#existential-quantification>   | ExistentialQuantification -  -- | [GHC &#xa7; 7.8.7] Cause a type variable in a signature, which has an-  -- explicit @forall@ quantifier, to scope over the definition of the+  -- | Cause a type variable in a signature, which has an explicit+  -- @forall@ quantifier, to scope over the definition of the   -- accompanying value declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#scoped-type-variables>   | ScopedTypeVariables    -- | Deprecated, use 'ScopedTypeVariables' instead.   | PatternSignatures -  -- | [GHC &#xa7; 7.8.3] Enable implicit function parameters with dynamic-  -- scope.+  -- | Enable implicit function parameters with dynamic scope.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#implicit-parameters>   | ImplicitParams -  -- | [GHC &#xa7; 7.8.2] Relax some restrictions on the form of the context-  -- of a type signature.+  -- | Relax some restrictions on the form of the context of a type+  -- signature.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#flexible-contexts>   | FlexibleContexts -  -- | [GHC &#xa7; 7.6.3.2] Relax some restrictions on the form of the-  -- context of an instance declaration.+  -- | Relax some restrictions on the form of the context of an+  -- instance declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-rules>   | FlexibleInstances -  -- | [GHC &#xa7; 7.4.1] Allow data type declarations with no constructors.+  -- | Allow data type declarations with no constructors.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#nullary-types>   | EmptyDataDecls -  -- | [GHC &#xa7; 4.10.3] Run the C preprocessor on Haskell source code.+  -- | Run the C preprocessor on Haskell source code.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/options-phases.html#c-pre-processor>   | CPP -  -- | [GHC &#xa7; 7.8.4] Allow an explicit kind signature giving the kind of-  -- types over which a type variable ranges.+  -- | Allow an explicit kind signature giving the kind of types over+  -- which a type variable ranges.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#kinding>   | KindSignatures -  -- | [GHC &#xa7; 7.11] Enable a form of pattern which forces evaluation-  -- before an attempted match, and a form of strict @let@/@where@-  -- binding.+  -- | Enable a form of pattern which forces evaluation before an+  -- attempted match, and a form of strict @let@/@where@ binding.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bang-patterns.html>   | BangPatterns -  -- | [GHC &#xa7; 7.6.3.1] Allow type synonyms in instance heads.+  -- | Allow type synonyms in instance heads.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#flexible-instance-head>   | TypeSynonymInstances -  -- | [GHC &#xa7; 7.9] Enable Template Haskell, a system for compile-time+  -- | Enable Template Haskell, a system for compile-time   -- metaprogramming.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html>   | TemplateHaskell -  -- | [GHC &#xa7; 8] Enable the Foreign Function Interface.  In GHC,-  -- implements the standard Haskell 98 Foreign Function Interface-  -- Addendum, plus some GHC-specific extensions.+  -- | Enable the Foreign Function Interface.  In GHC, implements the+  -- standard Haskell 98 Foreign Function Interface Addendum, plus+  -- some GHC-specific extensions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html>   | ForeignFunctionInterface -  -- | [GHC &#xa7; 7.10] Enable arrow notation.+  -- | Enable arrow notation.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/arrow-notation.html>   | Arrows -  -- | [GHC &#xa7; 7.16] Enable generic type classes, with default instances-  -- defined in terms of the algebraic structure of a type.+  -- | /(deprecated)/ Enable generic type classes, with default instances defined in+  -- terms of the algebraic structure of a type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/generic-classes.html>   | Generics -  -- | [GHC &#xa7; 7.3.11] Enable the implicit importing of the module-  -- @Prelude@.  When disabled, when desugaring certain built-in syntax-  -- into ordinary identifiers, use whatever is in scope rather than the-  -- @Prelude@ -- version.+  -- | Enable the implicit importing of the module "Prelude".  When+  -- disabled, when desugaring certain built-in syntax into ordinary+  -- identifiers, use whatever is in scope rather than the "Prelude"+  -- -- version.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>   | ImplicitPrelude -  -- | [GHC &#xa7; 7.3.15] Enable syntax for implicitly binding local names-  -- corresponding to the field names of a record.  Puns bind specific-  -- names, unlike 'RecordWildCards'.+  -- | Enable syntax for implicitly binding local names corresponding+  -- to the field names of a record.  Puns bind specific names, unlike+  -- 'RecordWildCards'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-puns>   | NamedFieldPuns -  -- | [GHC &#xa7; 7.3.5] Enable a form of guard which matches a pattern and-  -- binds variables.+  -- | Enable a form of guard which matches a pattern and binds+  -- variables.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#pattern-guards>   | PatternGuards -  -- | [GHC &#xa7; 7.5.4] Allow a type declared with @newtype@ to use-  -- @deriving@ for any class with an instance for the underlying type.+  -- | Allow a type declared with @newtype@ to use @deriving@ for any+  -- class with an instance for the underlying type.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#newtype-deriving>   | GeneralizedNewtypeDeriving -  -- | [Hugs &#xa7; 7.1] Enable the \"Trex\" extensible records system.+  -- | Enable the \"Trex\" extensible records system.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/hugs-only.html#TREX>   | ExtensibleRecords -  -- | [Hugs &#xa7; 7.2] Enable type synonyms which are transparent in-  -- some definitions and opaque elsewhere, as a way of implementing -  -- abstract datatypes.+  -- | Enable type synonyms which are transparent in some definitions+  -- and opaque elsewhere, as a way of implementing abstract+  -- datatypes.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/restricted-synonyms.html>   | RestrictedTypeSynonyms -  -- | [Hugs &#xa7; 7.3] Enable an alternate syntax for string literals,+  -- | Enable an alternate syntax for string literals,   -- with string templating.+  --+  -- * <http://cvs.haskell.org/Hugs/pages/users_guide/here-documents.html>   | HereDocuments -  -- | [GHC &#xa7; 7.3.2] Allow the character @#@ as a postfix modifier on-  -- identifiers.  Also enables literal syntax for unboxed values.+  -- | Allow the character @#@ as a postfix modifier on identifiers.+  -- Also enables literal syntax for unboxed values.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#magic-hash>   | MagicHash -  -- | [GHC &#xa7; 7.7] Allow data types and type synonyms which are-  -- indexed by types, i.e. ad-hoc polymorphism for types.+  -- | Allow data types and type synonyms which are indexed by types,+  -- i.e. ad-hoc polymorphism for types.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-families.html>   | TypeFamilies -  -- | [GHC &#xa7; 7.5.2] Allow a standalone declaration which invokes the-  -- type class @deriving@ mechanism.+  -- | Allow a standalone declaration which invokes the type class+  -- @deriving@ mechanism.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#stand-alone-deriving>   | StandaloneDeriving -  -- | [GHC &#xa7; 7.3.1] Allow certain Unicode characters to stand for-  -- certain ASCII character sequences, e.g. keywords and punctuation.+  -- | Allow certain Unicode characters to stand for certain ASCII+  -- character sequences, e.g. keywords and punctuation.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#unicode-syntax>   | UnicodeSyntax -  -- | [GHC &#xa7; 8.1.1] Allow the use of unboxed types as foreign types,-  -- e.g. in @foreign import@ and @foreign export@.+  -- | Allow the use of unboxed types as foreign types, e.g. in+  -- @foreign import@ and @foreign export@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#id681687>   | UnliftedFFITypes -  -- | [GHC &#xa7; 7.4.3] Defer validity checking of types until after-  -- expanding type synonyms, relaxing the constraints on how synonyms-  -- may be used.+  -- | Enable interruptible FFI.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-interruptible>+  | InterruptibleFFI++  -- | Allow use of CAPI FFI calling convention (@foreign import capi@).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/ffi.html#ffi-capi>+  | CApiFFI++  -- | Defer validity checking of types until after expanding type+  -- synonyms, relaxing the constraints on how synonyms may be used.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#type-synonyms>   | LiberalTypeSynonyms -  -- | [GHC &#xa7; 7.4.2] Allow the name of a type constructor, type class,-  -- or type variable to be an infix operator.+  -- | Allow the name of a type constructor, type class, or type+  -- variable to be an infix operator.   | TypeOperators ---PArr -- not ready yet, and will probably be renamed to ParallelArrays--  -- | [GHC &#xa7; 7.3.16] Enable syntax for implicitly binding local names-  -- corresponding to the field names of a record.  A wildcard binds-  -- all unmentioned names, unlike 'NamedFieldPuns'.+  -- | Enable syntax for implicitly binding local names corresponding+  -- to the field names of a record.  A wildcard binds all unmentioned+  -- names, unlike 'NamedFieldPuns'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#record-wildcards>   | RecordWildCards    -- | Deprecated, use 'NamedFieldPuns' instead.   | RecordPuns -  -- | [GHC &#xa7; 7.3.14] Allow a record field name to be disambiguated-  -- by the type of the record it's in.+  -- | Allow a record field name to be disambiguated by the type of+  -- the record it's in.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#disambiguate-fields>   | DisambiguateRecordFields -  -- | [GHC &#xa7; 7.6.4] Enable overloading of string literals using a-  -- type class, much like integer literals.+  -- | Enable traditional record syntax (as supported by Haskell 98)+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#traditional-record-syntax>+  | TraditionalRecordSyntax++  -- | Enable overloading of string literals using a type class, much+  -- like integer literals.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-strings>   | OverloadedStrings -  -- | [GHC &#xa7; 7.4.6] Enable generalized algebraic data types, in-  -- which type variables may be instantiated on a per-constructor-  -- basis. Implies GADTSyntax.+  -- | Enable generalized algebraic data types, in which type+  -- variables may be instantiated on a per-constructor basis. Implies+  -- 'GADTSyntax'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt>   | GADTs    -- | Enable GADT syntax for declaring ordinary algebraic datatypes.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#gadt-style>   | GADTSyntax -  -- | [GHC &#xa7; 7.17.2] Make pattern bindings monomorphic.+  -- | Make pattern bindings monomorphic.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/monomorphism.html#id630981>   | MonoPatBinds -  -- | [GHC &#xa7; 7.8.8] Relax the requirements on mutually-recursive-  -- polymorphic functions.+  -- | Relax the requirements on mutually-recursive polymorphic+  -- functions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#typing-binds>   | RelaxedPolyRec -  -- | [GHC &#xa7; 2.4.5] Allow default instantiation of polymorphic-  -- types in more situations.+  -- | Allow default instantiation of polymorphic types in more+  -- situations.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/interactive-evaluation.html#extended-default-rules>   | ExtendedDefaultRules -  -- | [GHC &#xa7; 7.2.2] Enable unboxed tuples.+  -- | Enable unboxed tuples.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/primitives.html#unboxed-tuples>   | UnboxedTuples -  -- | [GHC &#xa7; 7.5.3] Enable @deriving@ for classes-  -- @Data.Typeable.Typeable@ and @Data.Generics.Data@.+  -- | Enable @deriving@ for classes 'Data.Typeable.Typeable' and+  -- 'Data.Generics.Data'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveDataTypeable -  -- | [GHC &#xa7; 7.6.1.3] Allow a class method's type to place-  -- additional constraints on a class type variable.+  -- | Enable @deriving@ for 'GHC.Generics.Generic' and 'GHC.Generics.Generic1'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>+  | DeriveGeneric++  -- | Enable support for default signatures.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-default-signatures>+  | DefaultSignatures++  -- | Allow type signatures to be specified in instance declarations.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#instance-sigs>+  | InstanceSigs++  -- | Allow a class method's type to place additional constraints on+  -- a class type variable.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#class-method-types>   | ConstrainedClassMethods -  -- | [GHC &#xa7; 7.3.18] Allow imports to be qualified by the package-  -- name the module is intended to be imported from, e.g.+  -- | Allow imports to be qualified by the package name the module is+  -- intended to be imported from, e.g.   --   -- > import "network" Network.Socket+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#package-imports>   | PackageImports -  -- | [GHC &#xa7; 7.8.6] Deprecated in GHC 6.12 and will be removed in-  -- GHC 7.  Allow a type variable to be instantiated at a+  -- | /(deprecated)/ Allow a type variable to be instantiated at a   -- polymorphic type.+  --+  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/other-type-extensions.html#impredicative-polymorphism>   | ImpredicativeTypes -  -- | [GHC &#xa7; 7.3.3] Change the syntax for qualified infix-  -- operators.+  -- | /(deprecated)/ Change the syntax for qualified infix operators.+  --+  -- * <http://www.haskell.org/ghc/docs/6.12.3/html/users_guide/syntax-extns.html#new-qualified-operators>   | NewQualifiedOperators -  -- | [GHC &#xa7; 7.3.12] Relax the interpretation of left operator-  -- sections to allow unary postfix operators.+  -- | Relax the interpretation of left operator sections to allow+  -- unary postfix operators.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#postfix-operators>   | PostfixOperators -  -- | [GHC &#xa7; 7.9.5] Enable quasi-quotation, a mechanism for defining-  -- new concrete syntax for expressions and patterns.+  -- | Enable quasi-quotation, a mechanism for defining new concrete+  -- syntax for expressions and patterns.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/template-haskell.html#th-quasiquotation>   | QuasiQuotes -  -- | [GHC &#xa7; 7.3.10] Enable generalized list comprehensions,-  -- supporting operations such as sorting and grouping.+  -- | Enable generalized list comprehensions, supporting operations+  -- such as sorting and grouping.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#generalised-list-comprehensions>   | TransformListComp -  -- | [GHC &#xa7; 7.3.6] Enable view patterns, which match a value by-  -- applying a function and matching on the result.+  -- | Enable monad comprehensions, which generalise the list+  -- comprehension syntax to work for any monad.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#monad-comprehensions>+  | MonadComprehensions++  -- | Enable view patterns, which match a value by applying a+  -- function and matching on the result.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#view-patterns>   | ViewPatterns    -- | Allow concrete XML syntax to be used in expressions and patterns,@@ -395,6 +535,8 @@    -- | Enables the use of tuple sections, e.g. @(, True)@ desugars into   -- @\x -> (x, True)@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#tuple-sections>   | TupleSections    -- | Allows GHC primops, written in C--, to be imported into a Haskell@@ -403,65 +545,167 @@    -- | Support for patterns of the form @n + k@, where @k@ is an   -- integer literal.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#n-k-patterns>   | NPlusKPatterns    -- | Improve the layout rule when @if@ expressions are used in a @do@   -- block.   | DoAndIfThenElse +  -- | Enable support for multi-way @if@-expressions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#multi-way-if>+  | MultiWayIf++  -- | Enable support lambda-@case@ expressions.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#lambda-case>+  | LambdaCase+   -- | Makes much of the Haskell sugar be desugared into calls to the   -- function with a particular name that is in scope.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#rebindable-syntax>   | RebindableSyntax    -- | Make @forall@ a keyword in types, which can be used to give the   -- generalisation explicitly.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#explicit-foralls>   | ExplicitForAll    -- | Allow contexts to be put on datatypes, e.g. the @Eq a@ in   -- @data Eq a => Set a = NilSet | ConsSet a (Set a)@.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/data-type-extensions.html#datatype-contexts>   | DatatypeContexts    -- | Local (@let@ and @where@) bindings are monomorphic.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#mono-local-binds>   | MonoLocalBinds -  -- | Enable @deriving@ for the @Data.Functor.Functor@ class.+  -- | Enable @deriving@ for the 'Data.Functor.Functor' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveFunctor -  -- | Enable @deriving@ for the @Data.Traversable.Traversable@ class.+  -- | Enable @deriving@ for the 'Data.Traversable.Traversable' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveTraversable -  -- | Enable @deriving@ for the @Data.Foldable.Foldable@ class.+  -- | Enable @deriving@ for the 'Data.Foldable.Foldable' class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#deriving-typeable>   | DeriveFoldable -  -- | Enable non-decreasing indentation for 'do' blocks.+  -- | Enable non-decreasing indentation for @do@ blocks.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/bugs-and-infelicities.html#infelicities-syntax>   | NondecreasingIndentation -  -- | [GHC &#xa7; 7.20.3] Allow imports to be qualified with a safe-  -- keyword that requires the imported module be trusted as according-  -- to the Safe Haskell definition of trust.+  -- | Allow imports to be qualified with a safe keyword that requires+  -- the imported module be trusted as according to the Safe Haskell+  -- definition of trust.   --   -- > import safe Network.Socket+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-imports>   | SafeImports -  -- | [GHC &#xa7; 7.20] Compile a module in the Safe, Safe Haskell-  -- mode -- a restricted form of the Haskell language to ensure-  -- type safety.+  -- | Compile a module in the Safe, Safe Haskell mode -- a restricted+  -- form of the Haskell language to ensure type safety.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>   | Safe -  -- | [GHC &#xa7; 7.20] Compile a module in the Trustworthy, Safe-  -- Haskell mode -- no restrictions apply but the module is marked-  -- as trusted as long as the package the module resides in is-  -- trusted.+  -- | Compile a module in the Trustworthy, Safe Haskell mode -- no+  -- restrictions apply but the module is marked as trusted as long as+  -- the package the module resides in is trusted.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>   | Trustworthy -  -- | [GHC &#xa7; 7.40] Allow type class/implicit parameter/equality-  -- constraints to be used as types with the special kind Constraint.-  -- Also generalise the (ctxt => ty) syntax so that any type of kind-  -- Constraint can occur before the arrow.+  -- | Compile a module in the Unsafe, Safe Haskell mode so that+  -- modules compiled using Safe, Safe Haskell mode can't import it.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/safe-haskell.html#safe-trust>+  | Unsafe++  -- | Allow type class/implicit parameter/equality constraints to be+  -- used as types with the special kind constraint.  Also generalise+  -- the @(ctxt => ty)@ syntax so that any type of kind constraint can+  -- occur before the arrow.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/constraint-kind.html>   | ConstraintKinds -  deriving (Show, Read, Eq, Enum, Bounded)+  -- | Enable kind polymorphism.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/kind-polymorphism.html>+  | PolyKinds +  -- | Enable datatype promotion.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/promotion.html>+  | DataKinds++  -- | Enable parallel arrays syntax (@[:@, @:]@) for /Data Parallel Haskell/.+  --+  -- * <http://www.haskell.org/haskellwiki/GHC/Data_Parallel_Haskell>+  | ParallelArrays++  -- | Enable explicit role annotations, like in (@data T a\@R@).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/roles.html>+  | RoleAnnotations++  -- | Enable overloading of list literals, arithmetic sequences and+  -- list patterns using the 'IsList' type class.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#overloaded-lists>+  | OverloadedLists++  -- | Enables case expressions that have no alternatives. Also applies to lambda-case expressions if they are enabled.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#empty-case>+  | EmptyCase++  -- | Triggers the generation of derived 'Typeable' instances for every+  -- datatype and type class declaration.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/deriving.html#auto-derive-typeable>+  | AutoDeriveTypeable++  -- | Desugars negative literals directly (without using negate).+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#negative-literals>+  | NegativeLiterals++  -- | Allows the use of floating literal syntax for all instances of 'Num', including 'Int' and 'Integer'.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#num-decimals>+  | NumDecimals++  -- | Enables support for type classes with no type parameter.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/type-class-extensions.html#nullary-type-classes>+  | NullaryTypeClasses++  -- | Enable explicit namespaces in module import/export lists.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/syntax-extns.html#explicit-namespaces>+  | ExplicitNamespaces++  -- | Allow the user to write ambiguous types, and the type inference engine to infer them.+  --+  -- * <http://www.haskell.org/ghc/docs/latest/html/users_guide/other-type-extensions.html#ambiguity>+  | AllowAmbiguousTypes++  deriving (Show, Read, Eq, Enum, Bounded, Typeable, Data)+ {-# DEPRECATED knownExtensions    "KnownExtension is an instance of Enum and Bounded, use those instead." #-} knownExtensions :: [KnownExtension]@@ -537,4 +781,3 @@     [ (head str, (str, extension))     | extension <- [toEnum 0 ..]     , let str = show extension ]-
cabal/Cabal/Makefile view
@@ -1,5 +1,5 @@ -VERSION=1.14.0+VERSION=1.18.1  #KIND=devel KIND=rc@@ -8,6 +8,7 @@ PREFIX=/usr/local HC=ghc GHCFLAGS=-Wall+SSH_USER=$USER  all: build @@ -71,7 +72,10 @@ users-guide: $(USERGUIDE_STAMP) doc/*.markdown $(USERGUIDE_STAMP): doc/*.markdown 	mkdir -p $(PANDOC_HTML_OUTDIR)-	for file in $^; do $(PANDOC) $(PANDOC_OPTIONS) --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; done+	for file in $^; do \+		[ $${file} != doc/index.markdown ] && TOC=--table-of-contents || TOC=; \+		$(PANDOC) $(PANDOC_OPTIONS) $${TOC} --from=markdown --to=html --output $(PANDOC_HTML_OUTDIR)/$$(basename $${file} .markdown).html $${file}; \+	done 	cp doc/$(PANDOC_HTML_CSS) $(PANDOC_HTML_OUTDIR)  docs: haddock users-guide@@ -112,7 +116,7 @@ 	cp -r dist/doc/html $(DISTLOC)/Cabal-$(VERSION)/doc/API 	cp -r dist/doc/users-guide $(DISTLOC)/Cabal-$(VERSION)/doc/ 	cp changelog $(DISTLOC)/Cabal-$(VERSION)/-	tar -C $(DISTLOC) -c Cabal-$(VERSION) -zf $(DISTLOC)/Cabal-$(VERSION).tar.gz+	tar -C $(DISTLOC) -czf $(DISTLOC)/Cabal-$(VERSION).tar.gz Cabal-$(VERSION) 	mv $(DISTLOC)/Cabal-$(VERSION)/doc $(DISTLOC)/ 	mv $(DISTLOC)/Cabal-$(VERSION)/changelog $(DISTLOC)/ 	rm -r $(DISTLOC)/Cabal-$(VERSION)/@@ -120,8 +124,8 @@ 	@echo "Release fileset prepared: $(DISTLOC)/"  release: $(DIST_STAMP)-	scp -r $(DISTLOC) haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION)-	ssh haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)'+	scp -r $(DISTLOC) $(SSH_USER)@haskell.org:/srv/web/haskell.org/cabal/release/cabal-$(VERSION)+	ssh $(SSH_USER)@haskell.org 'cd /srv/web/haskell.org/cabal/release && rm -f $(KIND) && ln -s cabal-$(VERSION) $(KIND)'  # tags...
cabal/Cabal/README view
@@ -21,8 +21,8 @@ then to get one you'd first need to install the Cabal library! To avoid this bootstrapping problem, you can install the Cabal library directly: -Installing as a user (no root or administer access)----------------------------------------------------+Installing as a user (no root or administrator access)+------------------------------------------------------      ghc --make Setup     ./Setup configure --user@@ -120,7 +120,7 @@  Please report bugs and wish-list items in our [bug tracker]. -[bug tracker]: http://hackage.haskell.org/trac/hackage/+[bug tracker]: https://github.com/haskell/cabal/issues   Your Help
+ cabal/Cabal/cabal.config view
@@ -0,0 +1,1 @@+ghc-options: -fno-ignore-asserts
cabal/Cabal/changelog view
@@ -216,7 +216,7 @@ 	* New field "build-tools" for tool dependencies 	* Improved c2hs support 	* Preprocessor output no longer clutters source dirs-	* Seperate "includes" and "install-includes" fields+	* Separate "includes" and "install-includes" fields 	* Makefile command to generate makefiles for building libs with GHC 	* New --docdir configure flag 	* Generic --with-prog --prog-args configure flags
cabal/Cabal/doc/Cabal.css view
@@ -1,3 +1,7 @@+body {+  max-width: 18cm;+}+ div {   font-family: sans-serif;   color: black;@@ -37,3 +41,9 @@ a:hover   { background: #FFFFA8 } a:active  { color:      #D00000 } a:visited { color:      #680098 }++h1 a:link, h2 a:link, h3 a:link, h4 a:link, h5 a:link, h6 a:link,+h1 a:visited, h2 a:visited, h3 a:visited, h4 a:visited, h5 a:visited, h6 a:visited {+  color: #005A9C;+  text-decoration: none+}
cabal/Cabal/doc/developing-packages.markdown view
@@ -1,5 +1,440 @@-% Cabal User Guide+% Cabal User Guide: Developing Cabal packages ++# Quickstart #+++Lets assume we have created a project directory and already have a+Haskell module or two.++Every project needs a name, we'll call this example "proglet".++~~~~~~~~~~~+$ cd proglet/+$ ls+Proglet.hs+~~~~~~~~~~~++It is assumed that (apart from external dependencies) all the files that+make up a package live under a common project root directory. This+simple example has all the project files in one directory, but most+packages will use one or more subdirectories. See section [TODO](#TODO)+for the standard practices for organising the files in your project+directory.++To turn this into a Cabal package we need two extra files in the+project's root directory:++ * `proglet.cabal`: containing package metadata and build information.++ * `Setup.hs`: usually containing a few standardized lines of code, but+   can be customized if necessary.++We can create both files manually or we can use `cabal init` to create+them for us.++### Using "cabal init" ###++The `cabal init` command is interactive. It asks us a number of+questions starting with the package name and version.++~~~~~~~~~~+$ cabal init+Package name [default "proglet"]? +Package version [default "0.1"]? +...+~~~~~~~~~~++It also asks questions about various other bits of package metadata. For+a package that you never intend to distribute to others, these fields can+be left blank.++One of the important questions is whether the package contains a library+or an executable. Libraries are collections of Haskell modules that can+be re-used by other Haskell libraries and programs, while executables+are standalone programs.++~~~~~~~~~~+What does the package build:+   1) Library+   2) Executable+Your choice?+~~~~~~~~~~++For the moment these are the only choices. For more complex packages+(e.g. a library and multiple executables or test suites) the `.cabal`+file can be edited afterwards.++Finally, `cabal init` creates the initial `proglet.cabal` and `Setup.hs`+files, and depending on your choice of license, a `LICENSE` file as well.++~~~~~~~~~~+Generating LICENSE...+Generating Setup.hs...+Generating proglet.cabal...++You may want to edit the .cabal file and add a Description field.+~~~~~~~~~~++As this stage the `proglet.cabal` is not quite complete and before you+are able to build the package you will need to edit the file and add+some build information about the library or executable.++### Editing the .cabal file ###++Load up the `.cabal` file in a text editor. The first part of the+`.cabal` file has the package metadata and towards the end of the file+you will find the `executable` or `library` section.++You will see that the fields that have yet to be filled in are commented+out. Cabal files use "`--`" Haskell-style comment syntax. (Note that+comments are only allowed on lines on their own. Trailing comments on+other lines are not allowed because they could be confused with program+options.)++If you selected earlier to create a library package then your `.cabal`+file will have a section that looks like this:++~~~~~~~~~~~~~~~~~+library+  exposed-modules:     Proglet+  -- other-modules:+  -- build-depends:+~~~~~~~~~~~~~~~~~++Alternatively, if you selected an executable then there will be a+section like:++~~~~~~~~~~~~~~~~~+executable proglet+  -- main-is:+  -- other-modules:+  -- build-depends:+~~~~~~~~~~~~~~~~~++The build information fields listed (but commented out) are just the few+most important and common fields. There are many others that are covered+later in this chapter.++Most of the build information fields are the same between libraries and+executables. The difference is that libraries have a number of "exposed"+modules that make up the public interface of the library, while+executables have a file containing a `Main` module.++The name of a library always matches the name of the package, so it is+not specified in the library section. Executables often follow the name+of the package too, but this is not required and the name is given+explicitly.++### Modules included in the package ###++For a library, `cabal init` looks in the project directory for files+that look like Haskell modules and adds all the modules to the+`exposed-modules` field. For modules that do not form part of your+package's public interface, you can move those modules to the+`other-modules` field. Either way, all modules in the library need to be+listed.++For an executable, `cabal init` does not try to guess which file+contains your program's `Main` module. You will need to fill in the+`main-is` field with the file name of your program's `Main` module+(including `.hs` or `.lhs` extension). Other modules included in the+executable should be listed in the `other-modules` field.++### Modules imported from other packages ###++While your library or executable may include a number of modules, it+almost certainly also imports a number of external modules from the+standard libraries or other pre-packaged libraries. (These other+libraries are of course just Cabal packages that contain a library.)++You have to list all of the library packages that your library or+executable imports modules from. Or to put it another way: you have to+list all the other packages that your package depends on.++For example, suppose the example `Proglet` module imports the module+`Data.Map`. The `Data.Map` module comes from the `containers` package,+so we must list it:++~~~~~~~~~~~~~~~~~+library+  exposed-modules:     Proglet+  other-modules:+  build-depends:       containers, base == 4.*+~~~~~~~~~~~~~~~~~++In addition, almost every package also depends on the `base` library+package because it exports the standard `Prelude` module plus other+basic modules like `Data.List`.++You will notice that we have listed `base == 4.*`. This gives a+constraint on the version of the base package that our package will work+with. The most common kinds of constraints are:++ * `pkgname >= n`+ * `pkgname >= n && < m`+ * `pkgname == n.*`++The last is just shorthand, for example `base == 4.*` means exactly the+same thing as `base >= 4 && < 5`.++### Building the package ###++For simple packages that's it! We can now try configuring and building+the package:++~~~~~~~~~~~~~~~~+cabal configure+cabal build+~~~~~~~~~~~~~~~~++Assuming those two steps worked then you can also install the package:++~~~~~~~~~~~~~~~~+cabal install+~~~~~~~~~~~~~~~~++For libraries this makes them available for use in GHCi or to be used by+other packages. For executables it installs the program so that you can+run it (though you may first need to adjust your system's `$PATH`).++### Next steps ###++What we have covered so far should be enough for very simple packages+that you use on your own system.++The next few sections cover more details needed for more complex+packages and details needed for distributing packages to other people.++The previous chapter covers building and installing packages -- your own+packages or ones developed by other people.+++# Package concepts #++Before diving into the details of writing packages it helps to+understand a bit about packages in the Haskell world and the particular+approach that Cabal takes.++### The point of packages ###++Packages are a mechanism for organising and distributing code. Packages+are particularly suited for "programming in the large", that is building+big systems by using and re-using code written by different people at+different times.++People organise code into packages based on functionality and+dependencies. Social factors are also important: most packages have a+single author, or a relatively small team of authors.++Packages are also used for distribution: the idea is that a package can+be created in one place and be moved to a different computer and be+usable in that different environment. There are a surprising number of+details that have to be got right for this to work, and a good package+system helps to simply this process and make it reliable.++Packages come in two main flavours: libraries of reusable code, and+complete programs. Libraries present a code interface, an API, while+programs can be run directly. In the Haskell world, library packages+expose a set of Haskell modules as their public interface. Cabal+packages can contain a library or executables or both.++Some programming languages have packages as a builtin language concept.+For example in Java, a package provides a local namespace for types and+other definitions. In the Haskell world, packages are not a part of the+language itself. Haskell programs consist of a number of modules, and+packages just provide a way to partition the modules into sets of+related functionality. Thus the choice of module names in Haskell is+still important, even when using packages.++### Package names and versions ###++All packages have a name, e.g. "HUnit". Package names are assumed to be+unique. Cabal package names can use letters, numbers and hyphens, but+not spaces. The namespace for Cabal packages is flat, not hierarchical.++Packages also have a version, e.g "1.1". This matches the typical way in+which packages are developed. Strictly speaking, each version of a+package is independent, but usually they are very similar. Cabal package+versions follow the conventional numeric style, consisting of a sequence+of digits such as "1.0.1" or "2.0". There are a range of common+conventions for "versioning" packages, that is giving some meaning to+the version number in terms of changes in the package. Section [TODO]+has some tips on package versioning.++The combination of package name and version is called the _package ID_+and is written with a hyphen to separate the name and version, e.g.+"HUnit-1.1". ++For Cabal packages, the combination of the package name and version+_uniquely_ identifies each package. Or to put it another way: two+packages with the same name and version are considered to _be_ the same.++Strictly speaking, the package ID only identifies each Cabal _source_+package; the same Cabal source package can be configured and built in+different ways. There is a separate installed package ID that uniquely+identifies each installed package instance. Most of the time however,+users need not be aware of this detail.++### Kinds of package: Cabal vs GHC vs system ###++It can be slightly confusing at first because there are various+different notions of package floating around. Fortunately the details+are not very complicated.++Cabal packages+:   Cabal packages are really source packages. That is they contain+    Haskell (and sometimes C) source code.+    +    Cabal packages can be compiled to produce GHC packages. They can+    also be translated into operating system packages.++GHC packages+:   This is GHC's view on packages. GHC only cares about library+    packages, not executables. Library packages have to be registered+    with GHC for them to be available in GHCi or to be used when+    compiling other programs or packages.+    +    The low-level tool `ghc-pkg` is used to register GHC packages and to+    get information on what packages are currently registered.+    +    You never need to make GHC packages manually. When you build and+    install a Cabal package containing a library then it gets registered+    with GHC automatically.+    +    Haskell implementations other than GHC have essentially the same+    concept of registered packages. For the most part, Cabal hides the+    slight differences.++Operating system packages+:   On operating systems like Linux and Mac OS X, the system has a+    specific notion of a package and there are tools for installing and+    managing packages.+    +    The Cabal package format is designed to allow Cabal packages to be+    translated, mostly-automatically, into operating system packages.+    They are usually translated 1:1, that is a single Cabal package+    becomes a single system package.+    +    It is also possible to make Windows installers from Cabal packages,+    though this is typically done for a program together with all of its+    library dependencies, rather than packaging each library separately.+++### Unit of distribution ###++The Cabal package is the unit of distribution. What this means is that+each Cabal package can be distributed on its own in source or binary+form. Of course there may dependencies between packages, but there is+usually a degree of flexibility in which versions of packages can work+together so distributing them independently makes sense.++It is perhaps easiest to see what being ``the unit of distribution''+means by contrast to an alternative approach. Many projects are made up+of several interdependent packages and during development these might+all be kept under one common directory tree and be built and tested+together. When it comes to distribution however, rather than+distributing them all together in a single tarball, it is required that+they each be distributed independently in their own tarballs.++Cabal's approach is to say that if you can specify a dependency on a+package then that package should be able to be distributed+independently. Or to put it the other way round, if you want to+distribute it as a single unit, then it should be a single package.+++### Explicit dependencies and automatic package management ###++Cabal takes the approach that all packages dependencies are specified+explicitly and specified in a declarative way. The point is to enable+automatic package management. This means tools like `cabal` can resolve+dependencies and install a package plus all of its dependencies+automatically. Alternatively, it is possible to mechanically (or mostly+mechanically) translate Cabal packages into system packages and let the+system package managager install dependencies automatically.++It is important to track dependencies accurately so that packages can+reliably be moved from one system to another system and still be able to+build it there. Cabal is therefore relatively strict about specifying+dependencies. For example Cabal's default build system will not even let+code build if it tries to import a module from a package that isn't+listed in the `.cabal` file, even if that package is actually installed.+This helps to ensure that there are no "untracked dependencies" that+could cause the code to fail to build on some other system.++The explicit dependency approach is in contrast to the traditional+"./configure" approach where instead of specifying dependencies+declarativly, the `./configure` script checks if the dependencies are+present on the system. Some manual work is required to transform a+`./configure` based package into a Linux distribution package (or+similar). This conversion work is usually done by people other than the+package author(s). The practical effect of this is that only the most+popular packages will benefit from automatic package managment. Instead,+Cabal forces the original author to specify the dependencies but the+advantage is that every package can benefit from automatic package+managment.++The "./configure" approach tends to encourage packages that adapt+themselves to the environment in which they are built, for example by+disabling optional features so that they can continue to work when a+particular dependency is not available. This approach makes sense in a+world where installing additional dependencies is a tiresome manual+process and so minimising dependencies is important. The automatic+package managment view is that packages should just declare what they+need and the package manager will take responsibility for ensuring that+all the dependencies are installed.++Sometimes of course optional features and optional dependencies do make+sense. Cabal packages can have optional features and varying+dependencies. These conditional dependencies are still specified in a+declarative way however and remain compatible with automatic package+management. The need to remain compatible with automatic package+management means that Cabal's conditional dependencies system is a bit+less flexible than with the "./configure" approach.++### Portability ###++One of the purposes of Cabal is to make it easier to build packages on+different platforms (operating systems and CPU architectures), with+different compiler versions and indeed even with different Haskell+implementations. (Yes, there are Haskell implementations other than+GHC!)++Cabal provides abstractions of features present in different Haskell+implementations and wherever possible it is best to take advantage of+these to increase portability. Where necessary however it is possible to+use specific features of specific implementations.++For example a package author can list in the package's `.cabal` what+language extensions the code uses. This allows Cabal to figure out if+the language extension is supported by the Haskell implementation that+the user picks. Additionally, certain language extensions such as+Template Haskell require special handling from the build system and by+listing the extension it provides the build system with enough+information to do the right thing.++Another similar example is linking with foreign libraries. Rather than+specifying GHC flags directly, the package author can list the libraries+that are needed and the build system will take care of using the right+flags for the compiler. Additionally this makes it easier for tools to+discover what system C libraries a package needs, which is useful for+tracking dependencies on system libraries (e.g. when translating into+linux distro packages).++In fact both of these examples fall into the category of explicitly+specifying dependencies. Not all dependencies are other Cabal packages.+Foreign libraries are clearly another kind of dependency. It's also+possible to think of language extensions as dependencies: the package+depends on a Haskell implementation that supports all those extensions.++Where compiler-specific options are needed however, there is an "escape+hatch" available. The developer can specify implementation-specific+options and more generally there is a configuration mechanism to+customise many aspects of how a package is built depending on the+Haskell implementation, the operating system, computer architecture and+user-specified configuration flags.++ # Developing packages #  The Cabal package is the unit of distribution. When installed, its@@ -37,6 +472,7 @@ from separate packages; in all other current Haskell systems packages may not overlap in the modules they provide, including hidden modules. + ## Creating a package ##  Suppose you have a directory hierarchy containing the source files that@@ -55,9 +491,10 @@     the interface described in the section on [building and installing     packages](#building-and-installing-a-package)). This module should     import only modules that will be present in all Haskell-    implementations, including modules of the Cabal library.  In most-    cases it will be trivial, calling on the Cabal library to do most of-    the work.+    implementations, including modules of the Cabal library. The+    content of this file is determined by the `build-type` setting in+    the `.cabal` file. In most cases it will be trivial, calling on+    the Cabal library to do most of the work.  Once you have these, you can create a source bundle of this directory for distribution. Building of the package is discussed in the section on@@ -275,8 +712,8 @@ When building, Cabal will automatically run the appropriate preprocessor and compile the Haskell module it produces. -Some fields take lists of values, which are optionally separated by commas, except for the-`build-depends` field, where the commas are mandatory.+Some fields take lists of values, which are optionally separated by commas,+except for the `build-depends` field, where the commas are mandatory.  Some fields are marked as required.  All others are optional, and unless otherwise specified have empty default values.@@ -329,12 +766,45 @@  `build-type:` _identifier_ :   The type of build used by this package. Build types are the-    constructors of the [BuildType][] type, defaulting to `Custom`. If-    this field is given a value other than `Custom`, some tools such as-    `cabal-install` will be able to build the package without using the-    setup script. So if you are just using the default `Setup.hs` then-    set the build type as `Simple`.+    constructors of the [BuildType][] type, defaulting to `Custom`. +    If the build type is anything other than `Custom`, then the+    `Setup.hs` file *must* be exactly the standardized content+    discussed below. This is because in these cases, `cabal` will+    ignore the `Setup.hs` file completely, whereas other methods of+    package management, such as `runhaskell Setup.hs [CMD]`, still+    rely on the `Setup.hs` file.++    For build type `Simple`, the contents of `Setup.hs` must be:++    ~~~~~~~~~~~~~~~~+    import Distribution.Simple+    main = defaultMain+    ~~~~~~~~~~~~~~~~++    For build type `Configure` (see the section on [system-dependent+    parameters](#system-dependent-parameters) below), the contents of+    `Setup.hs` must be:++    ~~~~~~~~~~~~~~~~+    import Distribution.Simple+    main = defaultMainWithHooks autoconfUserHooks+    ~~~~~~~~~~~~~~~~++    For build type `Make` (see the section on [more complex+    packages](#more-complex-packages) below), the contents of+    `Setup.hs` must be:++    ~~~~~~~~~~~~~~~~+    import Distribution.Make+    main = defaultMain+    ~~~~~~~~~~~~~~~~++    For build type `Custom`, the file `Setup.hs` can be customized,+    and will be used both by `cabal` and other tools.++    For most packages, the build type `Simple` is sufficient.+ `license:` _identifier_ (default: `AllRightsReserved`) :   The type of license under which this package is distributed.     License names are the constants of the [License][dist-license] type.@@ -440,6 +910,12 @@     built with [`setup sdist`](#setup-sdist). As with `data-files` it     can use a limited form of `*` wildcards in file names. +`extra-doc-files:` _filename list_+:   A list of additional files to be included in source distributions,+    and also copied to the html directory when Haddock documentation is+    generated. As with `data-files` it can use a limited form of `*`+    wildcards in file names.+ `extra-tmp-files:` _filename list_ :   A list of additional files or directories to be removed by [`setup     clean`](#setup-clean). These would typically be additional files@@ -470,7 +946,43 @@ The library section may also contain build information fields (see the section on [build information](#build-information)). +#### Opening an interpreter session #### +While developing a package, it is often useful to make its code available inside+an interpreter session. This can be done with the `repl` command:++~~~~~~~~~~~~~~~~+cabal repl+~~~~~~~~~~~~~~~~++The name comes from the acronym [REPL], which stands for+"read-eval-print-loop". By default `cabal repl` loads the first component in a+package. If the package contains several named components, the name can be given+as an argument to `repl`. The name can be also optionally prefixed with the+component's type for disambiguation purposes. Example:++~~~~~~~~~~~~~~~~+cabal repl foo+cabal repl exe:foo+cabal repl test:bar+cabal repl bench:baz+~~~~~~~~~~~~~~~~++#### Freezing dependency versions ####++If a package is built in several different environments, such as a development+environment, a staging environment and a production environment, it may be+necessary or desirable to ensure that the same dependency versions are+selected in each environment. This can be done with the `freeze` command:++~~~~~~~~~~~~~~~~+cabal freeze+~~~~~~~~~~~~~~~~++The command writes the selected version for all dependencies to the+`cabal.config` file.  All environments which share this file will use the+dependency versions specified in it.+ ### Executables ###  Executable sections (if present) describe executable programs contained@@ -488,6 +1000,21 @@     using a preprocessor. The source file must be relative to one of the     directories listed in `hs-source-dirs`. +#### Running executables ####++You can have Cabal build and run your executables by using the `run` command:++~~~~~~~~~~~~~~~~+$ cabal run EXECUTABLE [-- EXECUTABLE_FLAGS]+~~~~~~~~~~~~~~~~++This command will configure, build and run the executable `EXECUTABLE`. The+double dash separator is required to distinguish executable flags from `run`'s+own flags. If there is only one executable defined in the whole package, the+executable's name can be omitted. See the output of `cabal help run` for a list+of options you can pass to `cabal run`.++ ### Test suites ###  Test suite sections (if present) describe package test suites and must have an@@ -653,8 +1180,8 @@ channels.  `main-is:` _filename_ (required: `exitcode-stdio-1.0`)-:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that it is the-    `.hs` filename that must be listed, even if that file is generated+:   The name of the `.hs` or `.lhs` file containing the `Main` module. Note that+    it is the `.hs` filename that must be listed, even if that file is generated     using a preprocessor. The source file must be relative to one of the     directories listed in `hs-source-dirs`.  This field is analogous to the     `main-is` field of an executable section.@@ -1272,6 +1799,27 @@     This field is optional. It default to empty which corresponds to the     root directory of the repository. +### Downloading a package's source ###++The `cabal get` command allows to access a package's source code - either by+unpacking a tarball downloaded from Hackage (the default) or by checking out a+working copy from the package's source repository.++~~~~~~~~~~~~~~~~+$ cabal get [FLAGS] PACKAGES+~~~~~~~~~~~~~~~~++The `get` command supports the following options:++`-d --destdir` _PATH_+:   Where to place the package source, defaults to (a subdirectory of) the+    current directory.++`-s --source-repository` _[head|this|...]_+:   Fork the package's source repository using the appropriate version control+    system. The optional argument allows to choose a specific repo kind.++ ## Accessing data files from package code ##  The placement on the target system of files listed in the `data-files`@@ -1309,19 +1857,18 @@  For some packages, especially those interfacing with C libraries, implementation details and the build procedure depend on the build-environment.  A variant of the simple build infrastructure (the-`build-type` `Configure`) handles many such situations using a slightly-longer `Setup.hs`:+environment. The `build-type` `Configure` can be used to handle many+such situations. In this case, `Setup.hs` should be:  ~~~~~~~~~~~~~~~~ import Distribution.Simple main = defaultMainWithHooks autoconfUserHooks ~~~~~~~~~~~~~~~~ -Most packages, however, would probably do better with-[configurations](#configurations).+Most packages, however, would probably do better using the `Simple`+build type and [configurations](#configurations). -This program differs from `defaultMain` in two ways:+The `build-type` `Configure` differs from `Simple` in two ways:  * The package root directory must contain a shell script called   `configure`. The configure step will run the script. This `configure`@@ -1409,26 +1956,39 @@ ld-options:  -L/usr/X11R6/lib ~~~~~~~~~~~~~~~~ -The `configure` script also generates a header file-`include/HsX11Config.h` containing C preprocessor defines recording the-results of various tests.  This file may be included by C source files-and preprocessed Haskell source files in the package.+The `configure` script also generates a header file `include/HsX11Config.h`+containing C preprocessor defines recording the results of various tests.  This+file may be included by C source files and preprocessed Haskell source files in+the package. -Note: Packages using these features will also need to list-additional files such as `configure`,-templates for `.buildinfo` files, files named-only in `.buildinfo` files, header files and-so on in the `extra-source-files` field,-to ensure that they are included in source distributions.-They should also list files and directories generated by-`configure` in the-`extra-tmp-files` field to ensure that they-are removed by `setup clean`.+Note: Packages using these features will also need to list additional files such+as `configure`, templates for `.buildinfo` files, files named only in+`.buildinfo` files, header files and so on in the `extra-source-files` field to+ensure that they are included in source distributions.  They should also list+files and directories generated by `configure` in the `extra-tmp-files` field to+ensure that they are removed by `setup clean`. +Quite often the files generated by `configure` need to be listed somewhere in+the package description (for example, in the `install-includes` field). However,+we usually don't want generated files to be included in the source tarball. The+solution is again provided by the `.buildinfo` file. In the above example, the+following line should be added to `X11.buildinfo`:++~~~~~~~~~~~~~~~~+install-includes: HsX11Config.h+~~~~~~~~~~~~~~~~++In this way, the generated `HsX11Config.h` file won't be included in the source+tarball in addition to `HsX11Config.h.in`, but it will be copied to the right+location during the install process. Packages that use custom `Setup.hs` scripts+can update the necessary fields programmatically instead of using the+`.buildinfo` file.++ ## Conditional compilation ##  Sometimes you want to write code that works with more than one version-of a dependency.  You can specify a range of versions for the depenency+of a dependency.  You can specify a range of versions for the dependency in the `build-depends`, but how do you then write the code that can use different versions of the API? @@ -1455,28 +2015,49 @@ lexicographic on the sequence, but numeric on each component, so for example 1.2.0 is greater than 1.0.3). +Since version 1.20, there is also the `MIN_TOOL_VERSION_`_`tool`_ family of+macros for conditioning on the version of build tools used to build the program+(e.g. `hsc2hs`).+ Cabal places the definitions of these macros into an automatically-generated header file, which is included when preprocessing Haskell source code by passing options to the C preprocessor. +Cabal also allows to detect when the source code is being used for generating+documentation. The `__HADDOCK_VERSION__` macro is defined only when compiling+via [haddock][] instead of a normal Haskell compiler. The value of the+`__HADDOCK_VERSION__` macro is defined as `A*1000 + B*10 + C`, where `A.B.C` is+the Haddock version. This can be useful for working around bugs in Haddock or+generating prettier documentation in some special cases.+ ## More complex packages ##  For packages that don't fit the simple schemes described above, you have a few options: -  * You can customize the simple build infrastructure using _hooks_.-    These allow you to perform additional actions before and after each-    command is run, and also to specify additional preprocessors.  See-    `UserHooks` in [Distribution.Simple][dist-simple] for the details,-    but note that this interface is experimental, and likely to change-    in future releases.+  * By using the `build-type` `Custom`, you can supply your own+    `Setup.hs` file, and customize the simple build infrastructure+    using _hooks_.  These allow you to perform additional actions+    before and after each command is run, and also to specify+    additional preprocessors. A typical `Setup.hs` may look like this: +    ~~~~~~~~~~~~~~~~+    import Distribution.Simple+    main = defaultMainWithHooks simpleUserHooks { postHaddock = posthaddock }++    posthaddock args flags desc info = ....+    ~~~~~~~~~~~~~~~~++    See `UserHooks` in [Distribution.Simple][dist-simple] for the+    details, but note that this interface is experimental, and likely+    to change in future releases.+   * You could delegate all the work to `make`, though this is unlikely     to be very portable. Cabal supports this with the `build-type`     `Make` and a trivial setup library [Distribution.Make][dist-make],     which simply parses the command line arguments and invokes `make`.-    Here `Setup.hs` looks like+    Here `Setup.hs` should look like this:      ~~~~~~~~~~~~~~~~     import Distribution.Make@@ -1489,12 +2070,11 @@     `unregister`, `clean`, `dist` and `docs`. Some options to commands     are passed through as follows: -      * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`,-        `--datadir` and `--libexecdir` options to the `configure`-        command are passed on to the `configure` script. In addition the-        value of the `--with-compiler` option is passed in a `--with-hc`-        option and all options specified with `--configure-option=` are-        passed on.+      * The `--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir`,+        `--libexecdir` and `--sysconfdir` options to the `configure` command are+        passed on to the `configure` script. In addition the value of the+        `--with-compiler` option is passed in a `--with-hc` option and all+        options specified with `--configure-option=` are passed on.        * The `--destdir` option to the `copy` command becomes a setting         of a `destdir` variable on the invocation of `make copy`. The@@ -1507,14 +2087,16 @@                                 bindir=$(destdir)/$(bindir) \                                 libdir=$(destdir)/$(libdir) \                                 datadir=$(destdir)/$(datadir) \-                                libexecdir=$(destdir)/$(libexecdir)+                                libexecdir=$(destdir)/$(libexecdir) \+                                sysconfdir=$(destdir)/$(sysconfdir) \         ~~~~~~~~~~~~~~~~ -  * You can write your own setup script conforming to the interface+  * Finally, with the `build-type` `Custom`, you can also write your+    own setup script from scratch. It must conform to the interface     described in the section on [building and installing-    packages](#building-and-installing-a-package), possibly using the-    Cabal library for part of the work.  One option is to copy the-    source of `Distribution.Simple`, and alter it for your needs.+    packages](#building-and-installing-a-package), and you may use the+    Cabal library for all or part of the work.  One option is to copy+    the source of `Distribution.Simple`, and alter it for your needs.     Good luck.  @@ -1535,3 +2117,4 @@ [happy]:      http://www.haskell.org/happy/ [Hackage]:    http://hackage.haskell.org/ [pkg-config]: http://pkg-config.freedesktop.org/+[REPL]:       http://en.wikipedia.org/wiki/Read%E2%80%93eval%E2%80%93print_loop
cabal/Cabal/doc/index.markdown view
@@ -1,83 +1,49 @@ % Cabal User Guide -Cabal is package system for [Haskell] software.--Cabal specifies a standard way in which Haskell libraries and-applications can be packaged so that it is easy for consumers to use-them, or re-package them, regardless of the Haskell implementation or-installation platform.+Cabal is the standard package system for [Haskell] software. It helps+people to configure, build and install Haskell software and to+distribute it easily to other users and developers. -Cabal defines a common interface -- the _Cabal package_ -- between-package authors, builders and users. There is a library to help package-authors implement this interface, and a tool to enable developers,-builders and users to work with Cabal packages.+There is a command line tool called `cabal` for working with Cabal+packages. It helps with installing existing packages and also helps+people developing their own packages. It can be used to work with local+packages or to install packages from online package archives, including+automatically installing dependencies. By default it is configured to+use [Hackage] which is Haskell's central package archive that contains+thousands of libraries and applications in the Cabal package format.  # Contents #    * [Introduction](#introduction)       - [What's in a package](#whats-in-a-package)       - [A tool for working with packages](#a-tool-for-working-with-packages)-  * [Developing packages](developing-packages.html)-      - [Package descriptions](developing-packages.html#package-descriptions)-          + [Package properties](developing-packages.html#package-properties)-          + [Library](developing-packages.html#library)-          + [Executables](developing-packages.html#executables)-          + [Test suites](developing-packages.html#test-suites)-          + [Build information](developing-packages.html#build-information)-          + [Configurations](developing-packages.html#configurations)-          + [Source Repositories](developing-packages.html#source-repositories)-      - [Accessing data files from package code](developing-packages.html#accessing-data-files-from-package-code)-          + [Accessing the package version](developing-packages.html#accessing-the-package-version)-      - [System-dependent parameters](developing-packages.html#system-dependent-parameters)-      - [Conditional compilation](developing-packages.html#conditional-compilation)-      - [More complex packages](developing-packages.html#more-complex-packages)-  * [Building and installing packages](installing-packages.html)-      - [Building and installing a system package](installing-packages.html#building-and-installing-a-system-package)-      - [Building and installing a user package](installing-packages.html#building-and-installing-a-user-package)-      - [Creating a binary package](installing-packages.html#creating-a-binary-package)-      - [setup configure](installing-packages.html#setup-configure)-          + [Programs used for building](installing-packages.html#programs-used-for-building)-          + [Installation paths](installing-packages.html#installation-paths)-          + [Controlling Flag Assignments](installing-packages.html#controlling-flag-assignments)-          + [Building Test Suites](installing-packages.html#building-test-suites)-          + [Miscellaneous options](installing-packages.html#miscellaneous-options)-      - [setup build](installing-packages.html#setup-build)-      - [setup haddock](installing-packages.html#setup-haddock)-      - [setup hscolour](installing-packages.html#setup-hscolour)-      - [setup install](installing-packages.html#setup-install)-      - [setup copy](installing-packages.html#setup-copy)-      - [setup register](installing-packages.html#setup-register)-      - [setup unregister](installing-packages.html#setup-unregister)-      - [setup clean](installing-packages.html#setup-clean)-      - [setup test](installing-packages.html#setup-test)-      - [setup sdist](installing-packages.html#setup-sdist)+  * [Building, installing and managing packages](installing-packages.html)+  * [Creating packages](developing-packages.html)+  * [Cabal specification, design and implementation]()   * [Reporting bugs and deficiencies](misc.html#reporting-bugs-and-deficiencies)   * [Stability of Cabal interfaces](misc.html#stability-of-cabal-interfaces)-      - [Cabal file format](misc.html#cabal-file-format)-      - [Command-line interface](misc.html#command-line-interface)-          + [Very Stable Command-line interfaces](misc.html#very-stable-command-line-interfaces)-          + [Stable Command-line interfaces](misc.html#stable-command-line-interfaces)-          + [Unstable command-line](misc.html#unstable-command-line)-      - [Functions and Types](misc.html#functions-and-types)-          + [Very Stable API](misc.html#very-stable-api)-          + [Semi-stable API](misc.html#semi-stable-api)-          + [Unstable API](#unstable-api)-      - [Hackage](misc.html#hackage)  # Introduction # -Cabal is package system for Haskell software. The point of a packaging+Cabal is a package system for Haskell software. The point of a package system is to enable software developers and users to easily distribute,-use and reuse software. A good packaging system makes it easier for-developers to get their software into the hands of users, but equally-importantly it makes it easier for software developers to be able to-reuse software components written by other developers.+use and reuse software. A package system makes it easier for developers+to get their software into the hands of users. Equally importantly, it+makes it easier for software developers to be able to reuse software+components written by other developers.  Packaging systems deal with packages and with Cabal we call them _Cabal packages_. The Cabal package is the unit of distribution. Every Cabal package has a name and a version number which are used to identify the package, e.g. `filepath-1.0`. +Cabal packages can depend on other Cabal packages. There are tools+to enable automated package management. This means it is possible for+developers and users to install a package plus all of the other Cabal+packages that it depends on. It also means that it is practical to make+very modular systems using lots of packages that reuse code written by+many developers.+ Cabal packages are source based and are typically (but not necessarily) portable to many platforms and Haskell implementations. The Cabal package format is designed to make it possible to translate into other@@ -86,64 +52,39 @@ When distributed, Cabal packages use the standard compressed tarball format, with the file extension `.tar.gz`, e.g. `filepath-1.0.tar.gz`. -Note that packages are not part of the Haskell language, but most-Haskell implementations have some notion of package, and Cabal supports-most Haskell implementations.+Note that packages are not part of the Haskell language, rather they+are a feature provided by the combination of Cabal and GHC (and several+other Haskell implementations).  -## What's in a package ##--A Cabal package consists of:--  * Haskell software, including libraries, executables and tests-  * meta-data about the package in a standard human and machine-    readable format (the "`.cabal`" file)-  * a standard interface to build the package (the "`Setup.hs`" file)--The `.cabal` file contains information about the package, supplied by-the package author. Some of this information is used for identifying and-managing the package when it comes to distribution.+## A tool for working with packages ## -For the majority of packages it is possible to supply enough information-in the `.cabal` file so that it can be built without the package author-needing to write any extra build system scripts. For complex packages it-may be necessary to add code to the `Setup.hs` file.+There is a command line tool, called "`cabal`", that users and developers+can use to build and install Cabal packages. It can be used for both+local packages and for packages available remotely over the network. It+can automatically install Cabal packages plus any other Cabal packages+they depend on. -Here is an example `foo.cabal` for a very simple Haskell library that-exposes one Haskell module called `Data.Foo`:+Developers can use the tool with packages in local directories, e.g.  ~~~~~~~~~~~~~~~~-name:              foo-version:           1.0-build-type:        Simple-cabal-version:     >= 1.2--library-  exposed-modules: Data.Foo-  build-depends:   base >= 3 && < 5+cd foo/+cabal install ~~~~~~~~~~~~~~~~ -For full details on what goes in the `.cabal` and `Setup.hs` files, and-for all the other features provided by the build system, see the section-on [developing packages](developing-packages.html).---## A tool for working with packages ##--There is a command line tool, called `cabal`, that users and developers-can use to install Cabal packages. It can be used for both local-packages and for packages available remotely over the network.+While working on a package in a local directory, developers can run the+individual steps to configure and build, and also generate documentation+and run test suites and benchmarks. -Developers can use the tool with packages in local directories, e.g.+It is also possible to install several local packages at once, e.g.  ~~~~~~~~~~~~~~~~-cd foo/-cabal install+cabal install foo/ bar/ ~~~~~~~~~~~~~~~~  Developers and users can use the tool to install packages from remote Cabal package archives. By default, the `cabal` tool is configured to-use the centeralised Haskell community archive called [Hackage] but it+use the centeral Haskell package archive called [Hackage] but it is possible to use it with any other suitable archive.  ~~~~~~~~~~~~~~~~@@ -152,6 +93,15 @@  This will install the `xmonad` package plus all of its dependencies. +In addition to packages that have been published in an archive,+developers can install packages from local or remote tarball files,+for example++~~~~~~~~~~~~~~~~+cabal install foo-1.0.tar.gz+cabal install http://example.com/foo-1.0.tar.gz+~~~~~~~~~~~~~~~~+ Cabal provides a number of ways for a user to customise how and where a package is installed. They can decide where a package will be installed, which Haskell implementation to use and whether to build optimised code@@ -164,6 +114,88 @@ Note that `cabal` is not the only tool for working with Cabal packages. Due to the standardised format and a library for reading `.cabal` files, there are several other special-purpose tools.++## What's in a package ##++A Cabal package consists of:++  * Haskell software, including libraries, executables and tests+  * metadata about the package in a standard human and machine+    readable format (the "`.cabal`" file)+  * a standard interface to build the package (the "`Setup.hs`" file)++The `.cabal` file contains information about the package, supplied by+the package author. In particular it lists the other Cabal packages+that the package depends on.++For full details on what goes in the `.cabal` and `Setup.hs` files, and+for all the other features provided by the build system, see the section+on [developing packages](developing-packages.html).+++## Cabal featureset ##++Cabal and its associated tools and websites covers:++ * a software build system+ * software configuration+ * packaging for distribution+ * automated package management+    * natively using the `cabal` command line tool; or+    * by translation into native package formats such as RPM or deb+ * web and local Cabal package archives+    * central Hackage website with 1000's of Cabal packages++Some parts of the system can be used without others. In particular the+built-in build system for simple packages is optional: it is possible+to use custom build systems.++## Similar systems ##++The Cabal system is roughly comparable with the system of Python Eggs,+Ruby Gems or Perl distributions. Each system has a notion of+distributable packages, and has tools to manage the process of+distributing and installing packages.++Hackage is an online archive of Cabal packages. It is roughly comparable+to CPAN but with rather fewer packages (around 5,000 vs 28,000).++Cabal is often compared with autoconf and automake and there is some+overlap in functionality. The most obvious similarity is that the+command line interface for actually configuring and building packages+follows the same steps and has many of the same configuration+paramaters.++~~~~~~~~~~+./configure --prefix=...+make+make install+~~~~~~~~~~++compared to++~~~~~~~~~~+cabal configure --prefix=...+cabal build+cabal install+~~~~~~~~~~++Cabal's build system for simple packages is considerably less flexible+than make/automake, but has builtin knowledge of how to build Haskell+code and requires very little manual configuration. Cabal's simple build+system is also portable to Windows, without needing a unix-like+environment such as cygwin/mingwin.++Compared to autoconf, Cabal takes a somewhat different approach to+package configuration. Cabal's approach is designed for automated+package management. Instead of having a configure script that tests for+whether dependencies are available, Cabal packages specify their+dependencies. There is some scope for optional and conditional+dependencies. By having package authors specify dependencies it makes it+possible for tools to install a package and all of its dependencies+automatically. It also makes it possible to translate (in a+mostly-automatically way) into another package format like RPM or deb+which also have automatic dependency resolution.  [Haskell]:  http://www.haskell.org/ [Hackage]:  http://hackage.haskell.org/
cabal/Cabal/doc/installing-packages.markdown view
@@ -1,17 +1,28 @@ % Cabal User Guide - # Building and installing packages #  After you've unpacked a Cabal package, you can build it by moving into-the root directory of the package and using the `Setup.hs` or-`Setup.lhs` script there:+the root directory of the package and running the `cabal` tool there: -> `_runhaskell_ Setup.hs` [_command_] [_option_...]+> `cabal [command] [option...]` -The _command_ argument selects a particular step in the build/install-process. You can also get a summary of the command syntax with+The _command_ argument selects a particular step in the build/install process. +You can also get a summary of the command syntax with++> `cabal help`++Alternatively, you can also use the `Setup.hs` or `Setup.lhs` script:++> `runhaskell Setup.hs [command] [option...]`++For the summary of the command syntax, run:++> `cabal help`++or+ > `runhaskell Setup.hs --help`  ## Building and installing a system package ##@@ -38,6 +49,171 @@ The package is installed under the user's home directory and is registered in the user's package database (`--user`). +## Installing packages from Hackage ##++The `cabal` tool also can download, configure, build and install a [Hackage]+package and all of its dependencies in a single step. To do this, run:++~~~~~~~~~~~~~~~~+cabal install [PACKAGE...]+~~~~~~~~~~~~~~~~++To browse the list of available packages, visit the [Hackage] web site.++## Developing with sandboxes ##++By default, any dependencies of the package are installed into the global or+user package databases (e.g. using `cabal install --only-dependencies`). If+you're building several different packages that have incompatible dependencies,+this can cause the build to fail. One way to avoid this problem is to build each+package in an isolated environment ("sandbox"), with a sandbox-local package+database. Because sandboxes are per-project, inconsistent dependencies can be+simply disallowed.++For more on sandboxes, see also+[this article](http://coldwa.st/e/blog/2013-08-20-Cabal-sandbox.html).++### Sandboxes: basic usage ###++To initialise a fresh sandbox in the current directory, run `cabal sandbox+init`. All subsequent commands (such as `build` and `install`) from this point+will use the sandbox.++~~~~~~~~~~~~~~~+$ cd /path/to/my/haskell/library+$ cabal sandbox init                   # Initialise the sandbox+$ cabal install --only-dependencies    # Install dependencies into the sandbox+$ cabal build                          # Build your package inside the sandbox+~~~~~~~~~~~~~~~++It can be useful to make a source package available for installation in the+sandbox - for example, if your package depends on a patched or an unreleased+version of a library. This can be done with the `cabal sandbox add-source`+command - think of it as "local [Hackage]". If an add-source dependency is later+modified, it is reinstalled automatically.++~~~~~~~~~~~~~~~+$ cabal sandbox add-source /my/patched/library # Add a new add-source dependency+$ cabal install --dependencies-only            # Install it into the sandbox+$ cabal build                                  # Build the local package+$ $EDITOR /my/patched/library/Source.hs        # Modify the add-source dependency+$ cabal build                                  # Modified dependency is automatically reinstalled+~~~~~~~~~~~~~~~++Normally, the sandbox settings (such as optimisation level) are inherited from+the main Cabal config file (`$HOME/cabal/config`). Sometimes, though, you need+to change some settings specifically for a single sandbox. You can do this by+creating a `cabal.config` file in the same directory with your+`cabal.sandbox.config` (which was created by `sandbox init`). This file has the+same syntax as the main Cabal config file.++~~~~~~~~~~~~~~~+$ cat cabal.config+documentation: True+constraints: foo == 1.0, bar >= 2.0, baz+$ cabal build                                  # Uses settings from the cabal.config file+~~~~~~~~~~~~~~~++When you have decided that you no longer want to build your package inside a+sandbox, just delete it:++~~~~~~~~~~~~~~~+$ cabal sandbox delete                       # Built-in command+$ rm -rf .cabal-sandbox cabal.sandbox.config # Alternative manual method+~~~~~~~~~~~~~~~++### Sandboxes: advanced usage ###++The default behaviour of the `add-source` command is to track modifications done+to the added dependency and reinstall the sandbox copy of the package when+needed. Sometimes this is not desirable: in these cases you can use `add-source+--snapshot`, which disables the change tracking. In addition to `add-source`,+there are also `list-sources` and `delete-source` commands.++Sometimes one wants to share a single sandbox between multiple packages. This+can be easily done with the `--sandbox` option:++~~~~~~~~~~~~~~~+$ mkdir -p /path/to/shared-sandbox+$ cd /path/to/shared-sandbox+$ cabal sandbox init --sandbox .+$ cd /path/to/package-a+$ cabal sandbox init --sandbox /path/to/shared-sandbox+$ cd /path/to/package-b+$ cabal sandbox init --sandbox /path/to/shared-sandbox+~~~~~~~~~~~~~~~++Note that `cabal sandbox init --sandbox .` puts all sandbox files into the+current directory. By default, `cabal sandbox init` initialises a new sandbox in+a newly-created subdirectory of the current working directory+(`./.cabal-sandbox`).++Using multiple different compiler versions simultaneously is also supported, via+the `-w` option:++~~~~~~~~~~~~~~~+$ cabal sandbox init+$ cabal install --only-dependencies -w /path/to/ghc-1 # Install dependencies for both compilers+$ cabal install --only-dependencies -w /path/to/ghc-2+$ cabal configure -w /path/to/ghc-1                   # Build with the first compiler+$ cabal build+$ cabal configure -w /path/to/ghc-2                   # Build with the second compiler+$ cabal build+~~~~~~~~~~~~~~~++It can be occasionally useful to run the compiler-specific package manager tool+(e.g. `ghc-pkg`) tool on the sandbox package DB directly (for example, you may+need to unregister some packages). The `cabal sandbox hc-pkg` command is a+convenient wrapper that runs the compiler-specific package manager tool with the+arguments:++~~~~~~~~~~~~~~~+$ cabal -v sandbox hc-pkg list+Using a sandbox located at /path/to/.cabal-sandbox+'ghc-pkg' '--global' '--no-user-package-conf'+    '--package-conf=/path/to/.cabal-sandbox/i386-linux-ghc-7.4.2-packages.conf.d'+    'list'+[...]+~~~~~~~~~~~~~~~++The `--require-sandbox` option makes all sandbox-aware commands+(`install`/`build`/etc.) exit with error if there is no sandbox present. This+makes it harder to accidentally modify the user package database. The option can+be also turned on via the per-user configuration file (`~/.cabal/config`) or the+per-project one (`$PROJECT_DIR/cabal.config`). The error can be squelched with+`--no-require-sandbox`.++The option `--sandbox-config-file` allows to specify the location of the+`cabal.sandbox.config` file (by default, `cabal` searches for it in the current+directory). This provides the same functionality as shared sandboxes, but+sometimes can be more convenient. Example:++~~~~~~~~~~~~~~~+$ mkdir my/sandbox+$ cd my/sandbox+$ cabal sandbox init+$ cd /path/to/my/project+$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install+# Uses the sandbox located at /path/to/my/sandbox/.cabal-sandbox+$ cd ~+$ cabal --sandbox-config-file=/path/to/my/sandbox/cabal.sandbox.config install+# Still uses the same sandbox+~~~~~~~~~~~~~~~++The sandbox config file can be also specified via the `CABAL_SANDBOX_CONFIG`+environment variable.++Finally, the flag `--ignore-sandbox` lets you temporarily ignore an existing+sandbox:++~~~~~~~~~~~~~~~+$ mkdir my/sandbox+$ cd my/sandbox+$ cabal sandbox init+$ cabal --ignore-sandbox install text+# Installs 'text' in the user package database ('~/.cabal').+~~~~~~~~~~~~~~~+ ## Creating a binary package ##  When creating binary packages (e.g. for RedHat or Debian) one needs to@@ -93,8 +269,8 @@ If a user-supplied `configure` script is run (see the section on [system-dependent parameters](#system-dependent-parameters) or on [complex packages](#complex-packages)), it is passed the-`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir` and-`--libexecdir` options. In addition the value of the `--with-compiler`+`--with-hc-pkg`, `--prefix`, `--bindir`, `--libdir`, `--datadir`, `--libexecdir`+and `--sysconfdir` options. In addition the value of the `--with-compiler` option is passed in a `--with-hc` option and all options specified with `--configure-option=` are passed on. @@ -132,6 +308,8 @@     name of a program that can be found on the program search path. For     example: `--with-ghc=ghc-6.6.1` or     `--with-cpphs=/usr/local/bin/cpphs`.+    The full list of accepted programs is not enumerated in this user guide.+    Rather, run `cabal install --help` to view the list.  `--`_`prog`_`-options=`_options_ :   Specify additional options to the program _prog_. Any program known@@ -199,6 +377,13 @@     variables: `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`,     `$version`, `$compiler`, `$os`, `$arch` +`--sysconfdir=`_dir_+:   Installation directory for the configuration files.++    In the simple build system, _dir_ may contain the following path variables:+    `$prefix`, `$bindir`, `$libdir`, `$libsubdir`, `$pkgid`, `$pkg`, `$version`,+    `$compiler`, `$os`, `$arch`+ In addition the simple build system supports the following installation path options:  `--libsubdir=`_dir_@@ -318,6 +503,7 @@ `--datadir` (library)      `C:\Program Files\Haskell`                                `$prefix/share` `--datasubdir`             `$pkgid`                                                  `$pkgid` `--docdir`                 `$prefix\doc\$pkgid`                                      `$datadir/doc/$pkgid`+`--sysconfdir`             `$prefix\etc`                                             `$prefix/etc` `--htmldir`                `$docdir\html`                                            `$docdir/html` `--program-prefix`         (empty)                                                   (empty) `--program-suffix`         (empty)                                                   (empty)@@ -490,7 +676,7 @@     itself (such as some linux distributions).  `--enable-shared`-:   Build shared library. This implies a seperate compiler run to+:   Build shared library. This implies a separate compiler run to     generate position independent code as required on most platforms.  `--disable-shared`@@ -530,6 +716,46 @@     for libraries it is also saved in the package registration     information and used when compiling modules that use the library. +`--allow-newer`[=_pkgs_]+:   Selectively relax upper bounds in dependencies without editing the+    package description.++    If you want to install a package A that depends on B >= 1.0 && < 2.0, but+    you have the version 2.0 of B installed, you can compile A against B 2.0 by+    using `cabal install --allow-newer=B A`. This works for the whole package+    index: if A also depends on C that in turn depends on B < 2.0, C's+    dependency on B will be also relaxed.++    Example:++    ~~~~~~~~~~~~~~~~+    $ cd foo+    $ cabal configure+    Resolving dependencies...+    cabal: Could not resolve dependencies:+    [...]+    $ cabal configure --allow-newer+    Resolving dependencies...+    Configuring foo...+    ~~~~~~~~~~~~~~~~++    Additional examples:++    ~~~~~~~~~~~~~~~~+    # Relax upper bounds in all dependencies.+    $ cabal install --allow-newer foo++    # Relax upper bounds only in dependencies on bar, baz and quux.+    $ cabal install --allow-newer=bar,baz,quux foo++    # Relax the upper bound on bar and force bar==2.1.+    $ cabal install --allow-newer=bar --constraint="bar==2.1" foo+    ~~~~~~~~~~~~~~~~++    It's also possible to enable `--allow-newer` permanently by setting+    `allow-newer: True` in the `~/.cabal/config` file.++ In the simple build infrastructure, an additional option is recognized:  `--scratchdir=`_dir_@@ -783,7 +1009,8 @@ The files placed in this distribution are the package description file, the setup script, the sources of the modules named in the package description file, and files named in the `license-file`, `main-is`,-`c-sources`, `data-files` and `extra-source-files` fields.+`c-sources`, `data-files`, `extra-source-files` and `extra-doc-files`+fields.  This command takes the following option:
cabal/Cabal/doc/misc.markdown view
@@ -8,7 +8,7 @@ <libraries@haskell.org>. There is also a development mailing list <cabal-devel@haskell.org>. -[bug tracker]: http://hackage.haskell.org/trac/hackage/+[bug tracker]: https://github.com/haskell/cabal/issues  # Stability of Cabal interfaces #
+ cabal/Cabal/misc/gen-extra-source-files.sh view
@@ -0,0 +1,5 @@+#! /bin/sh++find tests -type f \( -name '*.hs' -or -name '*.c' -or -name '*.sh' \+    -or -name '*.cabal' -or -name '*.hsc' \) -and -not -regex ".*/dist/.*" \+    | awk '/Check.hs$|UnitTests|PackageTester|autogen|PackageTests.hs|CreatePipe/ { next } { print }'
− cabal/Cabal/runTests.sh 
@@ -1,21 +0,0 @@-#!/bin/sh--HCBASE=/usr/bin/-HC=$HCBASE/ghc-GHCFLAGS='--make -Wall -fno-warn-unused-matches -cpp'-ISPOSIX=-DHAVE_UNIX_PACKAGE--rm -f moduleTest-mkdir -p dist/debug-echo Building...-$HC $GHCFLAGS $ISPOSIX -DDEBUG -odir dist/debug -hidir dist/debug -idist/debug/:.:tests/HUnit-1.0/src tests/ModuleTest.hs -o moduleTest 2> stderr-RES=$?-if [ $RES != 0 ]-then-    cat stderr >&2-    exit $RES-fi-echo Running...-./moduleTest-echo Done-
cabal/HACKING view
@@ -1,10 +1,25 @@ If you want to hack on Cabal, don't be intimidated!  Read the guide to the source code:-  http://hackage.haskell.org/trac/hackage/wiki/SourceGuide+  https://github.com/haskell/cabal/wiki/Source-Guide+  +Subscribe to the mailing list:+  http://www.haskell.org/mailman/listinfo/cabal-devel+  +Browse the list of open issues:+  https://github.com/haskell/cabal/issues  There are other resources listed on the dev wiki:-  http://hackage.haskell.org/trac/hackage/+  https://github.com/haskell/cabal/wiki+  http://hackage.haskell.org/trac/hackage/ (old wiki)  In particular, the open tickets and the cabal-devel mailing list which is a good place to ask questions.+++Dependencies policy+-------------------++Cabal's policy is to support being built by versions of GHC that are up+to 3 years old.+
− cabal/README 
@@ -1,8 +0,0 @@-This Cabal darcs repository contains multiple packages:-- * Cabal/          -- the Cabal library package- * cabal-install/  -- the cabal-install package containing the 'cabal' tool.--See the README in each subdir for more details.--The canonical upstream repo lives at https://github.com/haskell/cabal
+ cabal/README.md view
@@ -0,0 +1,12 @@+# Cabal++[![Build Status](https://secure.travis-ci.org/haskell/cabal.png?branch=master)](http://travis-ci.org/haskell/cabal)++This Cabal git repository contains multiple packages:++ * `Cabal`          -- the Cabal library package+ * `cabal-install`  -- the cabal-install package containing the `cabal` tool.++See the README in each subdir for more details.++The canonical upstream repo lives at https://github.com/haskell/cabal
+ cabal/cabal-install/.ghci view
@@ -0,0 +1,1 @@+:set -idist/build/autogen -optP-include -optPdist/build/autogen/cabal_macros.h
cabal/cabal-install/Distribution/Client/BuildReports/Anonymous.hs view
@@ -146,17 +146,17 @@       Left  (BR.BuildFailed     _) -> BuildFailed       Left  (BR.TestsFailed     _) -> TestsFailed       Left  (BR.InstallFailed   _) -> InstallFailed-      Right (BR.BuildOk       _ _) -> InstallOk+      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+      Right (BR.BuildOk BR.DocsNotTried _ _)  -> NotTried+      Right (BR.BuildOk BR.DocsFailed _ _)    -> Failed+      Right (BR.BuildOk BR.DocsOk _ _)        -> Ok     convertTestsOutcome = case result of       Left  (BR.TestsFailed _)              -> Failed       Left _                                -> NotTried-      Right (BR.BuildOk _ BR.TestsNotTried) -> NotTried-      Right (BR.BuildOk _ BR.TestsOk)       -> Ok+      Right (BR.BuildOk _ BR.TestsNotTried _) -> NotTried+      Right (BR.BuildOk _ BR.TestsOk _)       -> Ok  cabalInstallID :: PackageIdentifier cabalInstallID =
cabal/cabal-install/Distribution/Client/BuildReports/Storage.hs view
@@ -74,8 +74,8 @@       [ (report, repo, remoteRepo)       | (report, repo@Repo { repoKind = Left remoteRepo }) <- rs ] -storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> IO ()-storeLocal templates reports = sequence_+storeLocal :: [PathTemplate] -> [(BuildReport, Repo)] -> Platform -> IO ()+storeLocal templates reports platform = sequence_   [ do createDirectoryIfMissing True (takeDirectory file)        appendFile file output        --TODO: make this concurrency safe, either lock the report file or make@@ -94,6 +94,7 @@       where env = initialPathTemplateEnv                     (BuildReport.package  report)                     (BuildReport.compiler report)+                    platform      groupByFileName = map (\grp@((filename,_):_) -> (filename, map snd grp))                     . groupBy (equating  fst)@@ -116,9 +117,10 @@                 -> Maybe (BuildReport, Repo) fromPlanPackage (Platform arch os) comp planPackage = case planPackage of -  InstallPlan.Installed pkg@(ConfiguredPackage (SourcePackage {+  InstallPlan.Installed pkg@(ReadyPackage (SourcePackage {                           packageSource = RepoTarballPackage repo _ _ }) _ _ _) result-    -> Just $ (BuildReport.new os arch comp pkg (Right result), repo)+    -> Just $ (BuildReport.new os arch comp+               (readyPackageToConfiguredPackage pkg) (Right result), repo)    InstallPlan.Failed pkg@(ConfiguredPackage (SourcePackage {                        packageSource = RepoTarballPackage repo _ _ }) _ _ _) result
cabal/cabal-install/Distribution/Client/BuildReports/Upload.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE PatternGuards #-}+{-# LANGUAGE CPP, PatternGuards #-} -- This is a quick hack for uploading build reports to Hackage.  module Distribution.Client.BuildReports.Upload@@ -51,7 +51,11 @@   }   case rspCode response of     (3,0,3) | [Just buildId] <- [ do rel <- parseRelativeReference location+#if MIN_VERSION_network(2,4,0)+                                     return $ relativeTo rel uri+#else                                      relativeTo rel uri+#endif                                   | Header HdrLocation location <- rspHeaders response ]               -> return $ buildId     _         -> error "Unrecognised response from server."
cabal/cabal-install/Distribution/Client/Check.hs view
@@ -72,10 +72,10 @@         isDistError _                          = True         errors = filter isDistError packageChecks -    unless (null errors) $ do+    unless (null errors) $         putStrLn "Hackage would reject this package." -    when (null packageChecks) $ do+    when (null packageChecks) $         putStrLn "No errors or warnings could be found in the package."      return (null packageChecks)
+ cabal/cabal-install/Distribution/Client/Compat/Environment.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Compat.Environment+-- Copyright   :  (c) Simon Hengel 2012+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- A cross-platform library for setting environment variables.+--+-----------------------------------------------------------------------------++module Distribution.Client.Compat.Environment (+  lookupEnv, setEnv+) where++#ifdef mingw32_HOST_OS+import GHC.Windows+import Foreign.Safe+import Foreign.C+import Control.Monad+#else+import Foreign.C.Types+import Foreign.C.String+import Foreign.C.Error (throwErrnoIfMinus1_)+import System.Posix.Internals ( withFilePath )+#endif /* mingw32_HOST_OS */++#if MIN_VERSION_base(4,6,0)+import System.Environment (lookupEnv)+#else+import System.Environment (getEnv)+import Distribution.Compat.Exception (catchIO)+#endif++#if !MIN_VERSION_base(4,6,0)+-- | @lookupEnv var@ returns the value of the environment variable @var@, or+-- @Nothing@ if there is no such value.+lookupEnv :: String -> IO (Maybe String)+lookupEnv name = (Just `fmap` getEnv name) `catchIO` const (return Nothing)+#endif /* !MIN_VERSION_base(4,6,0) */++-- | @setEnv name value@ sets the specified environment variable to @value@.+--+-- Throws `Control.Exception.IOException` if either @name@ or @value@ is the+-- empty string or contains an equals sign.+setEnv :: String -> String -> IO ()+setEnv key value_+  | null value = error "Distribuiton.Compat.setEnv: empty string"+  | otherwise  = setEnv_ key value+  where+    -- NOTE: Anything that follows NUL is ignored on both POSIX and Windows. We+    -- still strip it manually so that the null check above succeds if a value+    -- starts with NUL.+    value = takeWhile (/= '\NUL') value_++setEnv_ :: String -> String -> IO ()++#ifdef mingw32_HOST_OS++setEnv_ key value = withCWString key $ \k -> withCWString value $ \v -> do+  success <- c_SetEnvironmentVariable k v+  unless success (throwGetLastError "setEnv")++# if defined(i386_HOST_ARCH)+#  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+#  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif /* i386_HOST_ARCH */++foreign import WINDOWS_CCONV unsafe "windows.h SetEnvironmentVariableW"+  c_SetEnvironmentVariable :: LPTSTR -> LPTSTR -> IO Bool+#else+setEnv_ key value = do+  withFilePath key $ \ keyP ->+    withFilePath value $ \ valueP ->+      throwErrnoIfMinus1_ "setenv" $+        c_setenv keyP valueP (fromIntegral (fromEnum True))++foreign import ccall unsafe "setenv"+   c_setenv :: CString -> CString -> CInt -> IO CInt+#endif /* mingw32_HOST_OS */
+ cabal/cabal-install/Distribution/Client/Compat/ExecutablePath.hs view
@@ -0,0 +1,164 @@+{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE CPP #-}++-- Copied verbatim from base-4.6.0.0. We can't simply import+-- System.Environment.getExecutablePath because we need compatibility with older+-- GHCs.++module Distribution.Client.Compat.ExecutablePath ( getExecutablePath ) where++-- The imports are purposely kept completely disjoint to prevent edits+-- to one OS implementation from breaking another.++#if defined(darwin_HOST_OS)+import Data.Word+import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import System.Posix.Internals+#elif defined(linux_HOST_OS)+import Foreign.C+import Foreign.Marshal.Array+import System.Posix.Internals+#elif defined(mingw32_HOST_OS)+import Data.Word+import Foreign.C+import Foreign.Marshal.Array+import Foreign.Ptr+import System.Posix.Internals+#else+import Foreign.C+import Foreign.Marshal.Alloc+import Foreign.Ptr+import Foreign.Storable+import System.Posix.Internals+#endif++-- The exported function is defined outside any if-guard to make sure+-- every OS implements it with the same type.++-- | Returns the absolute pathname of the current executable.+--+-- Note that for scripts and interactive sessions, this is the path to+-- the interpreter (e.g. ghci.)+--+-- /Since: 4.6.0.0/+getExecutablePath :: IO FilePath++--------------------------------------------------------------------------------+-- Mac OS X++#if defined(darwin_HOST_OS)++type UInt32 = Word32++foreign import ccall unsafe "mach-o/dyld.h _NSGetExecutablePath"+    c__NSGetExecutablePath :: CString -> Ptr UInt32 -> IO CInt++-- | Returns the path of the main executable. The path may be a+-- symbolic link and not the real file.+--+-- See dyld(3)+_NSGetExecutablePath :: IO FilePath+_NSGetExecutablePath =+    allocaBytes 1024 $ \ buf ->  -- PATH_MAX is 1024 on OS X+    alloca $ \ bufsize -> do+        poke bufsize 1024+        status <- c__NSGetExecutablePath buf bufsize+        if status == 0+            then peekFilePath buf+            else do reqBufsize <- fromIntegral `fmap` peek bufsize+                    allocaBytes reqBufsize $ \ newBuf -> do+                        status2 <- c__NSGetExecutablePath newBuf bufsize+                        if status2 == 0+                             then peekFilePath newBuf+                             else error "_NSGetExecutablePath: buffer too small"++foreign import ccall unsafe "stdlib.h realpath"+    c_realpath :: CString -> CString -> IO CString++-- | Resolves all symbolic links, extra \/ characters, and references+-- to \/.\/ and \/..\/. Returns an absolute pathname.+--+-- See realpath(3)+realpath :: FilePath -> IO FilePath+realpath path =+    withFilePath path $ \ fileName ->+    allocaBytes 1024 $ \ resolvedName -> do+        _ <- throwErrnoIfNull "realpath" $ c_realpath fileName resolvedName+        peekFilePath resolvedName++getExecutablePath = _NSGetExecutablePath >>= realpath++--------------------------------------------------------------------------------+-- Linux++#elif defined(linux_HOST_OS)++foreign import ccall unsafe "readlink"+    c_readlink :: CString -> CString -> CSize -> IO CInt++-- | Reads the @FilePath@ pointed to by the symbolic link and returns+-- it.+--+-- See readlink(2)+readSymbolicLink :: FilePath -> IO FilePath+readSymbolicLink file =+    allocaArray0 4096 $ \buf -> do+        withFilePath file $ \s -> do+            len <- throwErrnoPathIfMinus1 "readSymbolicLink" file $+                   c_readlink s buf 4096+            peekFilePathLen (buf,fromIntegral len)++getExecutablePath = readSymbolicLink $ "/proc/self/exe"++--------------------------------------------------------------------------------+-- Windows++#elif defined(mingw32_HOST_OS)++# if defined(i386_HOST_ARCH)+##  define WINDOWS_CCONV stdcall+# elif defined(x86_64_HOST_ARCH)+##  define WINDOWS_CCONV ccall+# else+#  error Unknown mingw32 arch+# endif++foreign import WINDOWS_CCONV unsafe "windows.h GetModuleFileNameW"+    c_GetModuleFileName :: Ptr () -> CWString -> Word32 -> IO Word32++getExecutablePath = go 2048  -- plenty, PATH_MAX is 512 under Win32+  where+    go size = allocaArray (fromIntegral size) $ \ buf -> do+        ret <- c_GetModuleFileName nullPtr buf size+        case ret of+            0 -> error "getExecutablePath: GetModuleFileNameW returned an error"+            _ | ret < size -> peekFilePath buf+              | otherwise  -> go (size * 2)++--------------------------------------------------------------------------------+-- Fallback to argv[0]++#else++foreign import ccall unsafe "getFullProgArgv"+    c_getFullProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO ()++getExecutablePath =+    alloca $ \ p_argc ->+    alloca $ \ p_argv -> do+        c_getFullProgArgv p_argc p_argv+        argc <- peek p_argc+        if argc > 0+            -- If argc > 0 then argv[0] is guaranteed by the standard+            -- to be a pointer to a null-terminated string.+            then peek p_argv >>= peek >>= peekFilePath+            else error $ "getExecutablePath: " ++ msg+  where msg = "no OS specific implementation and program name couldn't be " +++              "found in argv"++--------------------------------------------------------------------------------++#endif
+ cabal/cabal-install/Distribution/Client/Compat/FilePerms.hs view
@@ -0,0 +1,36 @@+{-# LANGUAGE CPP #-}+{-# OPTIONS_HADDOCK hide #-}+module Distribution.Client.Compat.FilePerms (+  setFileOrdinary,+  setFileExecutable,+  setFileHidden,+  ) where++#ifndef mingw32_HOST_OS+import System.Posix.Types+         ( FileMode )+import System.Posix.Internals+         ( c_chmod )+import Foreign.C+         ( withCString )+import Foreign.C+         ( throwErrnoPathIfMinus1_ )+#else+import System.Win32.File (setFileAttributes, fILE_ATTRIBUTE_HIDDEN)+#endif /* mingw32_HOST_OS */++setFileHidden, setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()+#ifndef mingw32_HOST_OS+setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r--+setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x+setFileHidden     _    = return ()++setFileMode :: FilePath -> FileMode -> IO ()+setFileMode name m =+  withCString name $ \s ->+    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)+#else+setFileOrdinary   _ = return ()+setFileExecutable _ = return ()+setFileHidden  path = setFileAttributes path fILE_ATTRIBUTE_HIDDEN+#endif
+ cabal/cabal-install/Distribution/Client/Compat/Process.hs view
@@ -0,0 +1,43 @@++-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Compat.Process+-- Copyright   :  (c) 2013 Liu Hao, Brent Yorgey+-- License     :  BSD-style (see the file LICENSE)+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- Cross-platform utilities for invoking processes.+--+-----------------------------------------------------------------------------++module Distribution.Client.Compat.Process (+  readProcessWithExitCode+) where++import           Control.Exception (catch, throw)+import           System.Exit       (ExitCode (ExitFailure))+import           System.IO.Error   (isDoesNotExistError)+import qualified System.Process    as P++-- | @readProcessWithExitCode@ creates an external process, reads its+--   standard output and standard error strictly, waits until the+--   process terminates, and then returns the @ExitCode@ of the+--   process, the standard output, and the standard error.+--+--   See the documentation of the version from @System.Process@ for+--   more information.+--+--   The version from @System.Process@ behaves inconsistently across+--   platforms when an executable with the given name is not found: in+--   some cases it returns an @ExitFailure@, in others it throws an+--   exception.  This variant catches \"does not exist\" exceptions and+--   turns them into @ExitFailure@s.+readProcessWithExitCode :: FilePath -> [String] -> String -> IO (ExitCode, String, String)+readProcessWithExitCode cmd args input =+  P.readProcessWithExitCode cmd args input+    `catch` \e -> if isDoesNotExistError e+                    then return (ExitFailure 127, "", "")+                    else throw e
+ cabal/cabal-install/Distribution/Client/Compat/Semaphore.hs view
@@ -0,0 +1,104 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# OPTIONS_GHC -funbox-strict-fields #-}+module Distribution.Client.Compat.Semaphore+    ( QSem+    , newQSem+    , waitQSem+    , signalQSem+    ) where++import Control.Concurrent.STM (TVar, atomically, newTVar, readTVar, retry,+                               writeTVar)+import Control.Exception (mask_, onException)+import Control.Monad (join, when)+import Data.Typeable (Typeable)++-- | 'QSem' is a quantity semaphore in which the resource is aqcuired+-- and released in units of one. It provides guaranteed FIFO ordering+-- for satisfying blocked `waitQSem` calls.+--+data QSem = QSem !(TVar Int) !(TVar [TVar Bool]) !(TVar [TVar Bool])+  deriving (Eq, Typeable)++newQSem :: Int -> IO QSem+newQSem i = atomically $ do+  q <- newTVar i+  b1 <- newTVar []+  b2 <- newTVar []+  return (QSem q b1 b2)++waitQSem :: QSem -> IO ()+waitQSem s@(QSem q _b1 b2) =+  mask_ $ join $ atomically $ do+        -- join, because if we need to block, we have to add a TVar to+        -- the block queue.+        -- mask_, because we need a chance to set up an exception handler+        -- after the join returns.+     v <- readTVar q+     if v == 0+        then do b <- newTVar False+                ys <- readTVar b2+                writeTVar b2 (b:ys)+                return (wait b)+        else do writeTVar q $! v - 1+                return (return ())+  where+    --+    -- very careful here: if we receive an exception, then we need to+    --  (a) write True into the TVar, so that another signalQSem doesn't+    --      try to wake up this thread, and+    --  (b) if the TVar is *already* True, then we need to do another+    --      signalQSem to avoid losing a unit of the resource.+    --+    -- The 'wake' function does both (a) and (b), so we can just call+    -- it here.+    --+    wait t =+      flip onException (wake s t) $+      atomically $ do+        b <- readTVar t+        when (not b) retry+++wake :: QSem -> TVar Bool -> IO ()+wake s x = join $ atomically $ do+      b <- readTVar x+      if b then return (signalQSem s)+           else do writeTVar x True+                   return (return ())++{-+ property we want:++   bracket waitQSem (\_ -> signalQSem) (\_ -> ...)++ never loses a unit of the resource.+-}++signalQSem :: QSem -> IO ()+signalQSem s@(QSem q b1 b2) =+  mask_ $ join $ atomically $ do+      -- join, so we don't force the reverse inside the txn+      -- mask_ is needed so we don't lose a wakeup+    v <- readTVar q+    if v /= 0+       then do writeTVar q $! v + 1+               return (return ())+       else do xs <- readTVar b1+               checkwake1 xs+  where+    checkwake1 [] = do+      ys <- readTVar b2+      checkwake2 ys+    checkwake1 (x:xs) = do+      writeTVar b1 xs+      return (wake s x)++    checkwake2 [] = do+      writeTVar q 1+      return (return ())+    checkwake2 ys = do+      let (z:zs) = reverse ys+      writeTVar b1 zs+      writeTVar b2 []+      return (wake s z)
+ cabal/cabal-install/Distribution/Client/Compat/Time.hs view
@@ -0,0 +1,132 @@+{-# LANGUAGE CPP, ForeignFunctionInterface #-}+module Distribution.Client.Compat.Time+       (EpochTime, getModTime, getFileAge, getCurTime)+       where++import Data.Int (Int64)+import System.Directory (getModificationTime)++#if MIN_VERSION_directory(1,2,0)+import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength)+import Data.Time (getCurrentTime, diffUTCTime)+#else+import System.Time (ClockTime(..), getClockTime+                   ,diffClockTimes, normalizeTimeDiff, tdDay)+#endif++#if defined mingw32_HOST_OS++import Data.Bits          ((.|.), bitSize, unsafeShiftL)+import Data.Int           (Int32)+import Data.Word          (Word64)+import Foreign            (allocaBytes, peekByteOff)+import System.IO.Error    (mkIOError, doesNotExistErrorType)+import System.Win32.Types (BOOL, DWORD, LPCTSTR, LPVOID, withTString)+++foreign import stdcall "windows.h GetFileAttributesExW"+  c_getFileAttributesEx :: LPCTSTR -> Int32 -> LPVOID -> IO BOOL++getFileAttributesEx :: String -> LPVOID -> IO BOOL+getFileAttributesEx path lpFileInformation =+  withTString path $ \c_path ->+      c_getFileAttributesEx c_path getFileExInfoStandard lpFileInformation++getFileExInfoStandard :: Int32+getFileExInfoStandard = 0++size_WIN32_FILE_ATTRIBUTE_DATA :: Int+size_WIN32_FILE_ATTRIBUTE_DATA = 36++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime = 20++index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime :: Int+index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime = 24++#else++#if MIN_VERSION_base(4,5,0)+import Foreign.C.Types    (CTime(..))+#else+import Foreign.C.Types    (CTime)+#endif+import System.Posix.Files (getFileStatus, modificationTime)++#endif++-- | The number of seconds since the UNIX epoch.+type EpochTime = Int64++-- | Return modification time of given file. Works around the low clock+-- resolution problem that 'getModificationTime' has on GHC < 7.8.+--+-- This is a modified version of the code originally written for OpenShake by+-- Neil Mitchell. See module Development.Shake.FileTime.+getModTime :: FilePath -> IO EpochTime++#if defined mingw32_HOST_OS++-- Directly against the Win32 API.+getModTime path = allocaBytes size_WIN32_FILE_ATTRIBUTE_DATA $ \info -> do+  res <- getFileAttributesEx path info+  if not res+    then do+      let err = mkIOError doesNotExistErrorType+                "Distribution.Client.Compat.Time.getModTime"+                Nothing (Just path)+      ioError err+    else do+      dwLow  <- peekByteOff info+                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwLowDateTime+      dwHigh <- peekByteOff info+                index_WIN32_FILE_ATTRIBUTE_DATA_ftLastWriteTime_dwHighDateTime+      return $! windowsTimeToPOSIXSeconds dwLow dwHigh+        where+          windowsTimeToPOSIXSeconds :: DWORD -> DWORD -> EpochTime+          windowsTimeToPOSIXSeconds dwLow dwHigh =+            let wINDOWS_TICK      = 10000000+                sEC_TO_UNIX_EPOCH = 11644473600+                qwTime = (fromIntegral dwHigh `unsafeShiftL` bitSize dwHigh)+                         .|. (fromIntegral dwLow)+                res    = ((qwTime :: Word64) `div` wINDOWS_TICK)+                         - sEC_TO_UNIX_EPOCH+            -- TODO: What if the result is not representable as POSIX seconds?+            -- Probably fine to return garbage.+            in fromIntegral res+#else++-- Directly against the unix library.+getModTime path = do+    -- CTime is Int32 in base 4.5, Int64 in base >= 4.6, and an abstract type in+    -- base < 4.5.+    t <- fmap modificationTime $ getFileStatus path+#if MIN_VERSION_base(4,5,0)+    let CTime i = t+    return (fromIntegral i)+#else+    return (read . show $ t)+#endif+#endif++-- | Return age of given file in days.+getFileAge :: FilePath -> IO Int+getFileAge file = do+  t0 <- getModificationTime file+#if MIN_VERSION_directory(1,2,0)+  t1 <- getCurrentTime+  let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength+#else+  t1 <- getClockTime+  let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0)+#endif+  return days++getCurTime :: IO EpochTime+getCurTime =  do+#if MIN_VERSION_directory(1,2,0)+  (truncate . utcTimeToPOSIXSeconds) `fmap` getCurrentTime+#else+  (TOD s _) <- getClockTime+  return $! fromIntegral s+#endif
cabal/cabal-install/Distribution/Client/Config.hs view
@@ -24,6 +24,7 @@     defaultCacheDir,     defaultCompiler,     defaultLogsDir,+    defaultUserInstall,      baseSavedConfig,     commentSavedConfig,@@ -38,20 +39,19 @@ import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Setup-         ( GlobalFlags(..), globalCommand+         ( GlobalFlags(..), globalCommand, defaultGlobalFlags          , ConfigExFlags(..), configureExOptions, defaultConfigExFlags          , InstallFlags(..), installOptions, defaultInstallFlags          , UploadFlags(..), uploadCommand          , ReportFlags(..), reportCommand          , showRepo, parseRepo )-import Distribution.Client.Utils-         ( numberOfProcessors )  import Distribution.Simple.Compiler          ( OptimisationLevel(..) ) import Distribution.Simple.Setup          ( ConfigFlags(..), configureOptions, defaultConfigFlags          , installDirsOptions+         , programConfigurationPaths', programConfigurationOptions          , Flag(..), toFlag, flagToMaybe, fromFlagOrDefault ) import Distribution.Simple.InstallDirs          ( InstallDirs(..), defaultInstallDirs@@ -87,7 +87,7 @@ import Data.Monoid          ( Monoid(..) ) import Control.Monad-         ( when, foldM, liftM )+         ( unless, foldM, liftM ) import qualified Distribution.Compat.ReadP as Parse          ( option ) import qualified Text.PrettyPrint as Disp@@ -100,10 +100,10 @@          ( URI(..), URIAuth(..) ) import System.FilePath          ( (<.>), (</>), takeDirectory )-import System.Environment-         ( getEnvironment ) import System.IO.Error          ( isDoesNotExistError )+import Distribution.Compat.Environment+         ( getEnvironment ) import Distribution.Compat.Exception          ( catchIO ) @@ -203,16 +203,20 @@   cacheDir   <- defaultCacheDir   logsDir    <- defaultLogsDir   worldFile  <- defaultWorldFile+  extraPath  <- defaultExtraPath   return mempty {     savedGlobalFlags     = mempty {       globalCacheDir     = toFlag cacheDir,       globalRemoteRepos  = [defaultRemoteRepo],       globalWorldFile    = toFlag worldFile     },+    savedConfigureFlags  = mempty {+      configProgramPathExtra = extraPath+    },     savedInstallFlags    = mempty {       installSummaryFile = [toPathTemplate (logsDir </> "build.log")],       installBuildReports= toFlag AnonymousReports,-      installNumJobs     = toFlag (Just numberOfProcessors)+      installNumJobs     = toFlag Nothing     }   } @@ -242,6 +246,11 @@   dir <- defaultCabalDir   return $ dir </> "world" +defaultExtraPath :: IO [FilePath]+defaultExtraPath = do+  dir <- defaultCabalDir+  return [dir </> "bin"]+ defaultCompiler :: CompilerFlavor defaultCompiler = fromMaybe GHC defaultCompilerFlavor @@ -268,7 +277,7 @@         ("default config file",  Just `liftM` defaultConfigFile) ]        getSource [] = error "no config file path candidate found."-      getSource ((msg,action): xs) = +      getSource ((msg,action): xs) =                         action >>= maybe (getSource xs) (return . (,) msg)    (source, configFile) <- getSource sources@@ -283,15 +292,15 @@       writeConfigFile configFile commentConf initialConf       return initialConf     Just (ParseOk ws conf) -> do-      when (not $ null ws) $ warn verbosity $+      unless (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."+        ++ maybe "" (\n -> ':' : show n) line ++ ":\n" ++ msg+      warn verbosity "Using default configuration."       initialSavedConfig    where@@ -339,7 +348,7 @@   userInstallDirs   <- defaultInstallDirs defaultCompiler True True   globalInstallDirs <- defaultInstallDirs defaultCompiler False True   return SavedConfig {-    savedGlobalFlags       = commandDefaultFlags globalCommand,+    savedGlobalFlags       = defaultGlobalFlags,     savedInstallFlags      = defaultInstallFlags,     savedConfigureExFlags  = defaultConfigExFlags,     savedConfigureFlags    = (defaultConfigFlags defaultProgramConfiguration) {@@ -358,11 +367,12 @@       toSavedConfig liftGlobalFlag        (commandOptions globalCommand ParseArgs)-       ["version", "numeric-version", "config-file"] []+       ["version", "numeric-version", "config-file", "sandbox-config-file"] []    ++ toSavedConfig liftConfigFlag        (configureOptions ParseArgs)-       (["builddir", "configure-option", "constraint"] ++ map fieldName installDirsFields)+       (["builddir", "configure-option", "constraint", "dependency"]+        ++ 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@@ -403,7 +413,7 @@    ++ toSavedConfig liftInstallFlag        (installOptions ParseArgs)-       ["dry-run", "only"] []+       ["dry-run", "only", "only-dependencies", "dependencies-only"] []    ++ toSavedConfig liftUploadFlag        (commandOptions uploadCommand ParseArgs)@@ -498,28 +508,49 @@   config <- parse others   let user0   = savedUserInstallDirs config       global0 = savedGlobalInstallDirs config-  (user, global) <- foldM parseSections (user0, global0) knownSections+  (user, global, paths, args) <-+    foldM parseSections (user0, global0, [], []) knownSections   return config {+    savedConfigureFlags    = (savedConfigureFlags config) {+       configProgramPaths  = paths,+       configProgramArgs   = args+       },     savedUserInstallDirs   = user,     savedGlobalInstallDirs = global   }    where-    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True-    isKnownSection _                                          = False+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _)            = True+    isKnownSection (ParseUtils.Section _ "program-locations" _ _)       = True+    isKnownSection (ParseUtils.Section _ "program-default-options" _ _) = True+    isKnownSection _                                                    = False      parse = parseFields (configFieldDescriptions                       ++ deprecatedFieldDescriptions) initial -    parseSections accum@(u,g) (ParseUtils.Section _ "install-dirs" name fs)+    parseSections accum@(u,g,p,a) (ParseUtils.Section _ "install-dirs" name fs)       | name' == "user"   = do u' <- parseFields installDirsFields u fs-                               return (u', g)+                               return (u', g, p, a)       | name' == "global" = do g' <- parseFields installDirsFields g fs-                               return (u, g')+                               return (u, g', p, a)       | otherwise         = do           warning "The install-paths section should be for 'user' or 'global'"           return accum       where name' = lowercase name+    parseSections accum@(u,g,p,a)+                 (ParseUtils.Section _ "program-locations" name fs)+      | name == ""        = do p' <- parseFields withProgramsFields p fs+                               return (u, g, p', a)+      | otherwise         = do+          warning "The 'program-locations' section should be unnamed"+          return accum+    parseSections accum@(u, g, p, a)+                  (ParseUtils.Section _ "program-default-options" name fs)+      | name == ""        = do a' <- parseFields withProgramOptionsFields a fs+                               return (u, g, p, a')+      | otherwise         = do+          warning "The 'program-default-options' section should be unnamed"+          return accum     parseSections accum f = do       warning $ "Unrecognized stanza on line " ++ show (lineNo f)       return accum@@ -529,15 +560,40 @@  showConfigWithComments :: SavedConfig -> SavedConfig -> String showConfigWithComments comment vals = Disp.render $-      ppFields configFieldDescriptions comment vals+      ppFields configFieldDescriptions mcomment vals   $+$ Disp.text ""   $+$ installDirsSection "user"   savedUserInstallDirs   $+$ Disp.text ""   $+$ installDirsSection "global" savedGlobalInstallDirs+  $+$ Disp.text ""+  $+$ configFlagsSection "program-locations" withProgramsFields+                         configProgramPaths+  $+$ Disp.text ""+  $+$ configFlagsSection "program-default-options" withProgramOptionsFields+                         configProgramArgs   where+    mcomment = Just comment     installDirsSection name field =       ppSection "install-dirs" name installDirsFields-                (field comment) (field vals)+                (fmap field mcomment) (field vals)+    configFlagsSection name fields field =+      ppSection name "" fields+               (fmap (field . savedConfigureFlags) mcomment)+               ((field . savedConfigureFlags) vals) + installDirsFields :: [FieldDescr (InstallDirs (Flag PathTemplate))] installDirsFields = map viewAsFieldDescr installDirsOptions++-- | Fields for the 'program-locations' section.+withProgramsFields :: [FieldDescr [(String, FilePath)]]+withProgramsFields =+  map viewAsFieldDescr $+  programConfigurationPaths' (++ "-location") defaultProgramConfiguration+                             ParseArgs id (++)++-- | Fields for the 'program-default-options' section.+withProgramOptionsFields :: [FieldDescr [(String, [String])]]+withProgramOptionsFields =+  map viewAsFieldDescr $+  programConfigurationOptions defaultProgramConfiguration ParseArgs id (++)
cabal/cabal-install/Distribution/Client/Configure.hs view
@@ -12,9 +12,11 @@ ----------------------------------------------------------------------------- module Distribution.Client.Configure (     configure,+    chooseCabalVersion,   ) where  import Distribution.Client.Dependency+import Distribution.Client.Dependency.Types (AllowNewer(..), isAllowNewer) import qualified Distribution.Client.InstallPlan as InstallPlan import Distribution.Client.InstallPlan (InstallPlan) import Distribution.Client.IndexUtils as IndexUtils@@ -36,6 +38,7 @@ import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Utils          ( defaultPackageDesc )+import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package          ( Package(..), packageName, Dependency(..), thisPackageVersion ) import Distribution.PackageDescription.Parse@@ -45,44 +48,57 @@ import Distribution.Version          ( anyVersion, thisVersion ) import Distribution.Simple.Utils as Utils-         ( notice, info, debug, die )+         ( notice, debug, die ) import Distribution.System-         ( Platform, buildPlatform )+         ( Platform ) import Distribution.Verbosity as Verbosity          ( Verbosity )+import Distribution.Version+         ( Version(..), VersionRange, orLaterVersion )  import Data.Monoid (Monoid(..)) +-- | Choose the Cabal version such that the setup scripts compiled against this+-- version will support the given command-line flags.+chooseCabalVersion :: ConfigExFlags -> Maybe Version -> VersionRange+chooseCabalVersion configExFlags maybeVersion =+  maybe defaultVersionRange thisVersion maybeVersion+  where+    allowNewer = fromFlagOrDefault False $+                 fmap isAllowNewer (configAllowNewer configExFlags)++    defaultVersionRange = if allowNewer+                          then orLaterVersion (Version [1,19,2] [])+                          else anyVersion+ -- | Configure the package found in the local directory configure :: Verbosity           -> PackageDBStack           -> [Repo]           -> Compiler+          -> Platform           -> ProgramConfiguration           -> ConfigFlags           -> ConfigExFlags           -> [String]           -> IO ()-configure verbosity packageDBs repos comp conf+configure verbosity packageDBs repos comp platform conf   configFlags configExFlags extraArgs = do    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf   sourcePkgDb       <- getSourcePackages    verbosity repos -  progress <- planLocalPackage verbosity comp configFlags configExFlags+  progress <- planLocalPackage verbosity comp platform configFlags configExFlags                                installedPkgIndex sourcePkgDb    notice verbosity "Resolving dependencies..."   maybePlan <- foldProgress logMsg (return . Left) (return . Right)                             progress   case maybePlan of-    Left message -> do-      info verbosity message-      setupWrapper verbosity (setupScriptOptions installedPkgIndex) Nothing-        configureCommand (const configFlags) extraArgs+    Left message -> die message      Right installPlan -> case InstallPlan.ready installPlan of-      [pkg@(ConfiguredPackage (SourcePackage _ _ (LocalUnpackedPackage _)) _ _ _)] ->+      [pkg@(ReadyPackage (SourcePackage _ _ (LocalUnpackedPackage _) _) _ _ _)] ->         configurePackage verbosity           (InstallPlan.planPlatform installPlan)           (InstallPlan.planCompiler installPlan)@@ -94,9 +110,10 @@    where     setupScriptOptions index = SetupScriptOptions {-      useCabalVersion  = maybe anyVersion thisVersion+      useCabalVersion  = chooseCabalVersion configExFlags                          (flagToMaybe (configCabalVersion configExFlags)),       useCompiler      = Just comp,+      usePlatform      = Just platform,       usePackageDB     = packageDBs',       usePackageIndex  = index',       useProgramConfig = conf,@@ -125,11 +142,12 @@ -- and all its dependencies. -- planLocalPackage :: Verbosity -> Compiler+                 -> Platform                  -> ConfigFlags -> ConfigExFlags                  -> PackageIndex                  -> SourcePackageDb                  -> IO (Progress String String InstallPlan)-planLocalPackage verbosity comp configFlags configExFlags installedPkgIndex+planLocalPackage verbosity comp platform configFlags configExFlags installedPkgIndex   (SourcePackageDb _ packagePrefs) = do   pkg <- readPackageDescription verbosity =<< defaultPackageDesc verbosity   solver <- chooseSolver verbosity (fromFlag $ configSolver configExFlags) (compilerId comp)@@ -138,7 +156,8 @@       localPkg = SourcePackage {         packageInfoId             = packageId pkg,         Source.packageDescription = pkg,-        packageSource             = LocalUnpackedPackage "."+        packageSource             = LocalUnpackedPackage ".",+        packageDescrOverride      = Nothing       }        testsEnabled = fromFlagOrDefault False $ configTests configFlags@@ -146,16 +165,18 @@         fromFlagOrDefault False $ configBenchmarks configFlags        resolverParams =+          removeUpperBounds (fromFlagOrDefault AllowNewerNone $+                             configAllowNewer configExFlags) -          addPreferences+        . addPreferences             -- preferences from the config file or command line             [ PackageVersionPreference name ver             | Dependency name ver <- configPreferences configExFlags ]          . addConstraints             -- version constraints from the config file or command line-            -- TODO: should warn or error on constraints that are not on direct deps-            -- or flag constraints not on the package in question.+            -- TODO: should warn or error on constraints that are not on direct+            -- deps or flag constraints not on the package in question.             (map userToPackageConstraint (configExConstraints configExFlags))          . addConstraints@@ -166,10 +187,9 @@         . addConstraints             -- '--enable-tests' and '--enable-benchmarks' constraints from             -- command line-            [ PackageConstraintStanzas (packageName pkg) $ concat-                [ if testsEnabled then [TestStanzas] else []-                , if benchmarksEnabled then [BenchStanzas] else []-                ]+            [ PackageConstraintStanzas (packageName pkg) $+                [ TestStanzas  | testsEnabled ] +++                [ BenchStanzas | benchmarksEnabled ]             ]          $ standardInstallPolicy@@ -177,24 +197,26 @@             (SourcePackageDb mempty packagePrefs)             [SpecificSourcePackage localPkg] -  return (resolveDependencies buildPlatform (compilerId comp) solver resolverParams)+  return (resolveDependencies platform (compilerId comp) solver resolverParams)   -- | Call an installer for an 'SourcePackage' but override the configure--- flags with the ones given by the 'ConfiguredPackage'. In particular the--- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- flags with the ones given by the 'ReadyPackage'. In particular the+-- 'ReadyPackage' 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. --+-- NB: when updating this function, don't forget to also update+-- 'installReadyPackage' in D.C.Install. configurePackage :: Verbosity                  -> Platform -> CompilerId                  -> SetupScriptOptions                  -> ConfigFlags-                 -> ConfiguredPackage+                 -> ReadyPackage                  -> [String]                  -> IO () configurePackage verbosity platform comp scriptOptions configFlags-  (ConfiguredPackage (SourcePackage _ gpkg _) flags stanzas deps) extraArgs =+  (ReadyPackage (SourcePackage _ gpkg _ _) flags stanzas deps) extraArgs =    setupWrapper verbosity     scriptOptions (Just pkg) configureCommand configureFlags extraArgs@@ -202,14 +224,23 @@   where     configureFlags   = filterConfigureFlags configFlags {       configConfigurationsFlags = flags,-      configConstraints         = map thisPackageVersion deps,-      configVerbosity           = toFlag verbosity,-      configBenchmarks          = toFlag (BenchStanzas `elem` stanzas),-      configTests               = toFlag (TestStanzas `elem` stanzas)+      -- We generate the legacy constraints as well as the new style precise+      -- deps.  In the end only one set gets passed to Setup.hs configure,+      -- depending on the Cabal version we are talking to.+      configConstraints  = [ thisPackageVersion (packageId deppkg)+                           | deppkg <- deps ],+      configDependencies = [ (packageName (Installed.sourcePackageId deppkg),+                              Installed.installedPackageId deppkg)+                           | deppkg <- deps ],+      -- Use '--exact-configuration' if supported.+      configExactConfiguration = toFlag True,+      configVerbosity          = toFlag verbosity,+      configBenchmarks         = toFlag (BenchStanzas `elem` stanzas),+      configTests              = toFlag (TestStanzas `elem` stanzas)     }      pkg = case finalizePackageDescription flags            (const True)            platform comp [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Left _ -> error "finalizePackageDescription ReadyPackage failed"       Right (desc, _) -> desc
cabal/cabal-install/Distribution/Client/Dependency.hs view
@@ -33,6 +33,9 @@     standardInstallPolicy,     PackageSpecifier(..), +    -- ** Sandbox policy+    applySandboxInstallPolicy,+     -- ** Extra policy options     dontUpgradeBasePackage,     hideBrokenInstalledPackages,@@ -52,6 +55,7 @@     hideInstalledPackagesSpecificByInstalledPackageId,     hideInstalledPackagesSpecificBySourcePackageId,     hideInstalledPackagesAllVersions,+    removeUpperBounds   ) where  import Distribution.Client.Dependency.TopDown@@ -67,16 +71,24 @@          , SourcePackage(..) ) import Distribution.Client.Dependency.Types          ( PreSolver(..), Solver(..), DependencyResolver, PackageConstraint(..)-         , PackagePreferences(..), InstalledPreference(..)+         , AllowNewer(..), PackagePreferences(..), InstalledPreference(..)          , PackagesPreferenceDefault(..)          , Progress(..), foldProgress )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..) ) import Distribution.Client.Targets import qualified Distribution.InstalledPackageInfo as Installed import Distribution.Package-         ( PackageName(..), PackageId, Package(..), packageVersion+         ( PackageName(..), PackageId, Package(..), packageName, packageVersion          , InstalledPackageId, Dependency(Dependency))+import qualified Distribution.PackageDescription as PD+         ( PackageDescription(..), GenericPackageDescription(..)+         , Library(..), Executable(..), TestSuite(..), Benchmark(..), CondTree)+import Distribution.PackageDescription (BuildInfo(targetBuildDepends))+import Distribution.PackageDescription.Configuration (mapCondTree) import Distribution.Version-         ( Version(..), VersionRange, anyVersion, withinRange, simplifyVersionRange )+         ( Version(..), VersionRange, anyVersion, thisVersion, withinRange+         , removeUpperBound, simplifyVersionRange ) import Distribution.Compiler          ( CompilerId(..), CompilerFlavor(..) ) import Distribution.System@@ -235,7 +247,8 @@     }  hideInstalledPackagesSpecificByInstalledPackageId :: [InstalledPackageId]-                                                     -> DepResolverParams -> DepResolverParams+                                                     -> DepResolverParams+                                                     -> DepResolverParams hideInstalledPackagesSpecificByInstalledPackageId pkgids params =     --TODO: this should work using exclude constraints instead     params {@@ -245,7 +258,8 @@     }  hideInstalledPackagesSpecificBySourcePackageId :: [PackageId]-                                                  -> DepResolverParams -> DepResolverParams+                                                  -> DepResolverParams+                                                  -> DepResolverParams hideInstalledPackagesSpecificBySourcePackageId pkgids params =     --TODO: this should work using exclude constraints instead     params {@@ -276,7 +290,89 @@            . InstalledPackageIndex.brokenPackages            $ depResolverInstalledPkgIndex params +-- | Remove upper bounds in dependencies using the policy specified by the+-- 'AllowNewer' argument (all/some/none).+removeUpperBounds :: AllowNewer -> DepResolverParams -> DepResolverParams+removeUpperBounds allowNewer params =+    params {+      -- NB: It's important to apply 'removeUpperBounds' after+      -- 'addSourcePackages'. Otherwise, the packages inserted by+      -- 'addSourcePackages' won't have upper bounds in dependencies relaxed. +      depResolverSourcePkgIndex = sourcePkgIndex'+    }+  where+    sourcePkgIndex  = depResolverSourcePkgIndex params+    sourcePkgIndex' = case allowNewer of+      AllowNewerNone      -> sourcePkgIndex+      AllowNewerAll       -> fmap relaxAllPackageDeps         sourcePkgIndex+      AllowNewerSome pkgs -> fmap (relaxSomePackageDeps pkgs) sourcePkgIndex++    relaxAllPackageDeps :: SourcePackage -> SourcePackage+    relaxAllPackageDeps = onAllBuildDepends doRelax+      where+        doRelax (Dependency pkgName verRange) =+          Dependency pkgName (removeUpperBound verRange)++    relaxSomePackageDeps :: [PackageName] -> SourcePackage -> SourcePackage+    relaxSomePackageDeps pkgNames = onAllBuildDepends doRelax+      where+        doRelax d@(Dependency pkgName verRange)+          | pkgName `elem` pkgNames = Dependency pkgName+                                      (removeUpperBound verRange)+          | otherwise               = d++    -- Walk a 'GenericPackageDescription' and apply 'f' to all 'build-depends'+    -- fields.+    onAllBuildDepends :: (Dependency -> Dependency)+                      -> SourcePackage -> SourcePackage+    onAllBuildDepends f srcPkg = srcPkg'+      where+        gpd        = packageDescription srcPkg+        pd         = PD.packageDescription gpd+        condLib    = PD.condLibrary        gpd+        condExes   = PD.condExecutables    gpd+        condTests  = PD.condTestSuites     gpd+        condBenchs = PD.condBenchmarks     gpd++        f' = onBuildInfo f+        onBuildInfo g bi = bi+          { targetBuildDepends = map g (targetBuildDepends bi) }++        onLibrary    lib  = lib { PD.libBuildInfo  = f' $ PD.libBuildInfo  lib }+        onExecutable exe  = exe { PD.buildInfo     = f' $ PD.buildInfo     exe }+        onTestSuite  tst  = tst { PD.testBuildInfo = f' $ PD.testBuildInfo tst }+        onBenchmark  bmk  = bmk { PD.benchmarkBuildInfo =+                                     f' $ PD.benchmarkBuildInfo bmk }++        srcPkg' = srcPkg { packageDescription = gpd' }+        gpd'    = gpd {+          PD.packageDescription = pd',+          PD.condLibrary        = condLib',+          PD.condExecutables    = condExes',+          PD.condTestSuites     = condTests',+          PD.condBenchmarks     = condBenchs'+          }+        pd' = pd {+          PD.buildDepends = map  f            (PD.buildDepends pd),+          PD.library      = fmap onLibrary    (PD.library pd),+          PD.executables  = map  onExecutable (PD.executables pd),+          PD.testSuites   = map  onTestSuite  (PD.testSuites pd),+          PD.benchmarks   = map  onBenchmark  (PD.benchmarks pd)+          }+        condLib'    = fmap (onCondTree onLibrary)             condLib+        condExes'   = map  (mapSnd $ onCondTree onExecutable) condExes+        condTests'  = map  (mapSnd $ onCondTree onTestSuite)  condTests+        condBenchs' = map  (mapSnd $ onCondTree onBenchmark)  condBenchs++        mapSnd :: (a -> b) -> (c,a) -> (c,b)+        mapSnd = fmap++        onCondTree :: (a -> b) -> PD.CondTree v [Dependency] a+                   -> PD.CondTree v [Dependency] b+        onCondTree g = mapCondTree g (map f) id++ upgradeDependencies :: DepResolverParams -> DepResolverParams upgradeDependencies = setPreferenceDefault PreferAllLatest @@ -313,7 +409,44 @@   $ basicDepResolverParams       installedPkgIndex sourcePkgIndex +applySandboxInstallPolicy :: SandboxPackageInfo+                             -> DepResolverParams+                             -> DepResolverParams+applySandboxInstallPolicy+  (SandboxPackageInfo modifiedDeps otherDeps allSandboxPkgs _allDeps)+  params +  = addPreferences [ PackageInstalledPreference n PreferInstalled+                   | n <- installedNotModified ]++  . addTargets installedNotModified++  . addPreferences+      [ PackageVersionPreference (packageName pkg)+        (thisVersion (packageVersion pkg)) | pkg <- otherDeps ]++  . addConstraints+      [ PackageConstraintVersion (packageName pkg)+        (thisVersion (packageVersion pkg)) | pkg <- modifiedDeps ]++  . addTargets [ packageName pkg | pkg <- modifiedDeps ]++  . hideInstalledPackagesSpecificBySourcePackageId+      [ packageId pkg | pkg <- modifiedDeps ]++  -- We don't need to add source packages for add-source deps to the+  -- 'installedPkgIndex' since 'getSourcePackages' did that for us.++  $ params++  where+    installedPkgIds =+      map fst . InstalledPackageIndex.allPackagesBySourcePackageId+      $ allSandboxPkgs+    modifiedPkgIds       = map packageId modifiedDeps+    installedNotModified = [ packageName pkg | pkg <- installedPkgIds,+                             pkg `notElem` modifiedPkgIds ]+ -- ------------------------------------------------------------ -- * Interface to the standard resolver -- ------------------------------------------------------------@@ -353,7 +486,8 @@ resolveDependencies platform comp  solver params =      fmap (mkInstallPlan platform comp)-  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls shadowing maxBkjumps)+  $ runSolver solver (SolverConfig reorderGoals indGoals noReinstalls+                      shadowing maxBkjumps)                      platform comp installedPkgIndex sourcePkgIndex                      preferences constraints targets   where@@ -368,10 +502,10 @@       shadowing       maxBkjumps      = dontUpgradeBasePackage                       -- TODO:-                      -- The modular solver can properly deal with broken packages-                      -- and won't select them. So the 'hideBrokenInstalledPackages'-                      -- function should be moved into a module that is specific-                      -- to the Topdown solver.+                      -- The modular solver can properly deal with broken+                      -- packages and won't select them. So the+                      -- 'hideBrokenInstalledPackages' function should be moved+                      -- into a module that is specific to the Topdown solver.                       . (if solver /= Modular then hideBrokenInstalledPackages                                               else id)                       $ params@@ -379,7 +513,6 @@     preferences = interpretPackagesPreference                     (Set.fromList targets) defpref prefs - -- | Make an install plan from the output of the dep resolver. -- It checks that the plan is valid, or it's an error in the dep resolver. --@@ -448,7 +581,8 @@                            -> Either [ResolveNoDepsError] [SourcePackage] resolveWithoutDependencies (DepResolverParams targets constraints                               prefs defpref installedPkgIndex sourcePkgIndex-                              _reorderGoals _indGoals _avoidReinstalls _shadowing _maxBjumps) =+                              _reorderGoals _indGoals _avoidReinstalls+                              _shadowing _maxBjumps) =     collectEithers (map selectPackage targets)   where     selectPackage :: PackageName -> Either ResolveNoDepsError SourcePackage@@ -471,7 +605,8 @@                           (installPref pkg, versionPref pkg, packageVersion pkg)         installPref   = case preferInstalled of           PreferLatest    -> const False-          PreferInstalled -> not . null . InstalledPackageIndex.lookupSourcePackageId+          PreferInstalled -> not . null+                           . InstalledPackageIndex.lookupSourcePackageId                                                      installedPkgIndex                            . packageId         versionPref   pkg = packageVersion pkg `withinRange` preferredVersions
cabal/cabal-install/Distribution/Client/Dependency/Modular/Builder.hs view
@@ -43,6 +43,7 @@ extendOpen :: QPN -> [OpenGoal] -> BuildState -> BuildState extendOpen qpn' gs s@(BS { rdeps = gs', open = o' }) = go gs' o' gs   where+    go :: RevDepMap -> PSQ OpenGoal () -> [OpenGoal] -> BuildState     go g o []                                             = s { rdeps = g, open = o }     go g o (ng@(OpenGoal (Flagged _ _ _ _)    _gr) : ngs) = go g (cons ng () o) ngs     go g o (ng@(OpenGoal (Stanza  _   _  )    _gr) : ngs) = go g (cons ng () o) ngs@@ -63,7 +64,7 @@  -- | Given the current scope, qualify all the package names in the given set of -- dependencies and then extend the set of open goals accordingly.-scopedExtendOpen :: QPN -> I -> QGoalReasons -> FlaggedDeps PN -> FlagInfo ->+scopedExtendOpen :: QPN -> I -> QGoalReasonChain -> FlaggedDeps PN -> FlagInfo ->                     BuildState -> BuildState scopedExtendOpen qpn i gr fdeps fdefs s = extendOpen qpn gs s   where@@ -72,12 +73,12 @@     qfdefs = L.map (\ (fn, b) -> Flagged (FN (PI qpn i) fn) b [] []) $ M.toList fdefs     gs     = L.map (flip OpenGoal gr) (qfdeps ++ qfdefs) -data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasons+data BuildType = Goals | OneGoal OpenGoal | Instance QPN I PInfo QGoalReasonChain -build :: BuildState -> Tree (QGoalReasons, Scope)+build :: BuildState -> Tree (QGoalReasonChain, Scope) build = ana go   where-    go :: BuildState -> TreeF (QGoalReasons, Scope) BuildState+    go :: BuildState -> TreeF (QGoalReasonChain, Scope) BuildState      -- If we have a choice between many goals, we just record the choice in     -- the tree. We select each open goal in turn, and before we descend, remove@@ -131,7 +132,7 @@  -- | Interface to the tree builder. Just takes an index and a list of package names, -- and computes the initial state and then the tree from there.-buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasons, Scope)+buildTree :: Index -> Bool -> [PN] -> Tree (QGoalReasonChain, Scope) buildTree idx ind igs =     build (BS idx sc                   (M.fromList (L.map (\ qpn -> (qpn, []))                                                     qpns))
cabal/cabal-install/Distribution/Client/Dependency/Modular/Dependency.hs view
@@ -135,11 +135,11 @@  -- | Goals are solver variables paired with information about -- why they have been introduced.-data Goal qpn = Goal (Var qpn) (GoalReasons qpn)+data Goal qpn = Goal (Var qpn) (GoalReasonChain qpn)   deriving (Eq, Show)  instance Functor Goal where-  fmap f (Goal v gr) = Goal (fmap f v) (fmap (fmap f) gr)+  fmap f (Goal v grs) = Goal (fmap f v) (fmap (fmap f) grs)  class ResetGoal f where   resetGoal :: Goal qpn -> f qpn -> f qpn@@ -149,7 +149,7 @@  -- | For open goals as they occur during the build phase, we need to store -- additional information about flags.-data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasons+data OpenGoal = OpenGoal (FlaggedDep QPN) QGoalReasonChain   deriving (Eq, Show)  -- | Reasons why a goal can be added to a goal set.@@ -168,9 +168,9 @@  -- | The first element is the immediate reason. The rest are the reasons -- for the reasons ...-type GoalReasons qpn = [GoalReason qpn]+type GoalReasonChain qpn = [GoalReason qpn] -type QGoalReasons = GoalReasons QPN+type QGoalReasonChain = GoalReasonChain QPN  goalReasonToVars :: GoalReason qpn -> ConflictSet qpn goalReasonToVars UserGoal                 = S.empty@@ -178,9 +178,12 @@ goalReasonToVars (FDependency qfn _)      = S.singleton (F qfn) goalReasonToVars (SDependency qsn)        = S.singleton (S qsn) -goalReasonsToVars :: Ord qpn => GoalReasons qpn -> ConflictSet qpn-goalReasonsToVars = S.unions . L.map goalReasonToVars+goalReasonChainToVars :: Ord qpn => GoalReasonChain qpn -> ConflictSet qpn+goalReasonChainToVars = S.unions . L.map goalReasonToVars +goalReasonChainsToVars :: Ord qpn => [GoalReasonChain qpn] -> ConflictSet qpn+goalReasonChainsToVars = S.unions . L.map goalReasonChainToVars+ -- | Closes a goal, i.e., removes all the extraneous information that we -- need only during the build phase. close :: OpenGoal -> Goal QPN@@ -191,4 +194,4 @@ -- | Compute a conflic set from a goal. The conflict set contains the -- closure of goal reasons as well as the variable of the goal itself. toConflictSet :: Ord qpn => Goal qpn -> ConflictSet qpn-toConflictSet (Goal g gr) = S.insert g (goalReasonsToVars gr)+toConflictSet (Goal g grs) = S.insert g (goalReasonChainToVars grs)
cabal/cabal-install/Distribution/Client/Dependency/Modular/Explore.hs view
@@ -80,24 +80,25 @@     go (PChoiceF qpn _     ts) (A pa fa sa)   =       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> r (A (M.insert qpn k pa) fa sa)) $ -- record the pkg choice+        (\ k r -> r (A (M.insert qpn k pa) fa sa)) -- record the pkg choice       ts     go (FChoiceF qfn _ _ _ ts) (A pa fa sa)   =       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa (M.insert qfn k fa) sa)) $ -- record the flag choice+        (\ k r -> r (A pa (M.insert qfn k fa) sa)) -- record the flag choice       ts     go (SChoiceF qsn _ _   ts) (A pa fa sa)   =       asum $                                      -- try children in order,       P.mapWithKey                                -- when descending ...-        (\ k r -> r (A pa fa (M.insert qsn k sa))) $ -- record the flag choice+        (\ k r -> r (A pa fa (M.insert qsn k sa))) -- record the flag choice       ts     go (GoalChoiceF        ts) a              =       casePSQ ts A.empty                      -- empty goal choice is an internal error         (\ _k v _xs -> v a)                   -- commit to the first goal choice  -- | Version of 'explore' that returns a 'Log'.-exploreLog :: Tree (Maybe (ConflictSet QPN)) -> (Assignment -> Log Message (Assignment, RevDepMap))+exploreLog :: Tree (Maybe (ConflictSet QPN)) ->+              (Assignment -> Log Message (Assignment, RevDepMap)) exploreLog = cata go   where     go (FailF c fr)          _           = failWith (Failure c fr)
cabal/cabal-install/Distribution/Client/Dependency/Modular/IndexConversion.hs view
@@ -92,7 +92,7 @@  -- | Convert a single source package into the solver-specific format. convSP :: OS -> Arch -> CompilerId -> SourcePackage -> (PN, I, PInfo)-convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _pl) =+convSP os arch cid (SourcePackage (PackageIdentifier pn pv) gpd _ _pl) =   let i = I pv InRepo   in  (pn, i, convGPD os arch cid (PI pn i) gpd) @@ -114,10 +114,10 @@     PInfo       (maybe []    (convCondTree os arch cid pi fds (const True)          ) libs    ++        concatMap   (convCondTree os arch cid pi fds (const True)     . snd) exes    ++-      (prefix (Stanza (SN pi TestStanzas))-        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) tests)) ++-      (prefix (Stanza (SN pi BenchStanzas))-        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) benchs)))+      prefix (Stanza (SN pi TestStanzas))+        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) tests)  +++      prefix (Stanza (SN pi BenchStanzas))+        (L.map     (convCondTree os arch cid pi fds (const True)     . snd) benchs))       fds       [] -- TODO: add encaps       Nothing
cabal/cabal-install/Distribution/Client/Dependency/Modular/Log.hs view
@@ -18,6 +18,10 @@ -- Parameterized over the type of actual messages and the final result. type Log m a = Progress m () a +-- | Turns a log into a list of messages paired with a final result. A final result+-- of 'Nothing' indicates failure. A final result of 'Just' indicates success.+-- Keep in mind that forcing the second component of the returned pair will force the+-- entire log. runLog :: Log m a -> ([m], Maybe a) runLog (Done x)       = ([], Just x) runLog (Fail _)       = ([], Nothing)@@ -32,19 +36,24 @@ logToProgress :: Maybe Int -> Log Message a -> Progress String String a logToProgress mbj l = let                         (ms, s) = runLog l+                        -- 'Nothing' for 's' means search tree exhaustively searched and failed                         (es, e) = proc 0 ms -- catch first error (always)+                        -- 'Nothing' in 'e' means no backjump found                         (ns, t) = case mbj of                                      Nothing -> (ms, Nothing)                                      Just n  -> proc n ms+                        -- 'Nothing' in 't' means backjump limit not reached                         -- prefer first error over later error-                        r       = case t of-                                    Nothing -> case s of-                                                 Nothing -> e-                                                 Just _  -> Nothing-                                    Just _  -> e+                        (exh, r) = case t of+                                     -- backjump limit not reached+                                     Nothing -> case s of+                                                  Nothing -> (True, e) -- failed after exhaustive search+                                                  Just _  -> (True, Nothing) -- success+                                     -- backjump limit reached; prefer first error+                                     Just _  -> (False, e) -- failed after backjump limit was reached                       in go es es -- trace for first error                             (showMessages (const True) True ns) -- shortened run-                            r s+                            r s exh   where     -- Proc takes the allowed number of backjumps and a list of messages and explores the     -- message list until the maximum number of backjumps has been reached. The log until@@ -63,18 +72,22 @@     -- in parallel with the full log, but we also want to retain the reference to its     -- beginning for when we print it. This trick prevents a space leak!     ---    -- The thirs argument is the full log, the fifth and six error conditions.+    -- The third argument is the full log, the fifth and six error conditions.+    -- The seventh argument indicates whether the search was exhaustive.     --     -- The order of arguments is important! In particular 's' must not be evaluated     -- unless absolutely necessary. It contains the final result, and if we shortcut     -- with an error due to backjumping, evaluating 's' would still require traversing     -- the entire tree.-    go ms (_ : ns) (x : xs) r         s        = Step x (go ms ns xs r s)-    go ms []       (x : xs) r         s        = Step x (go ms [] xs r s)-    go ms _        []       (Just cs) _        = Fail ("Could not resolve dependencies:\n" ++-                                                 unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms))-    go _  _        []       _         (Just s) = Done s-    go _  _        []       _         _        = Fail ("Could not resolve dependencies.") -- should not happen+    go ms (_ : ns) (x : xs) r         s        exh = Step x (go ms ns xs r s exh)+    go ms []       (x : xs) r         s        exh = Step x (go ms [] xs r s exh)+    go ms _        []       (Just cs) _        exh = Fail $+                                                     "Could not resolve dependencies:\n" +++                                                     unlines (showMessages (L.foldr (\ v _ -> v `S.member` cs) True) False ms) +++                                                     (if exh then "Dependency tree exhaustively searched.\n"+                                                             else "Backjump limit reached (change with --max-backjumps).\n")+    go _  _        []       _         (Just s) _   = Done s+    go _  _        []       _         _        _   = Fail ("Could not resolve dependencies; something strange happened.") -- should not happen  logToProgress' :: Log Message a -> Progress String String a logToProgress' l = let
cabal/cabal-install/Distribution/Client/Dependency/Modular/Message.hs view
@@ -66,7 +66,7 @@       | p v       = x : xs       | otherwise = xs -showGRs :: QGoalReasons -> String+showGRs :: QGoalReasonChain -> String showGRs (gr : _) = showGR gr showGRs []       = ""
cabal/cabal-install/Distribution/Client/Dependency/Modular/PSQ.hs view
@@ -66,10 +66,11 @@     (k, v) : ys -> c k v (PSQ ys)  splits :: PSQ k a -> PSQ k (a, PSQ k a)-splits xs =-  casePSQ xs-    (PSQ [])-    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits ys)))+splits = go id +  where+    go f xs = casePSQ xs+        (PSQ [])+        (\ k v ys -> cons k (v, f ys) (go (f . cons k v) ys))  sortBy :: (a -> a -> Ordering) -> PSQ k a -> PSQ k a sortBy cmp (PSQ xs) = PSQ (S.sortBy (cmp `on` snd) xs)
cabal/cabal-install/Distribution/Client/Dependency/Modular/Preference.hs view
@@ -105,7 +105,7 @@ -- | Traversal that tries to establish various kinds of user constraints. Works -- by selectively disabling choices that have been ruled out by global user -- constraints.-enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasons -> Tree QGoalReasons+enforcePackageConstraints :: M.Map PN [PackageConstraint] -> Tree QGoalReasonChain -> Tree QGoalReasonChain enforcePackageConstraints pcs = trav go   where     go (PChoiceF qpn@(Q _ pn)               gr      ts) =@@ -132,7 +132,7 @@ -- can only be re-set explicitly by the user. This transformation should -- be run after user preferences have been enforced. For manual flags, -- it disables all but the first non-disabled choice.-enforceManualFlags :: Tree QGoalReasons -> Tree QGoalReasons+enforceManualFlags :: Tree QGoalReasonChain -> Tree QGoalReasonChain enforceManualFlags = trav go   where     go (FChoiceF qfn gr tr True ts) = FChoiceF qfn gr tr True $@@ -162,7 +162,7 @@ preferLatest = preferLatestFor (const True)  -- | Require installed packages.-requireInstalled :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+requireInstalled :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) requireInstalled p = trav go   where     go (PChoiceF v@(Q _ pn) i@(gr, _) cs)@@ -186,7 +186,7 @@ -- they are, perhaps this should just result in trying to reinstall those other -- packages as well. However, doing this all neatly in one pass would require to -- change the builder, or at least to change the goal set after building.-avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasons, a) -> Tree (QGoalReasons, a)+avoidReinstalls :: (PN -> Bool) -> Tree (QGoalReasonChain, a) -> Tree (QGoalReasonChain, a) avoidReinstalls p = trav go   where     go (PChoiceF qpn@(Q _ pn) i@(gr, _) cs)@@ -211,7 +211,8 @@ firstGoal :: Tree a -> Tree a firstGoal = trav go   where-    go (GoalChoiceF xs) = casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t)+    go (GoalChoiceF xs) = -- casePSQ xs (GoalChoiceF xs) (\ _ t _ -> out t) -- more space efficient, but removes valuable debug info+                          casePSQ xs (GoalChoiceF (fromList [])) (\ g t _ -> GoalChoiceF (fromList [(g, t)]))     go x                = x     -- Note that we keep empty choice nodes, because they mean success.
cabal/cabal-install/Distribution/Client/Dependency/Modular/Validate.hs view
@@ -80,10 +80,10 @@  type Validate = Reader ValidateState -validate :: Tree (QGoalReasons, Scope) -> Validate (Tree QGoalReasons)+validate :: Tree (QGoalReasonChain, Scope) -> Validate (Tree QGoalReasonChain) validate = cata go   where-    go :: TreeF (QGoalReasons, Scope) (Validate (Tree QGoalReasons)) -> Validate (Tree QGoalReasons)+    go :: TreeF (QGoalReasonChain, Scope) (Validate (Tree QGoalReasonChain)) -> Validate (Tree QGoalReasonChain)      go (PChoiceF qpn (gr,  sc)     ts) = PChoice qpn gr <$> sequence (P.mapWithKey (goP qpn gr sc) ts)     go (FChoiceF qfn (gr, _sc) b m ts) =@@ -117,7 +117,7 @@     go (FailF    c fr              ) = pure (Fail c fr)      -- What to do for package nodes ...-    goP :: QPN -> QGoalReasons -> Scope -> I -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goP :: QPN -> QGoalReasonChain -> Scope -> I -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goP qpn@(Q _pp pn) gr sc i r = do       PA ppa pfa psa <- asks pa    -- obtain current preassignment       idx            <- asks index -- obtain the index@@ -142,7 +142,7 @@                                     local (\ s -> s { pa = PA nppa pfa psa, saved = nsvd }) r      -- What to do for flag nodes ...-    goF :: QFN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goF :: QFN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goF qfn@(FN (PI qpn _i) _f) gr b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment       svd <- asks saved         -- obtain saved dependencies@@ -164,7 +164,7 @@         Right nppa  -> local (\ s -> s { pa = PA nppa npfa psa }) r      -- What to do for stanza nodes (similar to flag nodes) ...-    goS :: QSN -> QGoalReasons -> Bool -> Validate (Tree QGoalReasons) -> Validate (Tree QGoalReasons)+    goS :: QSN -> QGoalReasonChain -> Bool -> Validate (Tree QGoalReasonChain) -> Validate (Tree QGoalReasonChain)     goS qsn@(SN (PI qpn _i) _f) gr b r = do       PA ppa pfa psa <- asks pa -- obtain current preassignment       svd <- asks saved         -- obtain saved dependencies@@ -205,7 +205,7 @@ -- | We try to find new dependencies that become available due to the given -- flag or stanza choice. We therefore look for the choice in question, and then call -- 'extractDeps' for everything underneath.-extractNewDeps :: Var QPN -> QGoalReasons -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN]+extractNewDeps :: Var QPN -> QGoalReasonChain -> Bool -> FAssignment -> SAssignment -> FlaggedDeps QPN -> [Dep QPN] extractNewDeps v gr b fa sa = go   where     go deps = do@@ -228,5 +228,5 @@                                   Just False -> []  -- | Interface.-validateTree :: Index -> Tree (QGoalReasons, Scope) -> Tree QGoalReasons+validateTree :: Index -> Tree (QGoalReasonChain, Scope) -> Tree QGoalReasonChain validateTree idx t = runReader (validate t) (VS idx M.empty (PA M.empty M.empty M.empty))
cabal/cabal-install/Distribution/Client/Dependency/Modular/Version.hs view
@@ -40,4 +40,3 @@ -- | Make a version number. mkV :: [Int] -> Ver mkV xs = CV.Version xs []-
cabal/cabal-install/Distribution/Client/Dependency/TopDown.hs view
@@ -368,7 +368,7 @@                               [ (dep, Constraints.conflicting cs dep)                               | dep <- missing ] -    configure cs (UnconfiguredPackage (SourcePackage _ pkg _) _ flags stanzas) =+    configure cs (UnconfiguredPackage (SourcePackage _ pkg _ _) _ flags stanzas) =       finalizePackageDescription flags (dependencySatisfiable cs)                                  platform comp [] (enableStanzas stanzas pkg)     dependencySatisfiable cs =@@ -397,7 +397,7 @@   InstalledAndSource ipkg apkg -> fmap (InstalledAndSource ipkg)                                        (configure apkg)   where-  configure (UnconfiguredPackage apkg@(SourcePackage _ p _) _ flags stanzas) =+  configure (UnconfiguredPackage apkg@(SourcePackage _ p _ _) _ flags stanzas) =     case finalizePackageDescription flags dependencySatisfiable                                     platform comp [] (enableStanzas stanzas p) of       Left missing        -> Left missing@@ -406,7 +406,7 @@    dependencySatisfiable = not . null . PackageIndex.lookupDependency available --- | Annotate each installed packages with its set of transative dependencies+-- | Annotate each installed packages with its set of transitive dependencies -- and its topological sort number. -- annotateInstalledPackages :: (PackageName -> TopologicalSortNumber)@@ -481,7 +481,7 @@       ++ [ ((), packageName pkg, nub deps)          | pkgs@(pkg:_) <- PackageIndex.allPackagesByName sourcePkgIndex          , let deps = [ depName-                      | SourcePackage _ pkg' _ <- pkgs+                      | SourcePackage _ pkg' _ _ <- pkgs                       , Dependency depName _ <-                           buildDepends (flattenPackageDescription pkg') ] ] @@ -517,7 +517,7 @@                         | pkg <- moreInstalled                         , dep <- depends pkg ]                      ++ [ name-                        | SourcePackage _ pkg _ <- moreSource+                        | SourcePackage _ pkg _ _ <- moreSource                         , Dependency name _ <-                             buildDepends (flattenPackageDescription pkg) ]         installedPkgIndex'' = foldl' (flip PackageIndex.insert)
cabal/cabal-install/Distribution/Client/Dependency/TopDown/Types.hs view
@@ -43,7 +43,7 @@    = InstalledPackageEx        InstalledPackage        !TopologicalSortNumber-       [PackageIdentifier]    -- transative closure of installed deps+       [PackageIdentifier]    -- transitive closure of installed deps  data UnconfiguredPackage    = UnconfiguredPackage
cabal/cabal-install/Distribution/Client/Dependency/Types.hs view
@@ -17,6 +17,7 @@     Solver(..),     DependencyResolver, +    AllowNewer(..), isAllowNewer,     PackageConstraint(..),     PackagePreferences(..),     InstalledPreference(..),@@ -138,7 +139,7 @@ -- data PackagePreferences = PackagePreferences VersionRange InstalledPreference --- | Wether we prefer an installed version of a package or simply the latest+-- | Whether we prefer an installed version of a package or simply the latest -- version. -- data InstalledPreference = PreferInstalled | PreferLatest@@ -167,6 +168,28 @@      --    | PreferLatestForSelected +-- | Policy for relaxing upper bounds in dependencies. For example, given+-- 'build-depends: array >= 0.3 && < 0.5', are we allowed to relax the upper+-- bound and choose a version of 'array' that is greater or equal to 0.5? By+-- default the upper bounds are always strictly honored.+data AllowNewer =++  -- | Default: honor the upper bounds in all dependencies, never choose+  -- versions newer than allowed.+  AllowNewerNone++  -- | Ignore upper bounds in dependencies on the given packages.+  | AllowNewerSome [PackageName]++  -- | Ignore upper bounds in dependencies on all packages.+  | AllowNewerAll++-- | Convert 'AllowNewer' to a boolean.+isAllowNewer :: AllowNewer -> Bool+isAllowNewer AllowNewerNone     = False+isAllowNewer (AllowNewerSome _) = True+isAllowNewer AllowNewerAll      = True+ -- | 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.@@ -175,8 +198,8 @@                              | 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.+-- | 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: --
cabal/cabal-install/Distribution/Client/Fetch.hs view
@@ -37,7 +37,7 @@ import Distribution.Simple.Utils          ( die, notice, debug ) import Distribution.System-         ( buildPlatform )+         ( Platform ) import Distribution.Text          ( display ) import Distribution.Verbosity@@ -66,15 +66,16 @@       -> PackageDBStack       -> [Repo]       -> Compiler+      -> Platform       -> ProgramConfiguration       -> GlobalFlags       -> FetchFlags       -> [UserTarget]       -> IO ()-fetch verbosity _ _ _ _ _ _ [] =+fetch verbosity _ _ _ _ _ _ _ [] =     notice verbosity "No packages requested. Nothing to do." -fetch verbosity packageDBs repos comp conf+fetch verbosity packageDBs repos comp platform conf       globalFlags fetchFlags userTargets = do      mapM_ checkTarget userTargets@@ -88,7 +89,7 @@                        userTargets      pkgs  <- planPackages-               verbosity comp fetchFlags+               verbosity comp platform fetchFlags                installedPkgIndex sourcePkgDb pkgSpecifiers      pkgs' <- filterM (fmap not . isFetched . packageSource) pkgs@@ -111,20 +112,22 @@  planPackages :: Verbosity              -> Compiler+             -> Platform              -> FetchFlags              -> PackageIndex              -> SourcePackageDb              -> [PackageSpecifier SourcePackage]              -> IO [SourcePackage]-planPackages verbosity comp fetchFlags+planPackages verbosity comp platform fetchFlags              installedPkgIndex sourcePkgDb pkgSpecifiers    | includeDependencies = do-      solver <- chooseSolver verbosity (fromFlag (fetchSolver fetchFlags)) (compilerId comp)+      solver <- chooseSolver verbosity+                (fromFlag (fetchSolver fetchFlags)) (compilerId comp)       notice verbosity "Resolving dependencies..."       installPlan <- foldProgress logMsg die return $                        resolveDependencies-                         buildPlatform (compilerId comp)+                         platform (compilerId comp)                          solver                          resolverParams
cabal/cabal-install/Distribution/Client/FetchUtils.hs view
@@ -27,7 +27,7 @@  import Distribution.Client.Types import Distribution.Client.HttpUtils-         ( downloadURI, isOldHackageURI )+         ( downloadURI, isOldHackageURI, DownloadResult(..) )  import Distribution.Package          ( PackageId, packageName, packageVersion )@@ -113,7 +113,7 @@       tmpdir <- getTemporaryDirectory       (path, hnd) <- openTempFile tmpdir "cabal-.tar.gz"       hClose hnd-      downloadURI verbosity uri path+      _ <- downloadURI verbosity uri path       return path  @@ -136,12 +136,12 @@             dir  = packageDir       repo pkgid             path = packageFile      repo pkgid         createDirectoryIfMissing True dir-        downloadURI verbosity uri path+        _ <- downloadURI verbosity uri path         return path  -- | Downloads an index file to [config-dir/packages/serv-id]. ---downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO FilePath+downloadIndex :: Verbosity -> RemoteRepo -> FilePath -> IO DownloadResult downloadIndex verbosity repo cacheDir = do   let uri = (remoteRepoURI repo) {               uriPath = uriPath (remoteRepoURI repo)@@ -150,7 +150,6 @@       path = cacheDir </> "00-index" <.> "tar.gz"   createDirectoryIfMissing True cacheDir   downloadURI verbosity uri path-  return path   -- ------------------------------------------------------------
+ cabal/cabal-install/Distribution/Client/Freeze.hs view
@@ -0,0 +1,172 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Freeze+-- Copyright   :  (c) David Himmelstrup 2005+--                    Duncan Coutts 2011+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@gmail.com+-- Stability   :  provisional+-- Portability :  portable+--+-- The cabal freeze command+-----------------------------------------------------------------------------+module Distribution.Client.Freeze (+    freeze,+  ) where++import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.IndexUtils as IndexUtils+         ( getSourcePackages, getInstalledPackages )+import Distribution.Client.InstallPlan+         ( PlanPackage )+import qualified Distribution.Client.InstallPlan as InstallPlan+import Distribution.Client.Setup+         ( GlobalFlags(..), FreezeFlags(..) )+import Distribution.Client.Sandbox.PackageEnvironment+         ( userPackageEnvironmentFile )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..) )++import Distribution.Package+         ( packageId, packageName, packageVersion )+import Distribution.Simple.Compiler+         ( Compiler(compilerId), PackageDBStack )+import Distribution.Simple.PackageIndex (PackageIndex)+import Distribution.Simple.Program+         ( ProgramConfiguration )+import Distribution.Simple.Setup+         ( fromFlag )+import Distribution.Simple.Utils+         ( die, notice, debug, intercalate, writeFileAtomic )+import Distribution.System+         ( Platform )+import Distribution.Text+         ( display )+import Distribution.Verbosity+         ( Verbosity )++import qualified Data.ByteString.Lazy.Char8 as BS.Char8+import Data.Version+         ( showVersion )++-- ------------------------------------------------------------+-- * The freeze command+-- ------------------------------------------------------------++--TODO:+-- * Don't overwrite all of `cabal.config`, just the constaints section.+-- * Should the package represented by `UserTargetLocalDir "."` be+--   constrained too? What about `base`?+++-- | Freeze all of the dependencies by writing a constraints section+-- constraining each dependency to an exact version.+--+freeze :: Verbosity+      -> PackageDBStack+      -> [Repo]+      -> Compiler+      -> Platform+      -> ProgramConfiguration+      -> Maybe SandboxPackageInfo+      -> GlobalFlags+      -> FreezeFlags+      -> IO ()+freeze verbosity packageDBs repos comp platform conf mSandboxPkgInfo+      globalFlags freezeFlags = do++    installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf+    sourcePkgDb       <- getSourcePackages    verbosity repos++    pkgSpecifiers <- resolveUserTargets verbosity+                       (fromFlag $ globalWorldFile globalFlags)+                       (packageIndex sourcePkgDb)+                       [UserTargetLocalDir "."]++    pkgs  <- planPackages+               verbosity comp platform mSandboxPkgInfo freezeFlags+               installedPkgIndex sourcePkgDb pkgSpecifiers++    if null pkgs+      then notice verbosity $ "No packages to be frozen. "+                           ++ "As this package has no dependencies."+      else if dryRun+             then notice verbosity $ unlines $+                     "The following packages would be frozen:"+                   : formatPkgs pkgs++             else freezePackages pkgs++  where+    dryRun = fromFlag (freezeDryRun freezeFlags)+++planPackages :: Verbosity+             -> Compiler+             -> Platform+             -> Maybe SandboxPackageInfo+             -> FreezeFlags+             -> PackageIndex+             -> SourcePackageDb+             -> [PackageSpecifier SourcePackage]+             -> IO [PlanPackage]+planPackages verbosity comp platform mSandboxPkgInfo freezeFlags+             installedPkgIndex sourcePkgDb pkgSpecifiers = do++  solver <- chooseSolver verbosity+            (fromFlag (freezeSolver freezeFlags)) (compilerId comp)+  notice verbosity "Resolving dependencies..."++  installPlan <- foldProgress logMsg die return $+                   resolveDependencies+                     platform (compilerId comp)+                     solver+                     resolverParams++  return $ InstallPlan.toList installPlan++  where+    resolverParams =++        setMaxBackjumps (if maxBackjumps < 0 then Nothing+                                             else Just maxBackjumps)++      . setIndependentGoals independentGoals++      . setReorderGoals reorderGoals++      . setShadowPkgs shadowPkgs++      . maybe id applySandboxInstallPolicy mSandboxPkgInfo++      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers++    logMsg message rest = debug verbosity message >> rest++    reorderGoals     = fromFlag (freezeReorderGoals     freezeFlags)+    independentGoals = fromFlag (freezeIndependentGoals freezeFlags)+    shadowPkgs       = fromFlag (freezeShadowPkgs       freezeFlags)+    maxBackjumps     = fromFlag (freezeMaxBackjumps     freezeFlags)++freezePackages :: [PlanPackage] -> IO ()+freezePackages pkgs =+    writeFileAtomic userPackageEnvironmentFile $ constraints pkgs+  where+    constraints = BS.Char8.pack+                . (++ "\n")+                . (prefix' ++)+                . intercalate separator+                . formatPkgs+    prefix' = "constraints: "+    separator = "\n" ++ (replicate (length prefix' - 2) ' ') ++ ", "+++formatPkgs :: [PlanPackage] -> [String]+formatPkgs = map $ showPkg . packageId+  where+    showPkg pid = name pid ++ " == " ++ version pid+    name = display . packageName+    version = showVersion . packageVersion
cabal/cabal-install/Distribution/Client/GZipUtils.hs view
@@ -27,7 +27,7 @@ -- -- This is to deal with http proxies that lie to us and transparently -- decompress without removing the content-encoding header. See:--- <http://hackage.haskell.org/trac/hackage/ticket/686>+-- <https://github.com/haskell/cabal/issues/678> -- maybeDecompress :: ByteString -> ByteString maybeDecompress bytes = foldStream $ decompressWithErrors gzipOrZlibFormat defaultDecompressParams bytes
+ cabal/cabal-install/Distribution/Client/Get.hs view
@@ -0,0 +1,352 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Get+-- Copyright   :  (c) Andrea Vezzosi 2008+--                    Duncan Coutts 2011+--                    John Millikin 2012+-- License     :  BSD-like+--+-- Maintainer  :  cabal-devel@haskell.org+-- Stability   :  provisional+-- Portability :  portable+--+-- The 'cabal get' command.+-----------------------------------------------------------------------------++module Distribution.Client.Get (+    get+  ) where++import Distribution.Package+         ( PackageId, packageId, packageName )+import Distribution.Simple.Setup+         ( Flag(..), fromFlag, fromFlagOrDefault )+import Distribution.Simple.Utils+         ( notice, die, info, writeFileAtomic )+import Distribution.Verbosity+         ( Verbosity )+import Distribution.Text(display)+import qualified Distribution.PackageDescription as PD++import Distribution.Client.Setup+         ( GlobalFlags(..), GetFlags(..) )+import Distribution.Client.Types+import Distribution.Client.Targets+import Distribution.Client.Dependency+import Distribution.Client.FetchUtils+import qualified Distribution.Client.Tar as Tar (extractTarGzFile)+import Distribution.Client.IndexUtils as IndexUtils+        ( getSourcePackages )+import Distribution.Client.Compat.Process+        ( readProcessWithExitCode )+import Distribution.Compat.Exception+        ( catchIO )++import Control.Exception+         ( finally )+import Control.Monad+         ( filterM, forM_, unless, when )+import Data.List+         ( sortBy )+import qualified Data.Map+import Data.Maybe+         ( listToMaybe, mapMaybe )+import Data.Monoid+         ( mempty )+import Data.Ord+         ( comparing )+import System.Directory+         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist+         , getCurrentDirectory, setCurrentDirectory+         )+import System.Exit+         ( ExitCode(..) )+import System.FilePath+         ( (</>), (<.>), addTrailingPathSeparator )+import System.Process+         ( rawSystem )+++-- | Entry point for the 'cabal get' command.+get :: Verbosity+    -> [Repo]+    -> GlobalFlags+    -> GetFlags+    -> [UserTarget]+    -> IO ()+get verbosity _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."++get verbosity repos globalFlags getFlags userTargets = do+  let useFork = case (getSourceRepository getFlags) of+        NoFlag -> False+        _      -> True++  unless useFork $+    mapM_ checkTarget userTargets++  sourcePkgDb <- getSourcePackages verbosity repos++  pkgSpecifiers <- resolveUserTargets verbosity+                   (fromFlag $ globalWorldFile globalFlags)+                   (packageIndex sourcePkgDb)+                   userTargets++  pkgs <- either (die . unlines . map show) return $+            resolveWithoutDependencies+              (resolverParams sourcePkgDb pkgSpecifiers)++  unless (null prefix) $+    createDirectoryIfMissing True prefix++  if useFork+    then fork pkgs+    else unpack pkgs++  where+    resolverParams sourcePkgDb pkgSpecifiers =+        --TODO: add commandline constraint and preference args for unpack+        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers++    prefix = fromFlagOrDefault "" (getDestDir getFlags)++    fork :: [SourcePackage] -> IO ()+    fork pkgs = do+      let kind = fromFlag . getSourceRepository $ getFlags+      branchers <- findUsableBranchers+      mapM_ (forkPackage verbosity branchers prefix kind) pkgs++    unpack :: [SourcePackage] -> IO ()+    unpack pkgs = do+      forM_ pkgs $ \pkg -> do+        location <- fetchPackage verbosity (packageSource pkg)+        let pkgid = packageId pkg+            descOverride | usePristine = Nothing+                         | otherwise   = packageDescrOverride pkg+        case location of+          LocalTarballPackage tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          RemoteTarballPackage _tarballURL tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          RepoTarballPackage _repo _pkgid tarballPath ->+            unpackPackage verbosity prefix pkgid descOverride tarballPath++          LocalUnpackedPackage _ ->+            error "Distribution.Client.Get.unpack: the impossible happened."+      where+        usePristine = fromFlagOrDefault False (getPristine getFlags)++checkTarget :: UserTarget -> IO ()+checkTarget target = case target of+    UserTargetLocalDir       dir  -> die (notTarball dir)+    UserTargetLocalCabalFile file -> die (notTarball file)+    _                             -> return ()+  where+    notTarball t =+        "The 'get' command is for tarball packages. "+     ++ "The target '" ++ t ++ "' is not a tarball."++-- ------------------------------------------------------------+-- * Unpacking the source tarball+-- ------------------------------------------------------------++unpackPackage :: Verbosity -> FilePath -> PackageId+              -> PackageDescriptionOverride+              -> FilePath  -> IO ()+unpackPackage verbosity prefix pkgid descOverride 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++    case descOverride of+      Nothing     -> return ()+      Just pkgtxt -> do+        let descFilePath = pkgdir </> display (packageName pkgid) <.> "cabal"+        info verbosity $+          "Updating " ++ descFilePath+                      ++ " with the latest revision from the index."+        writeFileAtomic descFilePath pkgtxt+++-- ------------------------------------------------------------+-- * Forking the source repository+-- ------------------------------------------------------------++data BranchCmd = BranchCmd (Verbosity -> FilePath -> IO ExitCode)++data Brancher = Brancher+    { brancherBinary :: String+    , brancherBuildCmd :: PD.SourceRepo -> Maybe BranchCmd+    }++-- | The set of all supported branch drivers.+allBranchers :: [(PD.RepoType, Brancher)]+allBranchers =+    [ (PD.Bazaar, branchBzr)+    , (PD.Darcs, branchDarcs)+    , (PD.Git, branchGit)+    , (PD.Mercurial, branchHg)+    , (PD.SVN, branchSvn)+    ]++-- | Find which usable branch drivers (selected from 'allBranchers') are+-- available and usable on the local machine.+--+-- Each driver's main command is run with @--help@, and if the child process+-- exits successfully, that brancher is considered usable.+findUsableBranchers :: IO (Data.Map.Map PD.RepoType Brancher)+findUsableBranchers = do+    let usable (_, brancher) = flip catchIO (const (return False)) $ do+         let cmd = brancherBinary brancher+         (exitCode, _, _) <- readProcessWithExitCode cmd ["--help"] ""+         return (exitCode == ExitSuccess)+    pairs <- filterM usable allBranchers+    return (Data.Map.fromList pairs)++-- | Fork a single package from a remote source repository to the local+-- filesystem.+forkPackage :: Verbosity+            -> Data.Map.Map PD.RepoType Brancher+               -- ^ Branchers supported by the local machine.+            -> FilePath+               -- ^ The directory in which new branches or repositories will+               -- be created.+            -> (Maybe PD.RepoKind)+               -- ^ Which repo to choose.+            -> SourcePackage+               -- ^ The package to fork.+            -> IO ()+forkPackage verbosity branchers prefix kind src = do+    let desc    = PD.packageDescription (packageDescription src)+        pkgid   = display (packageId src)+        pkgname = display (packageName src)+        destdir = prefix </> pkgname++    destDirExists <- doesDirectoryExist destdir+    when destDirExists $ do+        die ("The directory " ++ show destdir ++ " already exists, not forking.")++    destFileExists  <- doesFileExist destdir+    when destFileExists $ do+        die ("A file " ++ show destdir ++ " is in the way, not forking.")++    let repos = PD.sourceRepos desc+    case findBranchCmd branchers repos kind of+        Just (BranchCmd io) -> do+            exitCode <- io verbosity destdir+            case exitCode of+                ExitSuccess -> return ()+                ExitFailure _ -> die ("Couldn't fork package " ++ pkgid)+        Nothing -> case repos of+            [] -> die ("Package " ++ pkgid+                       ++ " does not have any source repositories.")+            _ -> die ("Package " ++ pkgid+                      ++ " does not have any usable source repositories.")++-- | Given a set of possible branchers, and a set of possible source+-- repositories, find a repository that is both 1) likely to be specific to+-- this source version and 2) is supported by the local machine.+findBranchCmd :: Data.Map.Map PD.RepoType Brancher -> [PD.SourceRepo]+                 -> (Maybe PD.RepoKind) -> Maybe BranchCmd+findBranchCmd branchers allRepos maybeKind = cmd where+    -- Sort repositories by kind, from This to Head to Unknown. Repositories+    -- with equivalent kinds are selected based on the order they appear in+    -- the Cabal description file.+    repos' = sortBy (comparing thisFirst) allRepos+    thisFirst r = case PD.repoKind r of+        PD.RepoThis -> 0 :: Int+        PD.RepoHead -> case PD.repoTag r of+            -- If the type is 'head' but the author specified a tag, they+            -- probably meant to create a 'this' repository but screwed up.+            Just _ -> 0+            Nothing -> 1+        PD.RepoKindUnknown _ -> 2++    -- If the user has specified the repo kind, filter out the repositories+    -- she's not interested in.+    repos = maybe repos' (\k -> filter ((==) k . PD.repoKind) repos') maybeKind++    repoBranchCmd repo = do+        t <- PD.repoType repo+        brancher <- Data.Map.lookup t branchers+        brancherBuildCmd brancher repo++    cmd = listToMaybe (mapMaybe repoBranchCmd repos)++-- | Branch driver for Bazaar.+branchBzr :: Brancher+branchBzr = Brancher "bzr" $ \repo -> do+    src <- PD.repoLocation repo+    let args dst = case PD.repoTag repo of+         Just tag -> ["branch", src, dst, "-r", "tag:" ++ tag]+         Nothing -> ["branch", src, dst]+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("bzr: branch " ++ show src)+        rawSystem "bzr" (args dst)++-- | Branch driver for Darcs.+branchDarcs :: Brancher+branchDarcs = Brancher "darcs" $ \repo -> do+    src <- PD.repoLocation repo+    let args dst = case PD.repoTag repo of+         Just tag -> ["get", src, dst, "-t", tag]+         Nothing -> ["get", src, dst]+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("darcs: get " ++ show src)+        rawSystem "darcs" (args dst)++-- | Branch driver for Git.+branchGit :: Brancher+branchGit = Brancher "git" $ \repo -> do+    src <- PD.repoLocation repo+    let branchArgs = case PD.repoBranch repo of+         Just b -> ["--branch", b]+         Nothing -> []+    let postClone dst = case PD.repoTag repo of+         Just t -> do+             cwd <- getCurrentDirectory+             setCurrentDirectory dst+             finally+                 (rawSystem "git" (["checkout", t] ++ branchArgs))+                 (setCurrentDirectory cwd)+         Nothing -> return ExitSuccess+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("git: clone " ++ show src)+        code <- rawSystem "git" (["clone", src, dst] ++ branchArgs)+        case code of+            ExitFailure _ -> return code+            ExitSuccess -> postClone dst++-- | Branch driver for Mercurial.+branchHg :: Brancher+branchHg = Brancher "hg" $ \repo -> do+    src <- PD.repoLocation repo+    let branchArgs = case PD.repoBranch repo of+         Just b -> ["--branch", b]+         Nothing -> []+    let tagArgs = case PD.repoTag repo of+         Just t -> ["--rev", t]+         Nothing -> []+    let args dst = ["clone", src, dst] ++ branchArgs ++ tagArgs+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("hg: clone " ++ show src)+        rawSystem "hg" (args dst)++-- | Branch driver for Subversion.+branchSvn :: Brancher+branchSvn = Brancher "svn" $ \repo -> do+    src <- PD.repoLocation repo+    let args dst = ["checkout", src, dst]+    return $ BranchCmd $ \verbosity dst -> do+        notice verbosity ("svn: checkout " ++ show src)+        rawSystem "svn" (args dst)
cabal/cabal-install/Distribution/Client/Haddock.hs view
@@ -21,7 +21,7 @@ import Control.Monad (guard) import System.Directory (createDirectoryIfMissing, doesFileExist,                          renameFile)-import System.FilePath ((</>), splitFileName)+import System.FilePath ((</>), splitFileName, isAbsolute) import Distribution.Package          ( Package(..), packageVersion ) import Distribution.Simple.Program (haddockProgram, ProgramConfiguration@@ -96,6 +96,14 @@   where     interfaceAndHtmlPath pkg = do       interface <- listToMaybe (InstalledPackageInfo.haddockInterfaces pkg)-      html <- listToMaybe (InstalledPackageInfo.haddockHTMLs pkg)+      html <- fmap fixFileUrl+                   (listToMaybe (InstalledPackageInfo.haddockHTMLs pkg))       guard (not . null $ html)       return (interface, html)+    +    -- the 'haddock-html' field in the hc-pkg output is often set as a+    -- native path, but we need it as a URL.+    -- See https://github.com/haskell/cabal/issues/1064+    fixFileUrl f | isAbsolute f = "file://" ++ f+                 | otherwise    = f+
cabal/cabal-install/Distribution/Client/HttpUtils.hs view
@@ -1,8 +1,8 @@-{-# OPTIONS -cpp #-} -------------------------------------------------------------------------------- | Separate module for HTTP actions, using a proxy server if one exists +-- | Separate module for HTTP actions, using a proxy server if one exists ----------------------------------------------------------------------------- module Distribution.Client.HttpUtils (+    DownloadResult(..),     downloadURI,     getHTTP,     cabalBrowse,@@ -12,148 +12,71 @@  import Network.HTTP          ( Request (..), Response (..), RequestMethod (..)-         , Header(..), HeaderName(..) )+         , Header(..), HeaderName(..), lookupHeader )+import Network.HTTP.Proxy ( Proxy(..), fetchProxy) import Network.URI-         ( URI (..), URIAuth (..), parseAbsoluteURI )-import Network.Stream-         ( Result, ConnError(..) )+         ( URI (..), URIAuth (..) ) import Network.Browser-         ( Proxy (..), Authority (..), BrowserAction, browse+         ( BrowserAction, browse          , setOutHandler, setErrHandler, setProxy, setAuthorityGen, request)+import Network.Stream+         ( Result, ConnError(..) ) import Control.Monad-         ( mplus, join, liftM, liftM2 )+         ( liftM ) import qualified Data.ByteString.Lazy.Char8 as ByteString import Data.ByteString.Lazy (ByteString)-#ifdef WIN32-import System.Win32.Types-         ( DWORD, HKEY )-import System.Win32.Registry-         ( hKEY_CURRENT_USER, regOpenKey, regCloseKey-         , regQueryValue, regQueryValueEx )-import Control.Exception-         ( bracket )-import Distribution.Compat.ExceptionCI-         ( handleIO )-import Foreign-         ( toBool, Storable(peek, sizeOf), castPtr, alloca )-#endif-import System.Environment (getEnvironment)  import qualified Paths_cabal_install (version) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, info, warn, debug+         ( die, info, warn, debug, notice          , copyFileVerbose, writeFileAtomic ) import Distribution.Text          ( display )+import Data.Char ( isSpace ) 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)+import System.FilePath+         ( (<.>) )+import System.Directory+         ( doesFileExist ) -proxyString = liftM2 mplus envProxyString registryProxyString+data DownloadResult = FileAlreadyInCache | FileDownloaded FilePath deriving (Eq) +-- Trime+trim :: String -> String+trim = f . f+      where f = reverse . dropWhile isSpace --- |Get the local proxy settings  +-- |Get the local proxy settings+--TODO: print info message when we're using a proxy based on verbosity 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+proxy _verbosity = do+  p <- fetchProxy True+  -- Handle empty proxy strings+  return $ case p of+    Proxy uri auth ->+      let uri' = trim uri in+      if uri' == "" then NoProxy else Proxy uri' auth+    _ -> p -mkRequest :: URI -> Request ByteString-mkRequest uri = Request{ rqURI     = uri-                       , rqMethod  = GET-                       , rqHeaders = [Header HdrUserAgent userAgent]-                       , rqBody    = ByteString.empty }+mkRequest :: URI+          -> Maybe String -- ^ Optional etag to be set in the If-None-Match HTTP header.+          -> Request ByteString+mkRequest uri etag = Request{ rqURI     = uri+                            , rqMethod  = GET+                            , rqHeaders = Header HdrUserAgent userAgent : ifNoneMatchHdr+                            , rqBody    = ByteString.empty }   where userAgent = "cabal-install/" ++ display Paths_cabal_install.version+        ifNoneMatchHdr = maybe [] (\t -> [Header HdrIfNoneMatch t]) etag  -- |Carry out a GET request, using the local proxy settings-getHTTP :: Verbosity -> URI -> IO (Result (Response ByteString))-getHTTP verbosity uri = liftM (\(_, resp) -> Right resp) $-                              cabalBrowse verbosity (return ()) (request (mkRequest uri))+getHTTP :: Verbosity+        -> URI+        -> Maybe String -- ^ Optional etag to check if we already have the latest file.+        -> IO (Result (Response ByteString))+getHTTP verbosity uri etag = liftM (\(_, resp) -> Right resp) $+                                   cabalBrowse verbosity (return ()) (request (mkRequest uri etag))  cabalBrowse :: Verbosity             -> BrowserAction s ()@@ -172,29 +95,56 @@ downloadURI :: Verbosity             -> URI      -- ^ What to download             -> FilePath -- ^ Where to put it-            -> IO ()-downloadURI verbosity uri path | uriScheme uri == "file:" =+            -> IO DownloadResult+downloadURI verbosity uri path | uriScheme uri == "file:" = do   copyFileVerbose verbosity (uriPath uri) path+  return (FileDownloaded path)+  -- Can we store the hash of the file so we can safely return path when the+  -- hash matches to avoid unnecessary computation? downloadURI verbosity uri path = do-  result <- getHTTP verbosity uri+  let etagPath = path <.> "etag"+  targetExists   <- doesFileExist path+  etagPathExists <- doesFileExist etagPath+  -- In rare cases the target file doesn't exist, but the etag does.+  etag <- if targetExists && etagPathExists+            then liftM Just $ readFile etagPath+            else return Nothing++  result <- getHTTP verbosity uri etag   let result' = case result of         Left  err -> Left err         Right rsp -> case rspCode rsp of-          (2,0,0) -> Right (rspBody rsp)+          (2,0,0) -> Right rsp+          (3,0,4) -> Right rsp           (a,b,c) -> Left err             where-              err = ErrorMisc $ "Unsucessful HTTP code: "-                             ++ concatMap show [a,b,c]+              err = ErrorMisc $ "Error HTTP code: "+                                ++ concatMap show [a,b,c] +  -- Only write the etag if we get a 200 response code.+  -- A 304 still sends us an etag header.   case result' of+    Left _ -> return ()+    Right rsp -> case rspCode rsp of+      (2,0,0) -> case lookupHeader HdrETag (rspHeaders rsp) of+        Nothing -> return ()+        Just newEtag -> writeFile etagPath newEtag+      (_,_,_) -> return ()++  case result' of     Left err   -> die $ "Failed to download " ++ show uri ++ " : " ++ show err-    Right body -> do-      info verbosity ("Downloaded to " ++ path)-      writeFileAtomic path body+    Right rsp -> case rspCode rsp of+      (2,0,0) -> do+        info verbosity ("Downloaded to " ++ path)+        writeFileAtomic path $ rspBody rsp+        return (FileDownloaded path)+      (3,0,4) -> do+        notice verbosity "Skipping download: Local and remote files match."+        return FileAlreadyInCache+      (_,_,_) -> return (FileDownloaded path)       --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
− cabal/cabal-install/Distribution/Client/Index.hs 
@@ -1,218 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Index--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Querying and modifying local build tree references in the package index.--------------------------------------------------------------------------------module Distribution.Client.Index (-    index,--    createEmpty,-    addBuildTreeRefs,-    removeBuildTreeRefs,-    listBuildTreeRefs,--    defaultIndexFileName-  ) where--import qualified Distribution.Client.Tar as Tar-import Distribution.Client.IndexUtils ( getSourcePackages )-import Distribution.Client.PackageIndex ( allPackages )-import Distribution.Client.Setup ( IndexFlags(..) )-import Distribution.Client.Types ( Repo(..), LocalRepo(..)-                                 , SourcePackageDb(..)-                                 , SourcePackage(..), PackageLocation(..) )-import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString-                                 , makeAbsoluteToCwd )--import Distribution.Simple.Setup ( fromFlagOrDefault )-import Distribution.Simple.Utils ( die, debug, notice, findPackageDesc )-import Distribution.Verbosity    ( Verbosity )--import qualified Data.ByteString.Lazy as BS-import Control.Exception         ( evaluate )-import Control.Monad             ( liftM, when, unless )-import Data.List                 ( (\\), nub )-import Data.Maybe                ( catMaybes )-import System.Directory          ( canonicalizePath, createDirectoryIfMissing,-                                   doesDirectoryExist, doesFileExist,-                                   renameFile )-import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension )-import System.IO                 ( IOMode(..), SeekMode(..)-                                 , hSeek, withBinaryFile )---- | A reference to a local build tree.-newtype BuildTreeRef = BuildTreeRef {-  buildTreePath :: FilePath-  }--defaultIndexFileName :: FilePath-defaultIndexFileName = "00-index.tar"---- | Entry point for the 'cabal index' command.-index :: Verbosity -> IndexFlags -> FilePath -> IO ()-index verbosity indexFlags path' = do-  let runInit         = fromFlagOrDefault False (indexInit indexFlags)-  let refsToAdd       = indexLinkSource indexFlags-  let runLinkSource   = not . null $ refsToAdd-  let refsToRemove    = indexRemoveSource indexFlags-  let runRemoveSource = not . null $ refsToRemove-  let runList         = fromFlagOrDefault False (indexList indexFlags)--  unless (or [runInit, runLinkSource, runRemoveSource, runList]) $ do-    die "no arguments passed to the 'index' command"--  path <- validateIndexPath path'--  when runInit $ do-    createEmpty verbosity path--  when runLinkSource $ do-    addBuildTreeRefs verbosity path refsToAdd--  when runRemoveSource $ do-    removeBuildTreeRefs verbosity path refsToRemove--  when runList $ do-    refs <- listBuildTreeRefs verbosity path-    mapM_ putStrLn refs---- | Given a path, ensure that it refers to a local build tree.-buildTreeRefFromPath :: FilePath -> IO (Maybe BuildTreeRef)-buildTreeRefFromPath dir = do-  dirExists <- doesDirectoryExist dir-  when (not dirExists) $ do-    die $ "directory '" ++ dir ++ "' does not exist"-  _ <- findPackageDesc dir-  return . Just $ BuildTreeRef { buildTreePath = dir }---- | Given a tar archive entry, try to parse it as a local build tree reference.-readBuildTreePath :: Tar.Entry -> Maybe FilePath-readBuildTreePath entry = case Tar.entryContent entry of-  (Tar.OtherEntryType typeCode bs size)-    | (typeCode == Tar.buildTreeRefTypeCode)-      && (size == BS.length bs) -> Just $ byteStringToFilePath bs-    | otherwise                 -> Nothing-  _ -> Nothing---- | Given a sequence of tar archive entries, extract all references to local--- build trees.-readBuildTreePaths :: Tar.Entries -> [FilePath]-readBuildTreePaths =-  catMaybes-  . Tar.foldrEntries (\e r -> (readBuildTreePath e):r)-  [] error---- | Given a path to a tar archive, extract all references to local build trees.-readBuildTreePathsFromFile :: FilePath -> IO [FilePath]-readBuildTreePathsFromFile = liftM (readBuildTreePaths . Tar.read)-                                  . BS.readFile---- | Given a local build tree, serialise it to a tar archive entry.-writeBuildTreeRef :: BuildTreeRef -> Tar.Entry-writeBuildTreeRef lbt = Tar.simpleEntry tarPath content-  where-    bs       = filePathToByteString path-    path     = buildTreePath lbt-    -- fromRight can't fail because the path is shorter than 255 characters.-    tarPath  = fromRight $ Tar.toTarPath True tarPath'-    -- Provide a filename for tools that treat custom entries as ordinary files.-    tarPath' = "local-build-tree-reference"-    content  = Tar.OtherEntryType Tar.buildTreeRefTypeCode bs (BS.length bs)--    -- TODO: Move this to D.C.Utils?-    fromRight (Left err) = error err-    fromRight (Right a)  = a---- | Check that the provided path is either an existing directory, or a tar--- archive in an existing directory.-validateIndexPath :: FilePath -> IO FilePath-validateIndexPath path' = do-   path <- makeAbsoluteToCwd path'-   if (== ".tar") . takeExtension $ path-     then return path-     else do dirExists <- doesDirectoryExist path-             unless dirExists $ do-               die $ "directory does not exist: '" ++ path ++ "'"-             return $ path </> defaultIndexFileName---- | Create an empty index file.-createEmpty :: Verbosity -> FilePath -> IO ()-createEmpty verbosity path = do-  indexExists <- doesFileExist path-  if indexExists-    then debug verbosity $ "Package index already exists: " ++ path-    else do-    debug verbosity $ "Creating the index file '" ++ path ++ "'"-    createDirectoryIfMissing True (takeDirectory path)-    -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'.-    let zeros = BS.replicate (512*20) 0-    BS.writeFile path zeros---- | Add given local build tree references to the index.-addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO ()-addBuildTreeRefs _         _   [] =-  error "Distribution.Client.Index.addBuildTreeRefs: unexpected"-addBuildTreeRefs verbosity path l' = do-  checkIndexExists path-  l <- liftM nub . mapM canonicalizePath $ l'-  treesInIndex <- readBuildTreePathsFromFile path-  -- Add only those paths that aren't already in the index.-  treesToAdd <- mapM buildTreeRefFromPath (l \\ treesInIndex)-  let entries = map writeBuildTreeRef (catMaybes treesToAdd)-  when (not . null $ entries) $ do-    offset <--      fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error-            . Tar.read) $ BS.readFile path-    _ <- evaluate offset-    debug verbosity $ "Writing at offset: " ++ show offset-    withBinaryFile path ReadWriteMode $ \h -> do-      hSeek h AbsoluteSeek (fromIntegral offset)-      BS.hPut h (Tar.write entries)-      debug verbosity $ "Successfully appended to '" ++ path ++ "'"---- | Remove given local build tree references from the index.-removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO ()-removeBuildTreeRefs _         _   [] =-  error "Distribution.Client.Index.removeBuildTreeRefs: unexpected"-removeBuildTreeRefs verbosity path l' = do-  checkIndexExists path-  l <- mapM canonicalizePath l'-  let tmpFile = path <.> "tmp"-  -- Performance note: on my system, it takes 'index --remove-source'-  -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be-  -- much smaller.-  BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read-    =<< BS.readFile path-  -- This invalidates the cache, so we don't have to update it explicitly.-  renameFile tmpFile path-  debug verbosity $ "Successfully renamed '" ++ tmpFile-    ++ "' to '" ++ path ++ "'"-    where-      p l entry = case readBuildTreePath entry of-        Nothing    -> True-        (Just pth) -> not $ any (== pth) l---- | List the local build trees that are referred to from the index.-listBuildTreeRefs :: Verbosity -> FilePath -> IO [FilePath]-listBuildTreeRefs verbosity path = do-  checkIndexExists path-  let repo = Repo { repoKind = Right LocalRepo-                  , repoLocalDir = takeDirectory path }-  pkgIndex <- fmap packageIndex . getSourcePackages verbosity $ [repo]-  let buildTreeRefs = [ pkgPath | (LocalUnpackedPackage pkgPath) <--                           map packageSource . allPackages $ pkgIndex ]-  when (null buildTreeRefs) $ do-    notice verbosity $ "Index file '" ++ path-      ++ "' has no references to local build trees."-  return buildTreeRefs---- | Check that the package index file exists and exit with error if it does not.-checkIndexExists :: FilePath -> IO ()-checkIndexExists path = do-  indexExists <- doesFileExist path-  when (not indexExists) $ do-    die $ "index does not exist: '" ++ path ++ "'"
cabal/cabal-install/Distribution/Client/IndexUtils.hs view
@@ -13,12 +13,15 @@ module Distribution.Client.IndexUtils (   getInstalledPackages,   getSourcePackages,+  getSourcePackagesStrict,   convert,    readPackageIndexFile,   parsePackageIndex,   readRepoIndex,   updateRepoIndexCache,++  BuildTreeRefType(..), refTypeFromTypeCode, typeCodeFromRefType   ) where  import qualified Distribution.Client.Tar as Tar@@ -29,9 +32,9 @@          , Package(..), packageVersion, packageName          , 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 qualified Distribution.Client.PackageIndex      as PackageIndex+import qualified Distribution.Simple.PackageIndex      as InstalledPackageIndex+import qualified Distribution.InstalledPackageInfo     as InstalledPackageInfo import qualified Distribution.PackageDescription.Parse as PackageDesc.Parse import Distribution.PackageDescription          ( GenericPackageDescription )@@ -52,14 +55,14 @@ import Distribution.Verbosity          ( Verbosity, normal, lessVerbose ) import Distribution.Simple.Utils-         ( die, warn, info, fromUTF8, findPackageDesc )+         ( die, warn, info, fromUTF8, tryFindPackageDesc )  import Data.Char   (isAlphaNum)-import Data.Maybe  (catMaybes, fromMaybe)+import Data.Maybe  (mapMaybe, fromMaybe) import Data.List   (isPrefixOf) import Data.Monoid (Monoid(..)) import qualified Data.Map as Map-import Control.Monad (MonadPlus(mplus), when, unless, liftM)+import Control.Monad (MonadPlus(mplus), when, liftM) import Control.Exception (evaluate) import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8@@ -67,16 +70,15 @@ import Data.ByteString.Lazy (ByteString) import Distribution.Client.GZipUtils (maybeDecompress) import Distribution.Client.Utils (byteStringToFilePath)+import Distribution.Compat.Exception (catchIO)+import Distribution.Client.Compat.Time (getFileAge, getModTime)+import System.Directory (doesFileExist) import System.FilePath ((</>), takeExtension, splitDirectories, normalise) import System.FilePath.Posix as FilePath.Posix          ( takeFileName ) import System.IO import System.IO.Unsafe (unsafeInterleaveIO) import System.IO.Error (isDoesNotExistError)-import Distribution.Compat.Exception (catchIO)-import System.Directory-         ( getModificationTime, doesFileExist )-import Distribution.Compat.Time   getInstalledPackages :: Verbosity -> Compiler@@ -130,16 +132,29 @@ -- This is a higher level wrapper used internally in cabal-install. -- getSourcePackages :: Verbosity -> [Repo] -> IO SourcePackageDb-getSourcePackages verbosity [] = do+getSourcePackages verbosity repos = getSourcePackages' verbosity repos+                                    ReadPackageIndexLazyIO++-- | Like 'getSourcePackages', but reads the package index strictly. Useful if+-- you want to write to the package index after having read it.+getSourcePackagesStrict :: Verbosity -> [Repo] -> IO SourcePackageDb+getSourcePackagesStrict verbosity repos = getSourcePackages' verbosity repos+                                          ReadPackageIndexStrict++-- | Common implementation used by getSourcePackages and+-- getSourcePackagesStrict.+getSourcePackages' :: Verbosity -> [Repo] -> ReadPackageIndexMode+                      -> IO SourcePackageDb+getSourcePackages' verbosity [] _mode = do   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file."   return SourcePackageDb {     packageIndex       = mempty,     packagePreferences = mempty   }-getSourcePackages verbosity repos = do+getSourcePackages' verbosity repos mode = do   info verbosity "Reading available packages..."-  pkgss <- mapM (readRepoIndex verbosity) repos+  pkgss <- mapM (\r -> readRepoIndex verbosity r mode) repos   let (pkgs, prefs) = mconcat pkgss       prefs' = Map.fromListWith intersectVersionRanges                  [ (name, range) | Dependency name range <- prefs ]@@ -157,17 +172,17 @@ -- -- This is a higher level wrapper used internally in cabal-install. ---readRepoIndex :: Verbosity -> Repo+readRepoIndex :: Verbosity -> Repo -> ReadPackageIndexMode               -> IO (PackageIndex SourcePackage, [Dependency])-readRepoIndex verbosity repo =+readRepoIndex verbosity repo mode =   let indexFile = repoLocalDir repo </> "00-index.tar"       cacheFile = repoLocalDir repo </> "00-index.cache"   in handleNotFound $ do     warnIfIndexIsOld indexFile     whenCacheOutOfDate indexFile cacheFile $ do-      info verbosity $ "Updating the index cache file..."+      info verbosity "Updating the index cache file..."       updatePackageIndexCacheFile indexFile cacheFile-    readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile+    readPackageIndexCacheFile mkAvailablePackage indexFile cacheFile mode    where     mkAvailablePackage pkgEntry =@@ -175,8 +190,11 @@         packageInfoId      = pkgid,         packageDescription = packageDesc pkgEntry,         packageSource      = case pkgEntry of-          NormalPackage _ _ _      -> RepoTarballPackage repo pkgid Nothing-          BuildTreeRef  _ path _ _ -> LocalUnpackedPackage path+          NormalPackage _ _ _ _       -> RepoTarballPackage repo pkgid Nothing+          BuildTreeRef  _  _ _ path _ -> LocalUnpackedPackage path,+        packageDescrOverride = case pkgEntry of+          NormalPackage _ _ pkgtxt _ -> Just pkgtxt+          _                          -> Nothing       }       where         pkgid = packageId pkgEntry@@ -199,7 +217,7 @@       when (dt >= isOldThreshold) $ case repoKind repo of         Left  remoteRepo -> warn verbosity $              "The package list for '" ++ remoteRepoName remoteRepo-          ++ "' is " ++ show dt  ++ " days old.\nRun "+          ++ "' is " ++ show dt ++ " days old.\nRun "           ++ "'hackport update' to get the latest list of available packages."         Right _localRepo -> return () @@ -209,41 +227,56 @@ updateRepoIndexCache :: Verbosity -> Repo -> IO () updateRepoIndexCache verbosity repo =     whenCacheOutOfDate indexFile cacheFile $ do-      info verbosity $ "Updating the index cache file..."+      info verbosity "Updating the index cache file..."       updatePackageIndexCacheFile indexFile cacheFile   where     indexFile = repoLocalDir repo </> "00-index.tar"     cacheFile = repoLocalDir repo </> "00-index.cache" -whenCacheOutOfDate :: FilePath-> FilePath -> IO () -> IO ()+whenCacheOutOfDate :: FilePath -> FilePath -> IO () -> IO () whenCacheOutOfDate origFile cacheFile action = do   exists <- doesFileExist cacheFile   if not exists     then action     else do-      origTime  <- getModificationTime origFile-      cacheTime <- getModificationTime cacheFile-      unless (cacheTime >= origTime) action-+      origTime  <- getModTime origFile+      cacheTime <- getModTime cacheFile+      when (origTime >= cacheTime) action  ------------------------------------------------------------------------ -- Reading the index file --  -- | An index entry is either a normal package, or a local build tree reference.-data PackageEntry = NormalPackage PackageId GenericPackageDescription BlockNo-                  | BuildTreeRef PackageId FilePath GenericPackageDescription-                    BlockNo+data PackageEntry =+  NormalPackage  PackageId GenericPackageDescription ByteString BlockNo+  | BuildTreeRef BuildTreeRefType+                 PackageId GenericPackageDescription FilePath   BlockNo +-- | A build tree reference is either a link or a snapshot.+data BuildTreeRefType = SnapshotRef | LinkRef+                      deriving Eq++refTypeFromTypeCode :: Tar.TypeCode -> BuildTreeRefType+refTypeFromTypeCode t+  | t == Tar.buildTreeRefTypeCode      = LinkRef+  | t == Tar.buildTreeSnapshotTypeCode = SnapshotRef+  | otherwise                          =+    error "Distribution.Client.IndexUtils.refTypeFromTypeCode: unknown type code"++typeCodeFromRefType :: BuildTreeRefType -> Tar.TypeCode+typeCodeFromRefType LinkRef     = Tar.buildTreeRefTypeCode+typeCodeFromRefType SnapshotRef = Tar.buildTreeSnapshotTypeCode+ type MkPackageEntry = IO PackageEntry  instance Package PackageEntry where-  packageId (NormalPackage pkgid _ _   ) = pkgid-  packageId (BuildTreeRef  pkgid _ _ _ ) = pkgid+  packageId (NormalPackage  pkgid _ _ _) = pkgid+  packageId (BuildTreeRef _ pkgid _ _ _) = pkgid  packageDesc :: PackageEntry -> GenericPackageDescription-packageDesc (NormalPackage _   descr _ ) = descr-packageDesc (BuildTreeRef  _ _ descr _ ) = descr+packageDesc (NormalPackage  _ descr _ _) = descr+packageDesc (BuildTreeRef _ _ descr _ _) = descr  -- | Read a compressed \"00-index.tar.gz\" file into a 'PackageIndex'. --@@ -302,7 +335,7 @@      | takeExtension fileName == ".cabal"     -> case splitDirectories (normalise fileName) of         [pkgname,vers,_] -> case simpleParse vers of-          Just ver -> Just $ return (NormalPackage pkgid descr blockNo)+          Just ver -> Just $ return (NormalPackage pkgid descr content blockNo)             where               pkgid  = PackageIdentifier (PackageName pkgname) ver               parsed = parsePackageDescription . fromUTF8 . BS.Char8.unpack@@ -315,12 +348,13 @@         _ -> Nothing    Tar.OtherEntryType typeCode content _-    | typeCode == Tar.buildTreeRefTypeCode ->+    | Tar.isBuildTreeRefTypeCode typeCode ->       Just $ do         let path   = byteStringToFilePath content-        cabalFile <- findPackageDesc path+        cabalFile <- tryFindPackageDesc path         descr     <- PackageDesc.Parse.readPackageDescription normal cabalFile-        return $ BuildTreeRef (packageId descr) path descr blockNo+        return $ BuildTreeRef (refTypeFromTypeCode typeCode) (packageId descr)+                              descr path blockNo    _ -> Nothing @@ -341,8 +375,7 @@   _ -> Nothing  parsePreferredVersions :: String -> [Dependency]-parsePreferredVersions = catMaybes-                       . map simpleParse+parsePreferredVersions = mapMaybe simpleParse                        . filter (not . isPrefixOf "--")                        . lines @@ -363,27 +396,37 @@     mkCache pkgs prefs =         [ CachePreference pref          | pref <- prefs ]      ++ [ CachePackageId pkgid blockNo-        | (NormalPackage pkgid _ blockNo) <- pkgs ]-     ++ [ CacheBuildTreeRef blockNo-        | (BuildTreeRef _ _ _ blockNo) <- pkgs]+        | (NormalPackage pkgid _ _ blockNo) <- pkgs ]+     ++ [ CacheBuildTreeRef refType blockNo+        | (BuildTreeRef refType _ _ _ blockNo) <- pkgs] +data ReadPackageIndexMode = ReadPackageIndexStrict+                          | ReadPackageIndexLazyIO+ readPackageIndexCacheFile :: Package pkg                           => (PackageEntry -> pkg)                           -> FilePath                           -> FilePath+                          -> ReadPackageIndexMode                           -> IO (PackageIndex pkg, [Dependency])-readPackageIndexCacheFile mkPkg indexFile cacheFile = do-  indexHnd <- openFile indexFile ReadMode+readPackageIndexCacheFile mkPkg indexFile cacheFile mode = do   cache    <- liftM readIndexCache (BSS.readFile cacheFile)-  packageIndexFromCache mkPkg indexHnd cache+  myWithFile indexFile ReadMode $ \indexHnd ->+    packageIndexFromCache mkPkg indexHnd cache mode+  where+    myWithFile f m act = case mode of+      ReadPackageIndexStrict -> withFile f m act+      ReadPackageIndexLazyIO -> do indexHnd <- openFile f m+                                   act indexHnd   packageIndexFromCache :: Package pkg                       => (PackageEntry -> pkg)                       -> Handle                       -> [IndexCacheEntry]+                      -> ReadPackageIndexMode                       -> IO (PackageIndex pkg, [Dependency])-packageIndexFromCache mkPkg hnd = accum mempty []+packageIndexFromCache mkPkg hnd entrs mode = accum mempty [] entrs   where     accum srcpkgs prefs [] = do       -- Have to reverse entries, since in a tar file, later entries mask@@ -397,19 +440,26 @@       -- The magic here is that we use lazy IO to read the .cabal file       -- from the index tarball if it turns out that we need it.       -- Most of the time we only need the package id.-      pkg <- unsafeInterleaveIO $ do-        getEntryContent blockno >>= readPackageDescription-      let srcpkg = mkPkg (NormalPackage pkgid pkg blockno)+      ~(pkg, pkgtxt) <- unsafeInterleaveIO $ do+        pkgtxt <- getEntryContent blockno+        pkg    <- readPackageDescription pkgtxt+        return (pkg, pkgtxt)+      let srcpkg = case mode of+            ReadPackageIndexLazyIO ->+              mkPkg (NormalPackage pkgid pkg pkgtxt blockno)+            ReadPackageIndexStrict ->+              pkg `seq` pkgtxt `seq` mkPkg (NormalPackage pkgid pkg+                                            pkgtxt blockno)       accum (srcpkg:srcpkgs) prefs entries -    accum srcpkgs prefs (CacheBuildTreeRef blockno : entries) = do+    accum srcpkgs prefs (CacheBuildTreeRef refType blockno : entries) = do       -- We have to read the .cabal file eagerly here because we can't cache the       -- package id for build tree references - the user might edit the .cabal       -- file after the reference was added to the index.       path <- liftM byteStringToFilePath . getEntryContent $ blockno-      pkg  <- do cabalFile <- findPackageDesc path+      pkg  <- do cabalFile <- tryFindPackageDesc path                  PackageDesc.Parse.readPackageDescription normal cabalFile-      let srcpkg = mkPkg (BuildTreeRef (packageId pkg) path pkg blockno)+      let srcpkg = mkPkg (BuildTreeRef refType (packageId pkg) pkg path blockno)       accum (srcpkg:srcpkgs) prefs entries      accum srcpkgs prefs (CachePreference pref : entries) =@@ -429,7 +479,7 @@           case Tar.entryContent e of             Tar.NormalFile _ size -> return size             Tar.OtherEntryType typecode _ size-              | typecode == Tar.buildTreeRefTypeCode+              | Tar.isBuildTreeRefTypeCode typecode                                   -> return size             _                     -> interror "unexpected tar entry type"         _ -> interror "could not read tar file entry"@@ -454,9 +504,9 @@ type BlockNo = Int  data IndexCacheEntry = CachePackageId PackageId BlockNo-                     | CacheBuildTreeRef BlockNo+                     | CacheBuildTreeRef BuildTreeRefType BlockNo                      | CachePreference Dependency-  deriving (Eq, Show)+  deriving (Eq)  readIndexCacheEntry :: BSS.ByteString -> Maybe IndexCacheEntry readIndexCacheEntry = \line ->@@ -468,10 +518,12 @@         (Just pkgname, Just pkgver, Just blockno)           -> Just (CachePackageId (PackageIdentifier pkgname pkgver) blockno)         _ -> Nothing-    [key, blocknostr] | key == buildTreeRefKey ->-      case parseBlockNo blocknostr of-        Just blockno -> Just (CacheBuildTreeRef blockno)-        _            -> Nothing+    [key, typecodestr, blocknostr] | key == buildTreeRefKey ->+      case (parseRefType typecodestr, parseBlockNo blocknostr) of+        (Just refType, Just blockno)+          -> Just (CacheBuildTreeRef refType blockno)+        _ -> Nothing+     (key: remainder) | key == preferredVersionKey ->       fmap CachePreference (simpleParse (BSS.unpack (BSS.unwords remainder)))     _  -> Nothing@@ -499,16 +551,24 @@         Just (blockno, remainder) | BSS.null remainder -> Just blockno         _                                              -> Nothing +    parseRefType str =+      case BSS.uncons str of+        Just (typeCode, remainder)+          | BSS.null remainder && Tar.isBuildTreeRefTypeCode typeCode+            -> Just (refTypeFromTypeCode typeCode)+        _   -> Nothing+ showIndexCacheEntry :: IndexCacheEntry -> String showIndexCacheEntry entry = case entry of    CachePackageId pkgid b -> "pkg: " ++ display (packageName pkgid)                                   ++ " " ++ display (packageVersion pkgid)                           ++ " b# " ++ show b-   CacheBuildTreeRef b    -> "build-tree-ref: " ++ show b+   CacheBuildTreeRef t b  -> "build-tree-ref: " ++ (typeCodeFromRefType t:" ")+                             ++ show b    CachePreference dep    -> "pref-ver: " ++ display dep  readIndexCache :: BSS.ByteString -> [IndexCacheEntry]-readIndexCache = catMaybes . map readIndexCacheEntry . BSS.lines+readIndexCache = mapMaybe readIndexCacheEntry . BSS.lines  showIndexCache :: [IndexCacheEntry] -> String showIndexCache = unlines . map showIndexCacheEntry
cabal/cabal-install/Distribution/Client/Init.hs view
@@ -24,14 +24,17 @@ import System.IO   ( hSetBuffering, stdout, BufferMode(..) ) import System.Directory-  ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile )+  ( getCurrentDirectory, doesDirectoryExist, doesFileExist, copyFile+  , getDirectoryContents ) import System.FilePath-  ( (</>), (<.>) )+  ( (</>), (<.>), takeBaseName ) import Data.Time   ( getCurrentTime, utcToLocalTime, toGregorian, localDay, getCurrentTimeZone ) +import Data.Char+  ( toUpper ) import Data.List-  ( intersperse, intercalate, nub, groupBy, (\\) )+  ( intercalate, nub, groupBy, (\\) ) import Data.Maybe   ( fromMaybe, isJust, catMaybes ) import Data.Function@@ -42,24 +45,20 @@ import Control.Applicative   ( (<$>) ) import Control.Monad-  ( when, unless )-#if MIN_VERSION_base(3,0,0)-import Control.Monad-  ( (>=>), join )-#endif+  ( when, unless, (>=>), join ) import Control.Arrow-  ( (&&&) )+  ( (&&&), (***) )  import Text.PrettyPrint hiding (mode, cat)  import Data.Version   ( Version(..) ) import Distribution.Version-  ( orLaterVersion, withinVersion, VersionRange )+  ( orLaterVersion, earlierVersion, intersectVersionRanges, VersionRange ) import Distribution.Verbosity   ( Verbosity ) import Distribution.ModuleName-  ( ModuleName, fromString )+  ( ModuleName, fromString )  -- And for the Text instance import Distribution.InstalledPackageInfo   ( InstalledPackageInfo, sourcePackageId, exposed ) import qualified Distribution.Package as P@@ -68,14 +67,13 @@ import Distribution.Client.Init.Types   ( InitFlags(..), PackageType(..), Category(..) ) import Distribution.Client.Init.Licenses-  ( bsd3, gplv2, gplv3, lgpl2, lgpl3, apache20 )+  ( bsd3, gplv2, gplv3, lgpl2, lgpl3, agplv3, apache20 ) import Distribution.Client.Init.Heuristics-  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..), scanForModules, neededBuildPrograms )+  ( guessPackageName, guessAuthorNameMail, SourceFileEntry(..),+    scanForModules, neededBuildPrograms )  import Distribution.License   ( License(..), knownLicenses )-import Distribution.ModuleName-  ( ) -- for the Text instance  import Distribution.ReadE   ( runReadE, readP_to_E )@@ -127,6 +125,7 @@   >=> getHomepage   >=> getSynopsis   >=> getCategory+  >=> getExtraSourceFiles   >=> getLibOrExec   >=> getLanguage   >=> getGenComments@@ -180,13 +179,15 @@   return $ flags { license = maybeToFlag lic }   where     listedLicenses =-      knownLicenses \\ [GPL Nothing, LGPL Nothing, Apache Nothing, OtherLicense]+      knownLicenses \\ [GPL Nothing, LGPL Nothing, AGPL Nothing+                       , Apache Nothing, OtherLicense]  -- | The author's name and email. Prompt, or try to guess from an existing --   darcs repo. getAuthorInfo :: InitFlags -> IO InitFlags getAuthorInfo flags = do-  (authorName, authorEmail)  <- (\(a,e) -> (flagToMaybe a, flagToMaybe e)) `fmap` guessAuthorNameMail+  (authorName, authorEmail)  <-+    (flagToMaybe *** flagToMaybe) `fmap` guessAuthorNameMail   authorName'  <-     return (flagToMaybe $ author flags)                   ?>> maybePrompt flags (promptStr "Author name" authorName)                   ?>> return authorName@@ -232,14 +233,38 @@                          (promptListOptional "Project category" [Codec ..]))   return $ flags { category = maybeToFlag cat } +-- | Try to guess extra source files (don't prompt the user).+getExtraSourceFiles :: InitFlags -> IO InitFlags+getExtraSourceFiles flags = do+  extraSrcFiles <-     return (extraSrc flags)+                   ?>> Just `fmap` guessExtraSourceFiles flags++  return $ flags { extraSrc = extraSrcFiles }++-- | Try to guess things to include in the extra-source-files field.+--   For now, we just look for things in the root directory named+--   'readme', 'changes', or 'changelog', with any sort of+--   capitalization and any extension.+guessExtraSourceFiles :: InitFlags -> IO [FilePath]+guessExtraSourceFiles flags = do+  dir <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags+  files <- getDirectoryContents dir+  return $ filter isExtra files++  where+    isExtra = (`elem` ["README", "CHANGES", "CHANGELOG"])+            . map toUpper+            . takeBaseName+ -- | Ask whether the project builds a library or executable. getLibOrExec :: InitFlags -> IO InitFlags getLibOrExec flags = do   isLib <-     return (flagToMaybe $ packageType flags)            ?>> maybePrompt flags (either (const Library) id `fmap`-                                   (promptList "What does the package build"-                                               [Library, Executable]-                                               Nothing display False))+                                   promptList "What does the package build"+                                   [Library, Executable]+                                   Nothing display False)            ?>> return (Just Library)    return $ flags { packageType = maybeToFlag isLib }@@ -250,13 +275,9 @@   lang <-     return (flagToMaybe $ language flags)           ?>> maybePrompt flags                 (either UnknownLanguage id `fmap`-                  (promptList "What base language is the package written in"-                    [Haskell2010, Haskell98]-                    (Just Haskell2010)-                    display-                    True-                  )-                )+                  promptList "What base language is the package written in"+                  [Haskell2010, Haskell98]+                  (Just Haskell2010) display True)           ?>> return (Just Haskell2010)    return $ flags { language = maybeToFlag lang }@@ -264,7 +285,7 @@ -- | Ask whether to generate explanatory comments. getGenComments :: InitFlags -> IO InitFlags getGenComments flags = do-  genComments <-     return (not <$> (flagToMaybe $ noComments flags))+  genComments <-     return (not <$> flagToMaybe (noComments flags))                  ?>> maybePrompt flags (promptYesNo promptMsg (Just False))                  ?>> return (Just False)   return $ flags { noComments = maybeToFlag (fmap not genComments) }@@ -275,7 +296,7 @@ getSrcDir :: InitFlags -> IO InitFlags getSrcDir flags = do   srcDirs <-     return (sourceDirs flags)-             ?>> Just `fmap` (guessSourceDirs flags)+             ?>> Just `fmap` guessSourceDirs flags    return $ flags { sourceDirs = srcDirs } @@ -283,8 +304,8 @@ --   moment just looks to see whether there is a directory called 'src'. guessSourceDirs :: InitFlags -> IO [String] guessSourceDirs flags = do-  dir      <- fromMaybe getCurrentDirectory-                (fmap return . flagToMaybe $ packageDir flags)+  dir      <-+    maybe getCurrentDirectory return . flagToMaybe $ packageDir flags   srcIsDir <- doesDirectoryExist (dir </> "src")   if srcIsDir     then return ["src"]@@ -293,8 +314,7 @@ -- | Get the list of exposed modules and extra tools needed to build them. getModulesBuildToolsAndDeps :: PackageIndex -> InitFlags -> IO InitFlags getModulesBuildToolsAndDeps pkgIx flags = do-  dir <- fromMaybe getCurrentDirectory-                   (fmap return . flagToMaybe $ packageDir flags)+  dir <- maybe getCurrentDirectory return . flagToMaybe $ packageDir flags    -- XXX really should use guessed source roots.   sourceFiles <- scanForModules dir@@ -317,9 +337,13 @@                         )                         pkgIx +  exts <-     return (otherExts flags)+          ?>> (return . Just . nub . concatMap extensions $ sourceFiles)+   return $ flags { exposedModules = Just mods                  , buildTools     = tools                  , dependencies   = deps+                 , otherExts      = exts                  }  importsToDeps :: InitFlags -> [ModuleName] -> PackageIndex -> IO [P.Dependency]@@ -359,7 +383,7 @@       grps  -> do message flags ("\nWarning: multiple packages found providing "                                  ++ display m                                  ++ ": " ++ intercalate ", " (map (display . P.pkgName . head) grps))-                  message flags ("You will need to pick one and manually add it to the Build-depends: field.")+                  message flags "You will need to pick one and manually add it to the Build-depends: field."                   return Nothing   where     pkgGroups = groupBy ((==) `on` P.pkgName) (map sourcePackageId ps)@@ -377,8 +401,19 @@                             (pvpize . maximum . map P.pkgVersion $ pids)      pvpize :: Version -> VersionRange-    pvpize v = withinVersion $ v { versionBranch = take 2 (versionBranch v) }+    pvpize v = orLaterVersion v'+               `intersectVersionRanges`+               earlierVersion (incVersion 1 v')+      where v' = (v { versionBranch = take 2 (versionBranch v) }) +incVersion :: Int -> Version -> Version+incVersion n (Version vlist tags) = Version (incVersion' n vlist) tags+  where+    incVersion' 0 []     = [1]+    incVersion' 0 (v:_)  = [v+1]+    incVersion' m []     = replicate m 0 ++ [1]+    incVersion' m (v:vs) = v : incVersion' (m-1) vs+ --------------------------------------------------------------------------- --  Prompting/user interaction  ------------------------------------------- ---------------------------------------------------------------------------@@ -447,7 +482,7 @@   $ promptList pr (Nothing : map Just choices) (Just Nothing)                (maybe "(none)" display) True   where-    rearrange = either (Just . Left) (maybe Nothing (Just . Right))+    rearrange = either (Just . Left) (fmap Right)  -- | Create a prompt from a list of items. promptList :: Eq t@@ -461,8 +496,7 @@   putStrLn $ pr ++ ":"   let options1 = map (\c -> (Just c == def, displayItem c)) choices       options2 = zip ([1..]::[Int])-                     (options1 ++ if other then [(False, "Other (specify)")]-                                           else [])+                     (options1 ++ [(False, "Other (specify)") | other])   mapM_ (putStrLn . \(n,(i,s)) -> showOption n i ++ s) options2   promptList' displayItem (length options2) choices def other  where showOption n i | n < 10 = " " ++ star i ++ " " ++ rest@@ -521,6 +555,9 @@           Flag (LGPL (Just (Version {versionBranch = [3]})))             -> Just lgpl3 +          Flag (AGPL (Just (Version {versionBranch = [3]})))+            -> Just agplv3+           Flag (Apache (Just (Version {versionBranch = [2, 0]})))             -> Just apache20 @@ -548,8 +585,6 @@     , "main = defaultMain"     ] --- XXX ought to do something sensible if a .cabal file already exists,--- instead of overwriting. writeCabalFile :: InitFlags -> IO Bool writeCabalFile flags@(InitFlags{packageName = NoFlag}) = do   message flags "Error: no package name provided."@@ -598,7 +633,7 @@ generateCabalFile :: String -> InitFlags -> String generateCabalFile fileName c =   renderStyle style { lineLength = 79, ribbonsPerLine = 1.1 } $-  (if (minimal c /= Flag True)+  (if minimal c /= Flag True     then showComment (Just $ "Initial " ++ fileName ++ " generated by cabal "                           ++ "init.  For further documentation, see "                           ++ "http://haskell.org/cabal/users-guide/")@@ -660,9 +695,9 @@                 Nothing                 True -       , fieldS "extra-source-files" NoFlag+       , fieldS "extra-source-files" (listFieldS (extraSrc c))                 (Just "Extra files to be distributed with the package, such as examples or a README.")-                False+                True         , field  "cabal-version" (Flag $ orLaterVersion (Version [1,10] []))                 (Just "Constraint on the version of Cabal needed to build this package.")@@ -670,12 +705,12 @@         , case packageType c of            Flag Executable ->-             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ (nest 2 $ vcat+             text "\nexecutable" <+> text (fromMaybe "" . flagToMaybe $ packageName c) $$ nest 2 (vcat              [ fieldS "main-is" NoFlag (Just ".hs or .lhs file containing the Main module.") True               , generateBuildInfo Executable c              ])-           Flag Library    -> text "\nlibrary" $$ (nest 2 $ vcat+           Flag Library    -> text "\nlibrary" $$ nest 2 (vcat              [ fieldS "exposed-modules" (listField (exposedModules c))                       (Just "Modules exported by the library.")                       True@@ -693,13 +728,17 @@                  Executable -> "Modules included in this executable, other than Main.")               True +     , fieldS "other-extensions" (listField (otherExts c'))+              (Just "LANGUAGE extensions used by modules in this package.")+              True+      , fieldS "build-depends" (listField (dependencies c'))               (Just "Other library packages from which modules are imported.")               True       , fieldS "hs-source-dirs" (listFieldS (sourceDirs c'))               (Just "Directories containing source files.")-              False+              True       , fieldS "build-tools" (listFieldS (buildTools c'))               (Just "Extra tools (e.g. alex, hsc2hs, ...) needed to build the source.")@@ -714,7 +753,7 @@    listField = listFieldS . fmap (map display)     listFieldS :: Maybe [String] -> Flag String-   listFieldS = Flag . maybe "" (concat . intersperse ", ")+   listFieldS = Flag . maybe "" (intercalate ", ")     field :: Text t => String -> Flag t -> Maybe String -> Bool -> Doc    field s f = fieldS s (fmap display f)@@ -733,15 +772,15 @@                         (False, _, _)     -> ($$ text "")                       $                       comment f <> text s <> colon-                                <> text (take (20 - length s) (repeat ' '))+                                <> text (replicate (20 - length s) ' ')                                 <> text (fromMaybe "" . flagToMaybe $ f)    comment NoFlag    = text "-- "    comment (Flag "") = text "-- "    comment _         = text ""     showComment :: Maybe String -> Doc-   showComment (Just t) = vcat . map text-                        . map ("-- "++) . lines+   showComment (Just t) = vcat+                        . map (text . ("-- "++)) . lines                         . renderStyle style {                             lineLength = 76,                             ribbonsPerLine = 1.05@@ -771,9 +810,3 @@ message :: InitFlags -> String -> IO () message (InitFlags{quiet = Flag True}) _ = return () message _ s = putStrLn s--#if MIN_VERSION_base(3,0,0)-#else-(>=>)       :: Monad m => (a -> m b) -> (b -> m c) -> (a -> m c)-f >=> g     = \x -> f x >>= g-#endif
cabal/cabal-install/Distribution/Client/Init/Heuristics.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Heuristics@@ -22,33 +21,38 @@ import Distribution.Text         (simpleParse) import Distribution.Simple.Setup (Flag(..)) import Distribution.ModuleName-    ( ModuleName, fromString, toFilePath )+    ( ModuleName, toFilePath ) import Distribution.Client.PackageIndex     ( allPackagesByName ) import qualified Distribution.PackageDescription as PD     ( category, packageDescription ) import Distribution.Simple.Utils          ( intercalate )+import Distribution.Client.Utils+         ( tryCanonicalizePath )+import Language.Haskell.Extension ( Extension )  import Distribution.Client.Types ( packageDescription, SourcePackageDb(..) )-import Control.Monad (liftM )+import Control.Applicative ( pure, (<$>), (<*>) )+import Control.Monad ( liftM ) import Data.Char   ( isUpper, isLower, isSpace )-#if MIN_VERSION_base(3,0,3) import Data.Either ( partitionEithers )-#endif import Data.List   ( isPrefixOf )-import Data.Maybe  ( catMaybes )-import Data.Monoid ( mempty, mappend )+import Data.Maybe  ( mapMaybe, catMaybes, maybeToList )+import Data.Monoid ( mempty, mconcat ) import qualified Data.Set as Set ( fromList, toList )-import System.Directory ( getDirectoryContents, doesDirectoryExist, doesFileExist,-                          getHomeDirectory, canonicalizePath )-import System.Environment ( getEnvironment )+import System.Directory ( getDirectoryContents,+                          doesDirectoryExist, doesFileExist, getHomeDirectory, )+import Distribution.Compat.Environment ( getEnvironment ) import System.FilePath ( takeExtension, takeBaseName, dropExtension,                          (</>), (<.>), splitDirectories, makeRelative ) +import Distribution.Client.Compat.Process ( readProcessWithExitCode )+import System.Exit ( ExitCode(..) )+ -- |Guess the package name based on the given root directory guessPackageName :: FilePath -> IO String-guessPackageName = liftM (last . splitDirectories) . canonicalizePath+guessPackageName = liftM (last . splitDirectories) . tryCanonicalizePath  -- |Data type of source files found in the working directory data SourceFileEntry = SourceFileEntry@@ -56,10 +60,11 @@     , moduleName         :: ModuleName     , fileExtension      :: String     , imports            :: [ModuleName]+    , extensions         :: [Extension]     } deriving Show  sfToFileName :: FilePath -> SourceFileEntry -> FilePath-sfToFileName projectRoot (SourceFileEntry relPath m ext _)+sfToFileName projectRoot (SourceFileEntry relPath m ext _ _)   = projectRoot </> relPath </> toFilePath m <.> ext  -- |Search for source files in the given directory@@ -77,7 +82,7 @@         let modules = catMaybes [ guessModuleName hierarchy file                                 | file <- files                                 , isUpper (head file) ]-        modules' <- mapM (findImports projectRoot) modules+        modules' <- mapM (findImportsAndExts projectRoot) modules         recMods <- mapM (scanRecursive dir hierarchy) dirs         return $ concat (modules' : recMods)     tagIsDir parent entry = do@@ -85,32 +90,34 @@         return $ (if isDir then Right else Left) entry     guessModuleName hierarchy entry         | takeBaseName entry == "Setup" = Nothing-        | ext `elem` sourceExtensions = Just $ SourceFileEntry relRoot modName ext []+        | ext `elem` sourceExtensions   =+            SourceFileEntry <$> pure relRoot <*> modName <*> pure ext <*> pure [] <*> pure []         | otherwise = Nothing       where-        relRoot = makeRelative projectRoot srcRoot+        relRoot       = makeRelative projectRoot srcRoot         unqualModName = dropExtension entry-        modName = fromString $ intercalate "." . reverse $ (unqualModName : hierarchy)-        ext = case takeExtension entry of '.':e -> e; e -> e+        modName       = simpleParse+                      $ intercalate "." . reverse $ (unqualModName : hierarchy)+        ext           = case takeExtension entry of '.':e -> e; e -> e     scanRecursive parent hierarchy entry       | isUpper (head entry) = scan (parent </> entry) (entry : hierarchy)       | isLower (head entry) && not (ignoreDir entry) =-          scanForModulesIn projectRoot $ foldl (</>) srcRoot (entry : hierarchy)+          scanForModulesIn projectRoot $ foldl (</>) srcRoot (reverse (entry : hierarchy))       | otherwise = return []     ignoreDir ('.':_)  = True     ignoreDir dir      = dir `elem` ["dist", "_darcs"] -findImports :: FilePath -> SourceFileEntry -> IO SourceFileEntry-findImports projectRoot sf = do+findImportsAndExts :: FilePath -> SourceFileEntry -> IO SourceFileEntry+findImportsAndExts projectRoot sf = do   s <- readFile (sfToFileName projectRoot sf) -  let modules = catMaybes-              . map ( getModName-                    . drop 1-                    . filter (not . null)-                    . dropWhile (/= "import")-                    . words-                    )+  let modules = mapMaybe+                ( getModName+                . drop 1+                . filter (not . null)+                . dropWhile (/= "import")+                . words+                )               . filter (not . ("--" `isPrefixOf`)) -- poor man's comment filtering               . lines               $ s@@ -120,8 +127,30 @@       -- Haskell parser since cabal's dependencies must be kept at a       -- minimum. -  return sf { imports = modules }+      -- A poor man's LANGUAGE pragma parser.+      exts = mapMaybe simpleParse+           . concatMap getPragmas+           . filter isLANGUAGEPragma+           . map fst+           . drop 1+           . takeWhile (not . null . snd)+           . iterate (takeBraces . snd)+           $ ("",s) +      takeBraces = break (== '}') . dropWhile (/= '{')++      isLANGUAGEPragma = ("{-# LANGUAGE " `isPrefixOf`)++      getPragmas = map trim . splitCommas . takeWhile (/= '#') . drop 13++      splitCommas "" = []+      splitCommas xs = x : splitCommas (drop 1 y)+        where (x,y) = break (==',') xs++  return sf { imports    = modules+            , extensions = exts+            }+  where getModName :: [String] -> Maybe ModuleName        getModName []               = Nothing        getModName ("qualified":ws) = getModName ws@@ -148,32 +177,111 @@ neededBuildPrograms entries =     [ handler     | ext <- nubSet (map fileExtension entries)-    , handler <- maybe [] (:[]) (lookup ext knownSuffixHandlers)+    , handler <- maybeToList (lookup ext knownSuffixHandlers)     ] --- |Guess author and email+-- | Guess author and email using darcs and git configuration options. Use+-- the following in decreasing order of preference:+--+-- 1. vcs env vars ($DARCS_EMAIL, $GIT_AUTHOR_*)+-- 2. Local repo configs+-- 3. Global vcs configs+-- 4. The generic $EMAIL+--+-- Name and email are processed separately, so the guess might end up being+-- a name from DARCS_EMAIL and an email from git config.+--+-- Darcs has preference, for tradition's sake. guessAuthorNameMail :: IO (Flag String, Flag String)-guessAuthorNameMail =-  update (readFromFile authorRepoFile) mempty >>=-  update (getAuthorHome >>= readFromFile) >>=-  update readFromEnvironment+guessAuthorNameMail = fmap authorGuessPure authorGuessIO++-- Ordered in increasing preference, since Flag-as-monoid is identical to+-- Last.+authorGuessPure :: AuthorGuessIO -> AuthorGuess+authorGuessPure (AuthorGuessIO env darcsLocalF darcsGlobalF gitLocal gitGlobal)+    = mconcat+        [ emailEnv env+        , gitGlobal+        , darcsCfg darcsGlobalF+        , gitLocal+        , darcsCfg darcsLocalF+        , gitEnv env+        , darcsEnv env+        ]++authorGuessIO :: IO AuthorGuessIO+authorGuessIO = AuthorGuessIO+    <$> getEnvironment+    <*> (maybeReadFile $ "_darcs" </> "prefs" </> "author")+    <*> (maybeReadFile =<< liftM (</> (".darcs" </> "author")) getHomeDirectory)+    <*> gitCfg Local+    <*> gitCfg Global++-- Types and functions used for guessing the author are now defined:++type AuthorGuess   = (Flag String, Flag String)+type Enviro        = [(String, String)]+data GitLoc        = Local | Global+data AuthorGuessIO = AuthorGuessIO+    Enviro         -- ^ Environment lookup table+    (Maybe String) -- ^ Contents of local darcs author info+    (Maybe String) -- ^ Contents of global darcs author info+    AuthorGuess    -- ^ Git config --local+    AuthorGuess    -- ^ Git config --global++darcsEnv :: Enviro -> AuthorGuess+darcsEnv = maybe mempty nameAndMail . lookup "DARCS_EMAIL"++gitEnv :: Enviro -> AuthorGuess+gitEnv env = (name, email)   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"+    name  = maybeFlag "GIT_AUTHOR_NAME" env+    email = maybeFlag "GIT_AUTHOR_EMAIL" env +darcsCfg :: Maybe String -> AuthorGuess+darcsCfg = maybe mempty nameAndMail++emailEnv :: Enviro -> AuthorGuess+emailEnv env = (mempty, email)+  where+    email = maybeFlag "EMAIL" env++gitCfg :: GitLoc -> IO AuthorGuess+gitCfg which = do+  name <- gitVar which "user.name"+  mail <- gitVar which "user.email"+  return (name, mail)++gitVar :: GitLoc -> String -> IO (Flag String)+gitVar which = fmap happyOutput . gitConfigQuery which++happyOutput :: (ExitCode, a, t) -> Flag a+happyOutput v = case v of+  (ExitSuccess, s, _) -> Flag s+  _                   -> mempty++gitConfigQuery :: GitLoc -> String -> IO (ExitCode, String, String)+gitConfigQuery which key =+    fmap trim' $ readProcessWithExitCode "git" ["config", w, key] ""+  where+    w = case which of+        Local  -> "--local"+        Global -> "--global"+    trim' (a, b, c) = (a, trim b, c)++maybeFlag :: String -> Enviro -> Flag String+maybeFlag k = maybe mempty Flag . lookup k++maybeReadFile :: String -> IO (Maybe String)+maybeReadFile f = do+    exists <- doesFileExist f+    if exists+        then fmap Just $ readFile f+        else return Nothing+ -- |Get list of categories used in hackage. NOTE: Very slow, needs to be cached knownCategories :: SourcePackageDb -> [String]-knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet $+knownCategories (SourcePackageDb sourcePkgIndex _) = nubSet     [ cat | pkg <- map head (allPackagesByName sourcePkgIndex)           , let catList = (PD.category . PD.packageDescription . packageDescription) pkg           , cat <- splitString ',' catList@@ -188,7 +296,10 @@   where     (nameOrEmail,erest) = break (== '<') str     (email,_)           = break (== '>') (tail erest)-    trim                = removeLeadingSpace . reverse . removeLeadingSpace . reverse++trim :: String -> String+trim = removeLeadingSpace . reverse . removeLeadingSpace . reverse+  where     removeLeadingSpace  = dropWhile isSpace  -- split string at given character, and remove whitespaces@@ -218,12 +329,3 @@   putStrLn "List of known categories"   print $ knownCategories db -}--#if MIN_VERSION_base(3,0,3)-#else-partitionEithers :: [Either a b] -> ([a],[b])-partitionEithers = foldr (either left right) ([],[])- where-   left  a (l, r) = (a:l, r)-   right a (l, r) = (l, a:r)-#endif
cabal/cabal-install/Distribution/Client/Init/Licenses.hs view
@@ -5,6 +5,7 @@   , gplv3   , lgpl2   , lgpl3+  , agplv3   , apache20    ) where@@ -1065,6 +1066,671 @@     , "Public License instead of this License.  But first, please read"     , "<http://www.gnu.org/philosophy/why-not-lgpl.html>."     , ""+    ]++agplv3 :: License+agplv3 = unlines+    [ "                    GNU AFFERO GENERAL PUBLIC LICENSE"+    , "                       Version 3, 19 November 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 Affero General Public License is a free, copyleft license for"+    , "software and other kinds of works, specifically designed to ensure"+    , "cooperation with the community in the case of network server software."+    , ""+    , "  The licenses for most software and other practical works are designed"+    , "to take away your freedom to share and change the works.  By contrast,"+    , "our General Public Licenses are 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."+    , ""+    , "  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."+    , ""+    , "  Developers that use our General Public Licenses protect your rights"+    , "with two steps: (1) assert copyright on the software, and (2) offer"+    , "you this License which gives you legal permission to copy, distribute"+    , "and/or modify the software."+    , ""+    , "  A secondary benefit of defending all users' freedom is that"+    , "improvements made in alternate versions of the program, if they"+    , "receive widespread use, become available for other developers to"+    , "incorporate.  Many developers of free software are heartened and"+    , "encouraged by the resulting cooperation.  However, in the case of"+    , "software used on network servers, this result may fail to come about."+    , "The GNU General Public License permits making a modified version and"+    , "letting the public access it on a server without ever releasing its"+    , "source code to the public."+    , ""+    , "  The GNU Affero General Public License is designed specifically to"+    , "ensure that, in such cases, the modified source code becomes available"+    , "to the community.  It requires the operator of a network server to"+    , "provide the source code of the modified version running there to the"+    , "users of that server.  Therefore, public use of a modified version, on"+    , "a publicly accessible server, gives the public access to the source"+    , "code of the modified version."+    , ""+    , "  An older license, called the Affero General Public License and"+    , "published by Affero, was designed to accomplish similar goals.  This is"+    , "a different license, not a version of the Affero GPL, but Affero has"+    , "released a new version of the Affero GPL which permits relicensing under"+    , "this license."+    , ""+    , "  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 Affero 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. Remote Network Interaction; Use with the GNU General Public License."+    , ""+    , "  Notwithstanding any other provision of this License, if you modify the"+    , "Program, your modified version must prominently offer all users"+    , "interacting with it remotely through a computer network (if your version"+    , "supports such interaction) an opportunity to receive the Corresponding"+    , "Source of your version by providing access to the Corresponding Source"+    , "from a network server at no charge, through some standard or customary"+    , "means of facilitating copying of software.  This Corresponding Source"+    , "shall include the Corresponding Source for any work covered by version 3"+    , "of the GNU General Public License that is incorporated pursuant to the"+    , "following paragraph."+    , ""+    , "  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 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 work with which it is combined will remain governed by version"+    , "3 of the GNU General Public License."+    , ""+    , "  14. Revised Versions of this License."+    , ""+    , "  The Free Software Foundation may publish revised and/or new versions of"+    , "the GNU Affero 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 Affero 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 Affero 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 Affero 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 Affero 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 Affero General Public License for more details."+    , ""+    , "    You should have received a copy of the GNU Affero 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 your software can interact with users remotely through a computer"+    , "network, you should also make sure that it provides a way for users to"+    , "get its source.  For example, if your program is a web application, its"+    , "interface could display a \"Source\" link that leads users to an archive"+    , "of the code.  There are many ways you could offer source, and different"+    , "solutions will be better for different programs; see section 13 for the"+    , "specific requirements."+    , ""+    , "  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 AGPL, see"+    , "<http://www.gnu.org/licenses/>."     ]  lgpl2 :: License
cabal/cabal-install/Distribution/Client/Init/Types.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE CPP #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Init.Types@@ -22,7 +21,7 @@ import qualified Distribution.Package as P import Distribution.License import Distribution.ModuleName-import Language.Haskell.Extension ( Language(..) )+import Language.Haskell.Extension ( Language(..), Extension )  import qualified Text.PrettyPrint as Disp import qualified Distribution.Compat.ReadP as Parse@@ -52,12 +51,14 @@                , synopsis     :: Flag String               , category     :: Flag (Either String Category)+              , extraSrc     :: Maybe [String]                , packageType  :: Flag PackageType               , language     :: Flag Language                , exposedModules :: Maybe [ModuleName]               , otherModules   :: Maybe [ModuleName]+              , otherExts      :: Maybe [Extension]                , dependencies :: Maybe [P.Dependency]               , sourceDirs   :: Maybe [String]@@ -68,6 +69,10 @@               }   deriving (Show) +  -- the Monoid instance for Flag has later values override earlier+  -- ones, which is why we want Maybe [foo] for collecting foo values,+  -- not Flag [foo].+ data PackageType = Library | Executable   deriving (Show, Read, Eq) @@ -91,10 +96,12 @@     , homepage       = mempty     , synopsis       = mempty     , category       = mempty+    , extraSrc       = mempty     , packageType    = mempty     , language       = mempty     , exposedModules = mempty     , otherModules   = mempty+    , otherExts      = mempty     , dependencies   = mempty     , sourceDirs     = mempty     , buildTools     = mempty@@ -116,10 +123,12 @@     , homepage       = combine homepage     , synopsis       = combine synopsis     , category       = combine category+    , extraSrc       = combine extraSrc     , packageType    = combine packageType     , language       = combine language     , exposedModules = combine exposedModules     , otherModules   = combine otherModules+    , otherExts      = combine otherExts     , dependencies   = combine dependencies     , sourceDirs     = combine sourceDirs     , buildTools     = combine buildTools@@ -153,12 +162,3 @@   disp  = Disp.text . show   parse = Parse.choice $ map (fmap read . Parse.string . show) [Codec .. ] -#if MIN_VERSION_base(3,0,0)-#else--- Compat instance for ghc-6.6 era-instance Monoid a => Monoid (Maybe a) where-  mempty = Nothing-  Nothing `mappend` m = m-  m `mappend` Nothing = m-  Just m1 `mappend` Just m2 = Just (m1 `mappend` m2)-#endif
cabal/cabal-install/Distribution/Client/Install.hs view
@@ -14,45 +14,56 @@ -- High level interface to package installation. ----------------------------------------------------------------------------- module Distribution.Client.Install (+    -- * High-level interface     install,-    upgrade,++    -- * Lower-level interface that allows to manipulate the install plan+    makeInstallContext,+    makeInstallPlan,+    processInstallPlan,+    InstallArgs,+    InstallContext,++    -- * Prune certain packages from the install plan+    pruneInstallPlan   ) where  import Data.List          ( unfoldr, nub, sort, (\\) )+import qualified Data.Set as S import Data.Maybe          ( isJust, fromMaybe, maybeToList ) import Control.Exception as Exception-         ( bracket, handleJust )-#if MIN_VERSION_base(4,0,0)-import Control.Exception as Exception-         ( Exception(toException), catches, Handler(Handler), IOException )-import System.Exit-         ( ExitCode )-#else+         ( Exception(toException), bracket, catches+         , Handler(Handler), handleJust, IOException, SomeException )+#ifndef mingw32_HOST_OS import Control.Exception as Exception-         ( Exception(IOException, ExitException) )+         ( Exception(fromException) ) #endif-import Distribution.Compat.ExceptionCI-         ( SomeException, catchIO, catchExit )+import System.Exit+         ( ExitCode(..) )+import Distribution.Compat.Exception+         ( catchIO, catchExit ) import Control.Monad          ( when, unless ) import System.Directory-         ( getTemporaryDirectory, doesFileExist, createDirectoryIfMissing )+         ( getTemporaryDirectory, doesDirectoryExist, doesFileExist,+           createDirectoryIfMissing, removeFile, renameDirectory ) import System.FilePath          ( (</>), (<.>), takeDirectory ) import System.IO-         ( openFile, IOMode(AppendMode), stdout, hFlush, hClose )+         ( openFile, IOMode(AppendMode), hClose ) import System.IO.Error          ( isDoesNotExistError, ioeGetFileName )  import Distribution.Client.Targets+import Distribution.Client.Configure+         ( chooseCabalVersion ) import Distribution.Client.Dependency import Distribution.Client.Dependency.Types          ( Solver(..) ) import Distribution.Client.FetchUtils import qualified Distribution.Client.Haddock as Haddock (regenerateHaddockIndex)--- import qualified Distribution.Client.Info as Info import Distribution.Client.IndexUtils as IndexUtils          ( getSourcePackages, getInstalledPackages ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -62,7 +73,12 @@          , ConfigFlags(..), configureCommand, filterConfigureFlags          , ConfigExFlags(..), InstallFlags(..) ) import Distribution.Client.Config-         ( defaultCabalDir )+         ( defaultCabalDir, defaultUserInstall )+import Distribution.Client.Sandbox.Timestamp+         ( withUpdateTimestamps )+import Distribution.Client.Sandbox.Types+         ( SandboxPackageInfo(..), UseSandbox(..), isUseSandbox+         , whenUsingSandbox ) import Distribution.Client.Tar (extractTarGzFile) import Distribution.Client.Types as Source import Distribution.Client.BuildReports.Types@@ -78,25 +94,29 @@ import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade import qualified Distribution.Client.World as World import qualified Distribution.InstalledPackageInfo as Installed-import Paths_cabal_install (getBinDir)+import Distribution.Client.Compat.ExecutablePath import Distribution.Client.JobControl  import Distribution.Simple.Compiler          ( CompilerId(..), Compiler(compilerId), compilerFlavor          , PackageDB(..), PackageDBStack )-import Distribution.Simple.Program (ProgramConfiguration, defaultProgramConfiguration)+import Distribution.Simple.Program (ProgramConfiguration,+                                    defaultProgramConfiguration) import qualified Distribution.Simple.InstallDirs as InstallDirs import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Simple.Setup          ( haddockCommand, HaddockFlags(..)          , buildCommand, BuildFlags(..), emptyBuildFlags-         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe )+         , toFlag, fromFlag, fromFlagOrDefault, flagToMaybe, defaultDistPref ) import qualified Distribution.Simple.Setup as Cabal-         ( installCommand, InstallFlags(..), emptyInstallFlags-         , emptyTestFlags, testCommand, Flag(..) )+         ( Flag(..)+         , copyCommand, CopyFlags(..), emptyCopyFlags+         , registerCommand, RegisterFlags(..), emptyRegisterFlags+         , testCommand, TestFlags(..), emptyTestFlags ) import Distribution.Simple.Utils-         ( rawSystemExit, comparing )+         ( createDirectoryIfMissingVerbose, rawSystemExit, comparing+         , writeFileAtomic, withTempFile , withFileContents ) import Distribution.Simple.InstallDirs as InstallDirs          ( PathTemplate, fromPathTemplate, toPathTemplate, substPathTemplate          , initialPathTemplateEnv, installDirsTemplateEnv )@@ -110,18 +130,22 @@          , FlagName(..), FlagAssignment ) import Distribution.PackageDescription.Configuration          ( finalizePackageDescription )+import Distribution.ParseUtils+         ( showPWarning ) import Distribution.Version-         ( Version, anyVersion, thisVersion )+         ( Version ) import Distribution.Simple.Utils as Utils-         ( notice, info, warn, die, intercalate, withTempDirectory )+         ( notice, info, warn, debug, debugNoWrap, die+         , intercalate, withTempDirectory ) import Distribution.Client.Utils-         ( numberOfProcessors, inDir, mergeBy, MergeResult(..) )+         ( determineNumJobs, inDir, mergeBy, MergeResult(..)+         , tryCanonicalizePath ) import Distribution.System-         ( Platform, buildPlatform, OS(Windows), buildOS )+         ( Platform, OS(Windows), buildOS ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-         ( Verbosity, showForCabal, verbose, deafening )+         ( Verbosity, showForCabal, normal, verbose ) import Distribution.Simple.BuildPaths ( exeExtension )  --TODO:@@ -142,12 +166,15 @@  -- | Installs the packages needed to satisfy a list of dependencies. ---install, upgrade+install   :: Verbosity   -> PackageDBStack   -> [Repo]   -> Compiler+  -> Platform   -> ProgramConfiguration+  -> UseSandbox+  -> Maybe SandboxPackageInfo   -> GlobalFlags   -> ConfigFlags   -> ConfigExFlags@@ -155,78 +182,124 @@   -> HaddockFlags   -> [UserTarget]   -> IO ()-install verbosity packageDBs repos comp conf-  globalFlags configFlags configExFlags installFlags haddockFlags userTargets0 = do+install verbosity packageDBs repos comp platform conf useSandbox mSandboxPkgInfo+  globalFlags configFlags configExFlags installFlags haddockFlags+  userTargets0 = do +    installContext <- makeInstallContext verbosity args (Just userTargets0)+    installPlan    <- foldProgress logMsg die' return =<<+                      makeInstallPlan verbosity args installContext++    processInstallPlan verbosity args installContext installPlan+  where+    args :: InstallArgs+    args = (packageDBs, repos, comp, platform, conf, useSandbox, mSandboxPkgInfo,+            globalFlags, configFlags, configExFlags, installFlags,+            haddockFlags)++    die' message = die (message ++ if isUseSandbox useSandbox+                                   then installFailedInSandbox else [])+    -- TODO: use a better error message, remove duplication.+    installFailedInSandbox =+      "\nNote: when using a sandbox, all packages are required to have "+      ++ "consistent dependencies. "+      ++ "Try reinstalling/unregistering the offending packages or "+      ++ "recreating the sandbox."+    logMsg message rest = debugNoWrap verbosity message >> rest++-- TODO: Make InstallContext a proper datatype with documented fields.+-- | Common context for makeInstallPlan and processInstallPlan.+type InstallContext = ( PackageIndex, SourcePackageDb+                      , [UserTarget], [PackageSpecifier SourcePackage] )++-- TODO: Make InstallArgs a proper datatype with documented fields or just get+-- rid of it completely.+-- | Initial arguments given to 'install' or 'makeInstallContext'.+type InstallArgs = ( PackageDBStack+                   , [Repo]+                   , Compiler+                   , Platform+                   , ProgramConfiguration+                   , UseSandbox+                   , Maybe SandboxPackageInfo+                   , GlobalFlags+                   , ConfigFlags+                   , ConfigExFlags+                   , InstallFlags+                   , HaddockFlags )++-- | Make an install context given install arguments.+makeInstallContext :: Verbosity -> InstallArgs -> Maybe [UserTarget]+                      -> IO InstallContext+makeInstallContext verbosity+  (packageDBs, repos, comp, _, conf,_,_,+   globalFlags, _, _, _, _) mUserTargets = do+     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf     sourcePkgDb       <- getSourcePackages    verbosity repos -    solver <- chooseSolver verbosity (fromFlag (configSolver  configExFlags)) (compilerId comp)+    (userTargets, pkgSpecifiers) <- case mUserTargets of+      Nothing           ->+        -- We want to distinguish between the case where the user has given an+        -- empty list of targets on the command-line and the case where we+        -- specifically want to have an empty list of targets.+        return ([], [])+      Just userTargets0 -> do+        -- For install, if no target is given it means we use the current+        -- directory as the single target.+        let userTargets | null userTargets0 = [UserTargetLocalDir "."]+                        | otherwise         = userTargets0 -    let -- For install, if no target is given it means we use the-        -- current directory as the single target-        userTargets | null userTargets0 = [UserTargetLocalDir "."]-                    | otherwise         = userTargets0+        pkgSpecifiers <- resolveUserTargets verbosity+                         (fromFlag $ globalWorldFile globalFlags)+                         (packageIndex sourcePkgDb)+                         userTargets+        return (userTargets, pkgSpecifiers) -    pkgSpecifiers <- resolveUserTargets verbosity-                       (fromFlag $ globalWorldFile globalFlags)-                       (packageIndex sourcePkgDb)-                       userTargets+    return (installedPkgIndex, sourcePkgDb, userTargets, pkgSpecifiers) +-- | Make an install plan given install context and install arguments.+makeInstallPlan :: Verbosity -> InstallArgs -> InstallContext+                -> IO (Progress String String InstallPlan)+makeInstallPlan verbosity+  (_, _, comp, platform, _, _, mSandboxPkgInfo,+   _, configFlags, configExFlags, installFlags,+   _)+  (installedPkgIndex, sourcePkgDb,+   _, pkgSpecifiers) = do++    solver <- chooseSolver verbosity (fromFlag (configSolver configExFlags))+              (compilerId comp)     notice verbosity "Resolving dependencies..."-    installPlan   <- foldProgress logMsg die return $-                       planPackages-                         comp solver configFlags configExFlags installFlags-                         installedPkgIndex sourcePkgDb pkgSpecifiers+    return $ planPackages comp platform mSandboxPkgInfo solver+      configFlags configExFlags installFlags+      installedPkgIndex sourcePkgDb pkgSpecifiers +-- | Given an install plan, perform the actual installations.+processInstallPlan :: Verbosity -> InstallArgs -> InstallContext+                   -> InstallPlan+                   -> IO ()+processInstallPlan verbosity+  args@(_,_, _, _, _, _, _, _, _, _, installFlags, _)+  (installedPkgIndex, sourcePkgDb,+   userTargets, pkgSpecifiers) installPlan = do     checkPrintPlan verbosity installedPkgIndex installPlan sourcePkgDb       installFlags pkgSpecifiers      unless dryRun $ do       installPlan' <- performInstallations verbosity-                        context installedPkgIndex installPlan-      postInstallActions verbosity context userTargets installPlan'-+                      args installedPkgIndex installPlan+      postInstallActions verbosity args userTargets installPlan'   where-    context :: InstallContext-    context = (packageDBs, repos, comp, conf,-               globalFlags, configFlags, configExFlags, installFlags, haddockFlags)--    dryRun      = fromFlag (installDryRun installFlags)-    logMsg message rest = debugNoWrap message >> rest-    -- Solver debug output really looks better without automatic-    -- line wrapping. TODO: This should probably be moved into-    -- the utilities module.-    debugNoWrap xs = when (verbosity >= deafening) (putStrLn xs >> hFlush stdout)--upgrade _ _ _ _ _ _ _ _ _ _ _ = die $-    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"- ++ "You can install the latest version of a package using 'cabal install'. "- ++ "The 'cabal upgrade' command has been removed because people found it "- ++ "confusing and it often led to broken packages.\n"- ++ "If you want the old upgrade behaviour then use the install command "- ++ "with the --upgrade-dependencies flag (but check first with --dry-run "- ++ "to see what would happen). This will try to pick the latest versions "- ++ "of all dependencies, rather than the usual behaviour of trying to pick "- ++ "installed versions of all dependencies. If you do use "- ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "- ++ "packages (e.g. by using appropriate --constraint= flags)."--type InstallContext = ( PackageDBStack-                      , [Repo]-                      , Compiler-                      , ProgramConfiguration-                      , GlobalFlags-                      , ConfigFlags-                      , ConfigExFlags-                      , InstallFlags-                      , HaddockFlags )+    dryRun = fromFlag (installDryRun installFlags)  -- ------------------------------------------------------------ -- * Installation planning -- ------------------------------------------------------------  planPackages :: Compiler+             -> Platform+             -> Maybe SandboxPackageInfo              -> Solver              -> ConfigFlags              -> ConfigExFlags@@ -235,15 +308,16 @@              -> SourcePackageDb              -> [PackageSpecifier SourcePackage]              -> Progress String String InstallPlan-planPackages comp solver configFlags configExFlags installFlags+planPackages comp platform mSandboxPkgInfo solver+             configFlags configExFlags installFlags              installedPkgIndex sourcePkgDb pkgSpecifiers =          resolveDependencies-          buildPlatform (compilerId comp)+          platform (compilerId comp)           solver           resolverParams -    >>= if onlyDeps then adjustPlanOnlyDeps else return+    >>= if onlyDeps then pruneInstallPlan pkgSpecifiers else return    where     resolverParams =@@ -262,6 +336,8 @@       . setPreferenceDefault (if upgradeDeps then PreferAllLatest                                              else PreferLatestForSelected) +      . removeUpperBounds allowNewer+       . addPreferences           -- preferences from the config file or command line           [ PackageVersionPreference name ver@@ -283,9 +359,12 @@           [ PackageConstraintStanzas (pkgSpecifierTarget pkgSpecifier) stanzas           | pkgSpecifier <- pkgSpecifiers ] +      . maybe id applySandboxInstallPolicy mSandboxPkgInfo+       . (if reinstall then reinstallTargets else id) -      $ standardInstallPolicy installedPkgIndex sourcePkgDb pkgSpecifiers+      $ standardInstallPolicy+        installedPkgIndex sourcePkgDb pkgSpecifiers      stanzas = concat         [ if testsEnabled then [TestStanzas] else []@@ -294,33 +373,6 @@     testsEnabled = fromFlagOrDefault False $ configTests configFlags     benchmarksEnabled = fromFlagOrDefault False $ configBenchmarks configFlags -    --TODO: this is a general feature and should be moved to D.C.Dependency-    -- Also, the InstallPlan.remove should return info more precise to the-    -- problem, rather than the very general PlanProblem type.-    adjustPlanOnlyDeps :: InstallPlan -> Progress String String InstallPlan-    adjustPlanOnlyDeps =-        either (Fail . explain) Done-      . InstallPlan.remove (isTarget pkgSpecifiers)-      where-        explain :: [InstallPlan.PlanProblem] -> String-        explain problems =-            "Cannot select only the dependencies (as requested by the "-         ++ "'--only-dependencies' flag), "-         ++ (case pkgids of-               [pkgid] -> "the package " ++ display pkgid ++ " is "-               _       -> "the packages "-                       ++ intercalate ", " (map display pkgids) ++ " are ")-         ++ "required by a dependency of one of the other targets."-          where-            pkgids =-              nub [ depid-                  | InstallPlan.PackageMissingDeps _ depids <- problems-                  , depid <- depids-                  , packageName depid `elem` targetnames ]--        targetnames  = map pkgSpecifierTarget pkgSpecifiers--     reinstall        = fromFlag (installReinstall        installFlags)     reorderGoals     = fromFlag (installReorderGoals     installFlags)     independentGoals = fromFlag (installIndependentGoals installFlags)@@ -329,7 +381,36 @@     maxBackjumps     = fromFlag (installMaxBackjumps     installFlags)     upgradeDeps      = fromFlag (installUpgradeDeps      installFlags)     onlyDeps         = fromFlag (installOnlyDeps         installFlags)+    allowNewer       = fromFlag (configAllowNewer        configExFlags) +-- | Remove the provided targets from the install plan.+pruneInstallPlan :: Package pkg => [PackageSpecifier pkg] -> InstallPlan+                    -> Progress String String InstallPlan+pruneInstallPlan pkgSpecifiers =+  -- TODO: this is a general feature and should be moved to D.C.Dependency+  -- Also, the InstallPlan.remove should return info more precise to the+  -- problem, rather than the very general PlanProblem type.+  either (Fail . explain) Done+  . InstallPlan.remove (\pkg -> packageName pkg `elem` targetnames)+  where+    explain :: [InstallPlan.PlanProblem] -> String+    explain problems =+      "Cannot select only the dependencies (as requested by the "+      ++ "'--only-dependencies' flag), "+      ++ (case pkgids of+             [pkgid] -> "the package " ++ display pkgid ++ " is "+             _       -> "the packages "+                        ++ intercalate ", " (map display pkgids) ++ " are ")+      ++ "required by a dependency of one of the other targets."+      where+        pkgids =+          nub [ depid+              | InstallPlan.PackageMissingDeps _ depids <- problems+              , depid <- depids+              , packageName depid `elem` targetnames ]++    targetnames  = map pkgSpecifierTarget pkgSpecifiers+ -- ------------------------------------------------------------ -- * Informational messages -- ------------------------------------------------------------@@ -414,7 +495,7 @@  linearizeInstallPlan :: PackageIndex                      -> InstallPlan-                     -> [(ConfiguredPackage, PackageStatus)]+                     -> [(ReadyPackage, PackageStatus)] linearizeInstallPlan installedPkgIndex plan =     unfoldr next plan   where@@ -425,7 +506,9 @@           pkgid  = packageId pkg           status = packageStatus installedPkgIndex pkg           plan'' = InstallPlan.completed pkgid-                     (BuildOk DocsNotTried TestsNotTried)+                     (BuildOk DocsNotTried TestsNotTried+                              (Just $ Installed.emptyInstalledPackageInfo+                              { Installed.sourcePackageId = pkgid }))                      (InstallPlan.processing [pkg] plan')           --FIXME: This is a bit of a hack,           -- pretending that each package is installed@@ -436,21 +519,17 @@  type PackageChange = MergeResult PackageIdentifier PackageIdentifier -isTarget :: Package pkg => [PackageSpecifier SourcePackage] -> pkg -> Bool-isTarget pkgSpecifiers pkg = packageName pkg `elem` targetnames-  where-    targetnames  = map pkgSpecifierTarget pkgSpecifiers- extractReinstalls :: PackageStatus -> [InstalledPackageId] extractReinstalls (Reinstall ipids _) = ipids extractReinstalls _                   = [] -packageStatus :: PackageIndex -> ConfiguredPackage -> PackageStatus+packageStatus :: PackageIndex -> ReadyPackage -> PackageStatus packageStatus installedPkgIndex cpkg =   case PackageIndex.lookupPackageName installedPkgIndex                                       (packageName cpkg) of     [] -> NewPackage-    ps ->  case filter ((==packageId cpkg) . Installed.sourcePackageId) (concatMap snd ps) of+    ps ->  case filter ((==packageId cpkg)+                        . Installed.sourcePackageId) (concatMap snd ps) of       []           -> NewVersion (map fst ps)       pkgs@(pkg:_) -> Reinstall (map Installed.installedPackageId pkgs)                                 (changes pkg cpkg)@@ -458,24 +537,26 @@   where      changes :: Installed.InstalledPackageInfo-            -> ConfiguredPackage+            -> ReadyPackage             -> [MergeResult PackageIdentifier PackageIdentifier]-    changes pkg pkg' = filter changed-                     $ mergeBy (comparing packageName)-                         -- get dependencies of installed package (convert to source pkg ids via index)-                         (nub . sort . concatMap (maybeToList .-                                                  fmap Installed.sourcePackageId .-                                                  PackageIndex.lookupInstalledPackageId installedPkgIndex) .-                                                  Installed.depends $ pkg)-                         -- get dependencies of configured package-                         (nub . sort . depends $ pkg')+    changes pkg pkg' =+      filter changed+      $ mergeBy (comparing packageName)+        -- get dependencies of installed package (convert to source pkg ids via+        -- index)+        (nub . sort . concatMap+         (maybeToList . fmap Installed.sourcePackageId .+          PackageIndex.lookupInstalledPackageId installedPkgIndex) .+         Installed.depends $ pkg)+        -- get dependencies of configured package+        (nub . sort . depends $ pkg')      changed (InBoth    pkgid pkgid') = pkgid /= pkgid'     changed _                        = True  printPlan :: Bool -- is dry run           -> Verbosity-          -> [(ConfiguredPackage, PackageStatus)]+          -> [(ReadyPackage, PackageStatus)]           -> SourcePackageDb           -> IO () printPlan dryRun verbosity plan sourcePkgDb = case plan of@@ -485,7 +566,8 @@         ("In order, the following " ++ wouldWill ++ " be installed:")       : map showPkgAndReason pkgs     | otherwise -> notice verbosity $ unlines $-        ("In order, the following " ++ wouldWill ++ " be installed (use -v for more details):")+        ("In order, the following " ++ wouldWill+         ++ " be installed (use -v for more details):")       : map showPkg pkgs   where     wouldWill | dryRun    = "would"@@ -505,10 +587,10 @@                 []   -> ""                 diff -> " changes: "  ++ intercalate ", " (map change diff) -    showLatest :: ConfiguredPackage -> String+    showLatest :: ReadyPackage -> String     showLatest pkg = case mLatestVersion of         Just latestVersion ->-            if pkgVersion /= latestVersion+            if pkgVersion < latestVersion             then (" (latest: " ++ display latestVersion ++ ")")             else ""         Nothing -> ""@@ -524,15 +606,15 @@     toFlagAssignment :: [Flag] -> FlagAssignment     toFlagAssignment = map (\ f -> (flagName f, flagDefault f)) -    nonDefaultFlags :: ConfiguredPackage -> FlagAssignment-    nonDefaultFlags (ConfiguredPackage spkg fa _ _) =+    nonDefaultFlags :: ReadyPackage -> FlagAssignment+    nonDefaultFlags (ReadyPackage spkg fa _ _) =       let defaultAssignment =             toFlagAssignment              (genPackageFlags (Source.packageDescription spkg))       in  fa \\ defaultAssignment -    stanzas :: ConfiguredPackage -> [OptionalStanza]-    stanzas (ConfiguredPackage _ _ sts _) = sts+    stanzas :: ReadyPackage -> [OptionalStanza]+    stanzas (ReadyPackage _ _ sts _) = sts      showStanzas :: [OptionalStanza] -> String     showStanzas = concatMap ((' ' :) . showStanza)@@ -565,12 +647,13 @@ --  * error reporting -- postInstallActions :: Verbosity-                   -> InstallContext+                   -> InstallArgs                    -> [UserTarget]                    -> InstallPlan                    -> IO () postInstallActions verbosity-  (packageDBs, _, comp, conf, globalFlags, configFlags, _, installFlags, _)+  (packageDBs, _, comp, platform, conf, useSandbox, mSandboxPkgInfo+  ,globalFlags, configFlags, _, installFlags, _)   targets installPlan = do    unless oneShot $@@ -581,18 +664,22 @@    let buildReports = BuildReports.fromInstallPlan installPlan   BuildReports.storeLocal (installSummaryFile installFlags) buildReports+    (InstallPlan.planPlatform installPlan)   when (reportingLevel >= AnonymousReports) $     BuildReports.storeAnonymous buildReports   when (reportingLevel == DetailedReports) $     storeDetailedBuildReports verbosity logsDir buildReports -  regenerateHaddockIndex verbosity packageDBs comp conf+  regenerateHaddockIndex verbosity packageDBs comp platform conf                          configFlags installFlags installPlan    symlinkBinaries verbosity configFlags installFlags installPlan    printBuildFailures installPlan +  updateSandboxTimestampsFile useSandbox mSandboxPkgInfo+                              comp platform installPlan+   where     reportingLevel = fromFlag (installBuildReports installFlags)     logsDir        = fromFlag (globalLogsDir globalFlags)@@ -627,11 +714,7 @@       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 @@ -639,12 +722,13 @@ regenerateHaddockIndex :: Verbosity                        -> [PackageDB]                        -> Compiler+                       -> Platform                        -> ProgramConfiguration                        -> ConfigFlags                        -> InstallFlags                        -> InstallPlan                        -> IO ()-regenerateHaddockIndex verbosity packageDBs comp conf+regenerateHaddockIndex verbosity packageDBs comp platform conf                        configFlags installFlags installPlan   | haddockIndexFileIsRequested && shouldRegenerateHaddockIndex = do @@ -678,7 +762,7 @@         normalUserInstall     = (UserPackageDB `elem` packageDBs)                              && all (not . isSpecificPackageDB) packageDBs -        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _)) = True+        installedDocs (InstallPlan.Installed _ (BuildOk DocsOk _ _)) = True         installedDocs _                                            = False         isSpecificPackageDB (SpecificPackageDB _) = True         isSpecificPackageDB _                     = False@@ -688,7 +772,7 @@       where         env  = env0 ++ installDirsTemplateEnv absoluteDirs         env0 = InstallDirs.compilerTemplateEnv (compilerId comp)-            ++ InstallDirs.platformTemplateEnv (buildPlatform)+            ++ InstallDirs.platformTemplateEnv platform         absoluteDirs = InstallDirs.substituteInstallDirTemplates                          env0 templateDirs         templateDirs = InstallDirs.combineInstallDirs fromFlagOrDefault@@ -736,19 +820,48 @@       DependentFailed pkgid -> " depends on " ++ display pkgid                             ++ " which failed to install."       DownloadFailed  e -> " failed while downloading the package."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       UnpackFailed    e -> " failed while unpacking the package."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       ConfigureFailed e -> " failed during the configure step."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       BuildFailed     e -> " failed during the building phase."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       TestsFailed     e -> " failed during the tests phase."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e       InstallFailed   e -> " failed during the final install step."-                        ++ " The exception was:\n  " ++ show e+                        ++ showException e +    showException e   =  " The exception was:\n  " ++ show e ++ maybeOOM e+#ifdef mingw32_HOST_OS+    maybeOOM _        = ""+#else+    maybeOOM e                    = maybe "" onExitFailure (fromException e)+    onExitFailure (ExitFailure 9) =+      "\nThis may be due to an out-of-memory condition."+    onExitFailure _               = ""+#endif ++-- | If we're working inside a sandbox and some add-source deps were installed,+-- update the timestamps of those deps.+updateSandboxTimestampsFile :: UseSandbox -> Maybe SandboxPackageInfo+                            -> Compiler -> Platform -> InstallPlan+                            -> IO ()+updateSandboxTimestampsFile (UseSandbox sandboxDir)+                            (Just (SandboxPackageInfo _ _ _ allAddSourceDeps))+                            comp platform installPlan =+  withUpdateTimestamps sandboxDir (compilerId comp) platform $ \_ -> do+    let allInstalled = [ pkg | InstallPlan.Installed pkg _+                            <- InstallPlan.toList installPlan ]+        allSrcPkgs   = [ pkg | ReadyPackage pkg _ _ _ <- allInstalled ]+        allPaths     = [ pth | LocalUnpackedPackage pth+                            <- map packageSource allSrcPkgs]+    allPathsCanonical <- mapM tryCanonicalizePath allPaths+    return $! filter (`S.member` allAddSourceDeps) allPathsCanonical++updateSandboxTimestampsFile _ _ _ _ _ = return ()+ -- ------------------------------------------------------------ -- * Actually do the installations -- ------------------------------------------------------------@@ -763,46 +876,54 @@ type UseLogFile = Maybe (PackageIdentifier -> FilePath, Verbosity)  performInstallations :: Verbosity-                     -> InstallContext+                     -> InstallArgs                      -> PackageIndex                      -> InstallPlan                      -> IO InstallPlan performInstallations verbosity-  (packageDBs, _, comp, conf,+  (packageDBs, _, comp, _, conf, useSandbox, _,    globalFlags, configFlags, configExFlags, installFlags, haddockFlags)   installedPkgIndex installPlan = do -  jobControl   <- if parallelBuild then newParallelJobControl-                                   else newSerialJobControl+  -- With 'install -j' it can be a bit hard to tell whether a sandbox is used.+  whenUsingSandbox useSandbox $ \sandboxDir ->+    when parallelInstall $+      notice verbosity $ "Notice: installing into a sandbox located at "+                         ++ sandboxDir++  jobControl   <- if parallelInstall then newParallelJobControl+                                     else newSerialJobControl   buildLimit   <- newJobLimit numJobs   fetchLimit   <- newJobLimit (min numJobs numFetchJobs)   installLock  <- newLock -- serialise installation   cacheLock    <- newLock -- serialise access to setup exe cache -  executeInstallPlan verbosity jobControl useLogFile installPlan $ \cpkg ->-    installConfiguredPackage platform compid configFlags-                             cpkg $ \configFlags' src pkg ->+  executeInstallPlan verbosity jobControl useLogFile installPlan $ \rpkg ->+    installReadyPackage platform compid configFlags+                        rpkg $ \configFlags' src pkg pkgoverride ->       fetchSourcePackage verbosity fetchLimit src $ \src' ->-        installLocalPackage verbosity buildLimit (packageId pkg) src' $ \mpath ->+        installLocalPackage verbosity buildLimit+                            (packageId pkg) src' distPref $ \mpath ->           installUnpackedPackage verbosity buildLimit installLock numJobs                                  (setupScriptOptions installedPkgIndex cacheLock)                                  miscOptions configFlags' installFlags haddockFlags-                                 compid pkg mpath useLogFile+                                 compid platform pkg pkgoverride mpath useLogFile    where     platform = InstallPlan.planPlatform installPlan     compid   = InstallPlan.planCompiler installPlan -    numJobs  = case installNumJobs installFlags of-      Cabal.NoFlag        -> 1-      Cabal.Flag Nothing  -> numberOfProcessors-      Cabal.Flag (Just n) -> n-    numFetchJobs = 2-    parallelBuild = numJobs >= 2+    numJobs         = determineNumJobs (installNumJobs installFlags)+    numFetchJobs    = 2+    parallelInstall = numJobs >= 2+    distPref        = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                      (configDistPref configFlags)      setupScriptOptions index lock = SetupScriptOptions {-      useCabalVersion  = maybe anyVersion thisVersion (libVersion miscOptions),+      useCabalVersion  = chooseCabalVersion configExFlags+                         (libVersion miscOptions),       useCompiler      = Just comp,+      usePlatform      = Just platform,       -- 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.@@ -816,12 +937,10 @@                            then Just index                            else Nothing,       useProgramConfig = conf,-      useDistPref      = fromFlagOrDefault-                           (useDistPref defaultSetupScriptOptions)-                           (configDistPref configFlags),+      useDistPref      = distPref,       useLoggingHandle = Nothing,       useWorkingDir    = Nothing,-      forceExternalSetupMethod = parallelBuild,+      forceExternalSetupMethod = parallelInstall,       setupCacheLock   = Just lock     }     reportingLevel = fromFlag (installBuildReports installFlags)@@ -854,25 +973,28 @@         useDefaultTemplate           | reportingLevel == DetailedReports = True           | isJust installLogFile'            = False-          | parallelBuild                     = True+          | parallelInstall                   = True           | otherwise                         = False          overrideVerbosity :: Bool         overrideVerbosity           | reportingLevel == DetailedReports = True           | isJust installLogFile'            = True-          | parallelBuild                     = False+          | parallelInstall                   = False           | otherwise                         = False      substLogFileName :: PathTemplate -> PackageIdentifier -> FilePath     substLogFileName template pkg = fromPathTemplate                                   . substPathTemplate env                                   $ template-      where env = initialPathTemplateEnv (packageId pkg) (compilerId comp)+      where env = initialPathTemplateEnv (packageId pkg)+                  (compilerId comp) platform      miscOptions  = InstallMisc {       rootCmd    = if fromFlag (configUserInstall configFlags)-                     then Nothing      -- ignore --root-cmd if --user.+                      || (isUseSandbox useSandbox)+                     then Nothing      -- ignore --root-cmd if --user+                                       -- or working inside a sandbox.                      else flagToMaybe (installRootCmd installFlags),       libVersion = flagToMaybe (configCabalVersion configExFlags)     }@@ -882,7 +1004,7 @@                    -> JobControl IO (PackageId, BuildResult)                    -> UseLogFile                    -> InstallPlan-                   -> (ConfiguredPackage -> IO BuildResult)+                   -> (ReadyPackage -> IO BuildResult)                    -> IO InstallPlan executeInstallPlan verbosity jobCtl useLogFile plan0 installPkg =     tryNewTasks 0 plan0@@ -932,45 +1054,61 @@         (Right _) -> notice verbosity $ "Installed " ++ display pkgid         (Left _)  -> do           notice verbosity $ "Failed to install " ++ display pkgid-          case useLogFile of-            Nothing                   -> return ()-            Just (mkLogFileName, _) -> do-              let (logName, n) = (mkLogFileName pkgid, 10)-              notice verbosity $ "Last " ++ (show n)-                ++ " lines of the build log ( " ++ logName ++ " ):"-              printLastNLines logName n+          when (verbosity >= normal) $+            case useLogFile of+              Nothing                 -> return ()+              Just (mkLogFileName, _) -> do+                let logName = mkLogFileName pkgid+                    n       = 10+                putStr $ "Last " ++ (show n)+                  ++ " lines of the build log ( " ++ logName ++ " ):\n"+                printLastNLines logName n      printLastNLines :: FilePath -> Int -> IO ()     printLastNLines path n = do       lns <- fmap lines $ readFile path       let len = length lns-      let toDrop = if len > n && n > 0 then (len - n) else 0-      mapM_ (notice verbosity) (drop toDrop lns)+      let toDrop = if (len > n && n > 0) then (len - n) else 0+      mapM_ putStrLn (drop toDrop lns)  -- | Call an installer for an 'SourcePackage' but override the configure--- flags with the ones given by the 'ConfiguredPackage'. In particular the--- 'ConfiguredPackage' specifies an exact 'FlagAssignment' and exactly+-- flags with the ones given by the 'ReadyPackage'. In particular the+-- 'ReadyPackage' specifies an exact 'FlagAssignment' and exactly -- versioned package dependencies. So we ignore any previous partial flag -- assignment or dependency constraints and use the new ones. ---installConfiguredPackage :: Platform -> CompilerId-                         ->  ConfigFlags -> ConfiguredPackage-                         -> (ConfigFlags -> PackageLocation (Maybe FilePath)-                                         -> PackageDescription -> a)-                         -> a-installConfiguredPackage platform comp configFlags-  (ConfiguredPackage (SourcePackage _ gpkg source) flags stanzas deps)+-- NB: when updating this function, don't forget to also update+-- 'configurePackage' in D.C.Configure.+installReadyPackage :: Platform -> CompilerId+                       -> ConfigFlags+                       -> ReadyPackage+                       -> (ConfigFlags -> PackageLocation (Maybe FilePath)+                                       -> PackageDescription+                                       -> PackageDescriptionOverride -> a)+                       -> a+installReadyPackage platform comp configFlags+  (ReadyPackage (SourcePackage _ gpkg source pkgoverride)+   flags stanzas deps)   installPkg = installPkg configFlags {     configConfigurationsFlags = flags,-    configConstraints = map thisPackageVersion deps,-    configBenchmarks = toFlag False,-    configTests = toFlag (TestStanzas `elem` stanzas)-  } source pkg+    -- We generate the legacy constraints as well as the new style precise deps.+    -- In the end only one set gets passed to Setup.hs configure, depending on+    -- the Cabal version we are talking to.+    configConstraints  = [ thisPackageVersion (packageId deppkg)+                         | deppkg <- deps ],+    configDependencies = [ (packageName (Installed.sourcePackageId deppkg),+                            Installed.installedPackageId deppkg)+                         | deppkg <- deps ],+    -- Use '--exact-configuration' if supported.+    configExactConfiguration = toFlag True,+    configBenchmarks         = toFlag False,+    configTests              = toFlag (TestStanzas `elem` stanzas)+  } source pkg pkgoverride   where     pkg = case finalizePackageDescription flags            (const True)            platform comp [] (enableStanzas stanzas gpkg) of-      Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+      Left _ -> error "finalizePackageDescription ReadyPackage failed"       Right (desc, _) -> desc  fetchSourcePackage@@ -992,10 +1130,10 @@ installLocalPackage   :: Verbosity   -> JobLimit-  -> PackageIdentifier -> PackageLocation FilePath+  -> PackageIdentifier -> PackageLocation FilePath -> FilePath   -> (Maybe FilePath -> IO BuildResult)   -> IO BuildResult-installLocalPackage verbosity jobLimit pkgid location installPkg =+installLocalPackage verbosity jobLimit pkgid location distPref installPkg =    case location of @@ -1004,24 +1142,25 @@      LocalTarballPackage tarballPath ->       installLocalTarballPackage verbosity jobLimit-        pkgid tarballPath installPkg+        pkgid tarballPath distPref installPkg      RemoteTarballPackage _ tarballPath ->       installLocalTarballPackage verbosity jobLimit-        pkgid tarballPath installPkg+        pkgid tarballPath distPref installPkg      RepoTarballPackage _ _ tarballPath ->       installLocalTarballPackage verbosity jobLimit-        pkgid tarballPath installPkg+        pkgid tarballPath distPref installPkg   installLocalTarballPackage   :: Verbosity   -> JobLimit-  -> PackageIdentifier -> FilePath+  -> PackageIdentifier -> FilePath -> FilePath   -> (Maybe FilePath -> IO BuildResult)   -> IO BuildResult-installLocalTarballPackage verbosity jobLimit pkgid tarballPath installPkg = do+installLocalTarballPackage verbosity jobLimit pkgid+                           tarballPath distPref installPkg = do   tmp <- getTemporaryDirectory   withTempDirectory verbosity tmp (display pkgid) $ \tmpDirPath ->     onFailure UnpackFailed $ do@@ -1036,8 +1175,33 @@         exists <- doesFileExist descFilePath         when (not exists) $           die $ "Package .cabal file not found: " ++ show descFilePath+        maybeRenameDistDir absUnpackedPath+       installPkg (Just absUnpackedPath) +  where+    -- 'cabal sdist' puts pre-generated files in the 'dist' directory. This+    -- fails when we use a nonstandard build directory name (as is the case+    -- with sandboxes), so we need to rename the 'dist' dir here.+    --+    -- TODO: 'cabal get happy && cd sandbox && cabal install ../happy' still+    -- fails even with this workaround. We probably can live with that.+    maybeRenameDistDir :: FilePath -> IO ()+    maybeRenameDistDir absUnpackedPath = do+      let distDirPath    = absUnpackedPath </> defaultDistPref+          distDirPathTmp = absUnpackedPath </> (defaultDistPref ++ "-tmp")+          distDirPathNew = absUnpackedPath </> distPref+      distDirExists <- doesDirectoryExist distDirPath+      when distDirExists $ do+        -- NB: we need to handle the case when 'distDirPathNew' is a+        -- subdirectory of 'distDirPath' (e.g. 'dist/dist-sandbox-3688fbc2').+        debug verbosity $ "Renaming '" ++ distDirPath ++ "' to '"+          ++ distDirPathTmp ++ "'."+        renameDirectory distDirPath distDirPathTmp+        createDirectoryIfMissingVerbose verbosity False distDirPath+        debug verbosity $ "Renaming '" ++ distDirPathTmp ++ "' to '"+          ++ distDirPathNew ++ "'."+        renameDirectory distDirPathTmp distDirPathNew  installUnpackedPackage   :: Verbosity@@ -1050,30 +1214,55 @@   -> InstallFlags   -> HaddockFlags   -> CompilerId+  -> Platform   -> PackageDescription+  -> PackageDescriptionOverride   -> Maybe FilePath -- ^ Directory to change to before starting the installation.   -> UseLogFile -- ^ File to log output to (if any)   -> IO BuildResult installUnpackedPackage verbosity buildLimit installLock numJobs                        scriptOptions miscOptions                        configFlags installConfigFlags haddockFlags-                       compid pkg workingDir useLogFile =+                       compid platform pkg pkgoverride workingDir useLogFile = do +  -- Override the .cabal file if necessary+  case pkgoverride of+    Nothing     -> return ()+    Just pkgtxt -> do+      let descFilePath = fromMaybe "." workingDir+                     </> display (packageName pkgid) <.> "cabal"+      info verbosity $+        "Updating " ++ display (packageName pkgid) <.> "cabal"+                    ++ " with the latest revision from the index."+      writeFileAtomic descFilePath pkgtxt++  -- Make sure that we pass --libsubdir etc to 'setup configure' (necessary if+  -- the setup script was compiled against an old version of the Cabal lib).+  configFlags' <- addDefaultInstallDirs configFlags+  -- Filter out flags not supported by the old versions of the Cabal lib.+  let configureFlags :: Version -> ConfigFlags+      configureFlags  = filterConfigureFlags configFlags' {+        configVerbosity = toFlag verbosity'+      }++  -- Path to the optional log file.+  mLogPath <- maybeLogPath+   -- Configure phase   onFailure ConfigureFailed $ withJobLimit buildLimit $ do     when (numJobs > 1) $ notice verbosity $       "Configuring " ++ display pkgid ++ "..."-    setup configureCommand configureFlags+    setup configureCommand configureFlags mLogPath    -- Build phase     onFailure BuildFailed $ do       when (numJobs > 1) $ notice verbosity $         "Building " ++ display pkgid ++ "..."-      setup buildCommand' buildFlags+      setup buildCommand' buildFlags mLogPath    -- Doc generation phase       docsResult <- if shouldHaddock-        then (do setup haddockCommand haddockFlags'+        then (do setup haddockCommand haddockFlags' mLogPath                  return DocsOk)                `catchIO`   (\_ -> return DocsFailed)                `catchExit` (\_ -> return DocsFailed)@@ -1082,24 +1271,28 @@   -- Tests phase       onFailure TestsFailed $ do         when (testsEnabled && PackageDescription.hasTests pkg) $-            setup Cabal.testCommand testFlags+            setup Cabal.testCommand testFlags mLogPath          let testsResult | testsEnabled = TestsOk                         | otherwise = TestsNotTried        -- Install phase-        onFailure InstallFailed $ criticalSection installLock $-          withWin32SelfUpgrade verbosity configFlags compid pkg $ do+        onFailure InstallFailed $ criticalSection installLock $ do+          -- Capture installed package configuration file+          maybePkgConf <- maybeGenPkgConf mLogPath++          -- Actual installation+          withWin32SelfUpgrade verbosity configFlags compid platform pkg $ do             case rootCmd miscOptions of               (Just cmd) -> reexec cmd-              Nothing    -> setup Cabal.installCommand installFlags-            return (Right (BuildOk docsResult testsResult))+              Nothing    -> do+                setup Cabal.copyCommand copyFlags mLogPath+                when shouldRegister $ do+                  setup Cabal.registerCommand registerFlags mLogPath+          return (Right (BuildOk docsResult testsResult maybePkgConf))    where     pkgid            = packageId pkg-    configureFlags   = filterConfigureFlags configFlags {-      configVerbosity = toFlag verbosity'-    }     buildCommand'    = buildCommand defaultProgramConfiguration     buildFlags   _   = emptyBuildFlags {       buildDistPref  = configDistPref configFlags,@@ -1107,40 +1300,94 @@     }     shouldHaddock    = fromFlag (installDocumentation installConfigFlags)     haddockFlags' _   = haddockFlags {-      haddockVerbosity = toFlag verbosity'+      haddockVerbosity = toFlag verbosity',+      haddockDistPref  = configDistPref configFlags     }     testsEnabled = fromFlag (configTests configFlags)-    testFlags _ = Cabal.emptyTestFlags-    installFlags _   = Cabal.emptyInstallFlags {-      Cabal.installDistPref  = configDistPref configFlags,-      Cabal.installVerbosity = toFlag verbosity'+    testFlags _ = Cabal.emptyTestFlags {+      Cabal.testDistPref = configDistPref configFlags     }+    copyFlags _ = Cabal.emptyCopyFlags {+      Cabal.copyDistPref   = configDistPref configFlags,+      Cabal.copyDest       = toFlag InstallDirs.NoCopyDest,+      Cabal.copyVerbosity  = toFlag verbosity'+    }+    shouldRegister = PackageDescription.hasLibs pkg+    registerFlags _ = Cabal.emptyRegisterFlags {+      Cabal.regDistPref   = configDistPref configFlags,+      Cabal.regVerbosity  = toFlag verbosity'+    }     verbosity' = maybe verbosity snd useLogFile+    tempTemplate name = name ++ "-" ++ display pkgid -    setup cmd flags  = do+    addDefaultInstallDirs :: ConfigFlags -> IO ConfigFlags+    addDefaultInstallDirs configFlags' = do+      defInstallDirs <- InstallDirs.defaultInstallDirs flavor userInstall False+      return $ configFlags' {+          configInstallDirs = fmap Cabal.Flag .+                              InstallDirs.substituteInstallDirTemplates env $+                              InstallDirs.combineInstallDirs fromFlagOrDefault+                              defInstallDirs (configInstallDirs configFlags)+          }+        where+          CompilerId flavor _ = compid+          env         = initialPathTemplateEnv pkgid compid platform+          userInstall = fromFlagOrDefault defaultUserInstall+                        (configUserInstall configFlags')++    maybeGenPkgConf :: Maybe FilePath+                    -> IO (Maybe Installed.InstalledPackageInfo)+    maybeGenPkgConf mLogPath =+      if shouldRegister then do+        tmp <- getTemporaryDirectory+        withTempFile tmp (tempTemplate "pkgConf") $ \pkgConfFile handle -> do+          hClose handle+          let registerFlags' version = (registerFlags version) {+                Cabal.regGenPkgConf = toFlag (Just pkgConfFile)+              }+          setup Cabal.registerCommand registerFlags' mLogPath+          withFileContents pkgConfFile $ \pkgConfText ->+            case Installed.parseInstalledPackageInfo pkgConfText of+              Installed.ParseFailed perror    -> pkgConfParseFailed perror+              Installed.ParseOk warns pkgConf -> do+                unless (null warns) $+                  warn verbosity $ unlines (map (showPWarning pkgConfFile) warns)+                return (Just pkgConf)+      else return Nothing++    pkgConfParseFailed :: Installed.PError -> IO a+    pkgConfParseFailed perror =+      die $ "Couldn't parse the output of 'setup register --gen-pkg-config':"+            ++ show perror++    maybeLogPath :: IO (Maybe FilePath)+    maybeLogPath =+      case useLogFile of+         Nothing                 -> return Nothing+         Just (mkLogFileName, _) -> do+           let logFileName = mkLogFileName (packageId pkg)+               logDir      = takeDirectory logFileName+           unless (null logDir) $ createDirectoryIfMissing True logDir+           logFileExists <- doesFileExist logFileName+           when logFileExists $ removeFile logFileName+           return (Just logFileName)++    setup cmd flags mLogPath =       Exception.bracket-              (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))-              (\mHandle -> case mHandle of-                           Just handle -> hClose handle-                           Nothing -> return ())-              (\logFileHandle ->-               setupWrapper verbosity-                 scriptOptions { useLoggingHandle = logFileHandle-                               , useWorkingDir    = workingDir }-                 (Just pkg)-                 cmd flags [])+      (maybe (return Nothing)+             (\path -> Just `fmap` openFile path AppendMode) mLogPath)+      (maybe (return ()) hClose)+      (\logFileHandle ->+        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+      -- look for our own executable file and re-exec ourselves using a helper+      -- program like sudo to elevate priviledges:+      self <- getExecutablePath       weExist <- doesFileExist self       if weExist         then inDir workingDir $@@ -1153,7 +1400,6 @@ -- 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)@@ -1161,11 +1407,6 @@   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   -- ------------------------------------------------------------@@ -1175,10 +1416,11 @@ withWin32SelfUpgrade :: Verbosity                      -> ConfigFlags                      -> CompilerId+                     -> Platform                      -> PackageDescription                      -> IO a -> IO a-withWin32SelfUpgrade _ _ _ _ action | buildOS /= Windows = action-withWin32SelfUpgrade verbosity configFlags compid pkg action = do+withWin32SelfUpgrade _ _ _ _ _ action | buildOS /= Windows = action+withWin32SelfUpgrade verbosity configFlags compid platform pkg action = do    defaultDirs <- InstallDirs.defaultInstallDirs                    compFlavor@@ -1206,7 +1448,8 @@         templateDirs   = InstallDirs.combineInstallDirs fromFlagOrDefault                            defaultDirs (configInstallDirs configFlags)         absoluteDirs   = InstallDirs.absoluteInstallDirs-                           pkgid compid InstallDirs.NoCopyDest templateDirs+                           pkgid compid InstallDirs.NoCopyDest+                           platform templateDirs         substTemplate  = InstallDirs.fromPathTemplate                        . InstallDirs.substPathTemplate env-          where env = InstallDirs.initialPathTemplateEnv pkgid compid+          where env = InstallDirs.initialPathTemplateEnv pkgid compid platform
cabal/cabal-install/Distribution/Client/InstallPlan.hs view
@@ -47,7 +47,9 @@  import Distribution.Client.Types          ( SourcePackage(packageDescription), ConfiguredPackage(..)-         , InstalledPackage, BuildFailure, BuildSuccess, enableStanzas )+         , ReadyPackage(..), readyPackageToConfiguredPackage+         , InstalledPackage, BuildFailure, BuildSuccess(..), enableStanzas+         , InstalledPackage (..) ) import Distribution.Package          ( PackageIdentifier(..), PackageName(..), Package(..), packageName          , PackageFixedDeps(..), Dependency(..) )@@ -73,11 +75,12 @@          ( duplicates, duplicatesBy, mergeBy, MergeResult(..) ) import Distribution.Simple.Utils          ( comparing, intercalate )+import qualified Distribution.InstalledPackageInfo as Installed  import Data.List          ( sort, sortBy ) import Data.Maybe-         ( fromMaybe )+         ( fromMaybe, maybeToList ) import qualified Data.Graph as Graph import Data.Graph (Graph) import Control.Exception@@ -127,9 +130,11 @@  data PlanPackage = PreExisting InstalledPackage                  | Configured  ConfiguredPackage-                 | Processing  ConfiguredPackage-                 | Installed   ConfiguredPackage BuildSuccess+                 | Processing  ReadyPackage+                 | Installed   ReadyPackage BuildSuccess                  | Failed      ConfiguredPackage BuildFailure+                   -- ^ NB: packages in the Failed state can be *either* Ready+                   -- or Configured.  instance Package PlanPackage where   packageId (PreExisting pkg) = packageId pkg@@ -204,7 +209,7 @@ -- configured state and have all their dependencies installed already. -- The plan is complete if the result is @[]@. ---ready :: InstallPlan -> [ConfiguredPackage]+ready :: InstallPlan -> [ReadyPackage] ready plan = assert check readyPackages   where     check = if null readyPackages && null processingPackages@@ -212,23 +217,37 @@               else True     configuredPackages = [ pkg | Configured pkg <- toList plan ]     processingPackages = [ pkg | Processing pkg <- toList plan]-    readyPackages = filter (all isInstalled . depends) configuredPackages-    isInstalled pkg =-      case PackageIndex.lookupPackageId (planIndex plan) pkg of-        Just (Configured  _) -> False-        Just (Processing  _) -> False-        Just (Failed    _ _) -> internalError depOnFailed-        Just (PreExisting _) -> True-        Just (Installed _ _) -> True-        Nothing              -> internalError incomplete++    readyPackages :: [ReadyPackage]+    readyPackages =+      [ ReadyPackage srcPkg flags stanzas deps+      | pkg@(ConfiguredPackage srcPkg flags stanzas _) <- configuredPackages+        -- select only the package that have all of their deps installed:+      , deps <- maybeToList (hasAllInstalledDeps pkg)+      ]++    hasAllInstalledDeps :: ConfiguredPackage -> Maybe [Installed.InstalledPackageInfo]+    hasAllInstalledDeps = mapM isInstalledDep . depends++    isInstalledDep :: PackageIdentifier -> Maybe Installed.InstalledPackageInfo+    isInstalledDep pkgid =+      case PackageIndex.lookupPackageId (planIndex plan) pkgid of+        Just (Configured  _)                            -> Nothing+        Just (Processing  _)                            -> Nothing+        Just (Failed    _ _)                            -> internalError depOnFailed+        Just (PreExisting (InstalledPackage instPkg _)) -> Just instPkg+        Just (Installed _ (BuildOk _ _ (Just instPkg))) -> Just instPkg+        Just (Installed _ (BuildOk _ _ Nothing))        -> internalError depOnNonLib+        Nothing                                         -> internalError incomplete     incomplete  = "install plan is not closed"     depOnFailed = "configured package depends on failed package"+    depOnNonLib = "configured package depends on a non-library package"  -- | Marks packages in the graph as currently processing (e.g. building). -- -- * The package must exist in the graph and be in the configured state. ---processing :: [ConfiguredPackage] -> InstallPlan -> InstallPlan+processing :: [ReadyPackage] -> InstallPlan -> InstallPlan processing pkgs plan = assert (invariant plan') plan'   where     plan' = plan {@@ -270,7 +289,7 @@                }     pkg      = lookupProcessingPackage plan pkgid     failures = PackageIndex.fromList-             $ Failed pkg buildResult+             $ Failed (readyPackageToConfiguredPackage pkg) buildResult              : [ Failed pkg' buildResult'                | Just pkg' <- map checkConfiguredPackage                             $ packagesThatDependOn plan pkgid ]@@ -287,7 +306,7 @@ -- | Lookup a package that we expect to be in the processing state. -- lookupProcessingPackage :: InstallPlan-                        -> PackageIdentifier -> ConfiguredPackage+                        -> PackageIdentifier -> ReadyPackage lookupProcessingPackage plan pkgid =   case PackageIndex.lookupPackageId (planIndex plan) pkgid of     Just (Processing pkg) -> pkg@@ -330,7 +349,7 @@  showPlanProblem (PackageMissingDeps pkg missingDeps) =      "Package " ++ display (packageId pkg)-  ++ " depends on the following packages which are missing from the plan "+  ++ " depends on the following packages which are missing from the plan: "   ++ intercalate ", " (map display missingDeps)  showPlanProblem (PackageCycle cycleGroup) =@@ -409,7 +428,7 @@ -- 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+-- versions are ok so long as they are not both in the transitive 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
cabal/cabal-install/Distribution/Client/InstallSymlink.hs view
@@ -1,9 +1,4 @@-{-# 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@@ -40,7 +35,7 @@ #else  import Distribution.Client.Types-         ( SourcePackage(..), ConfiguredPackage(..), enableStanzas )+         ( SourcePackage(..), ReadyPackage(..), enableStanzas ) import Distribution.Client.Setup          ( InstallFlags(installSymlinkBinDir) ) import qualified Distribution.Client.InstallPlan as InstallPlan@@ -132,12 +127,12 @@       , exe <- PackageDescription.executables pkg       , PackageDescription.buildable (PackageDescription.buildInfo exe) ] -    pkgDescription :: ConfiguredPackage -> PackageDescription-    pkgDescription (ConfiguredPackage (SourcePackage _ pkg _) flags stanzas _) =+    pkgDescription :: ReadyPackage -> PackageDescription+    pkgDescription (ReadyPackage (SourcePackage _ pkg _ _) flags stanzas _) =       case finalizePackageDescription flags              (const True)              platform compilerId [] (enableStanzas stanzas pkg) of-        Left _ -> error "finalizePackageDescription ConfiguredPackage failed"+        Left _ -> error "finalizePackageDescription ReadyPackage failed"         Right (desc, _) -> desc      -- This is sadly rather complicated. We're kind of re-doing part of the@@ -152,12 +147,12 @@                            defaultDirs (configInstallDirs configFlags)           absoluteDirs = InstallDirs.absoluteInstallDirs                            (packageId pkg) compilerId InstallDirs.NoCopyDest-                           templateDirs+                           platform templateDirs       canonicalizePath (InstallDirs.bindir absoluteDirs)      substTemplate pkgid = InstallDirs.fromPathTemplate                         . InstallDirs.substPathTemplate env-      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId+      where env = InstallDirs.initialPathTemplateEnv pkgid compilerId platform      fromFlagTemplate = fromFlagOrDefault (InstallDirs.toPathTemplate "")     prefixTemplate   = fromFlagTemplate (configProgPrefix configFlags)@@ -234,6 +229,6 @@       bs = splitPath b       commonLen = length $ takeWhile id $ zipWith (==) as bs    in joinPath $ [ ".." | _  <- drop commonLen as ]-              ++ [  b'  | b' <- drop commonLen bs ]+              ++ drop commonLen bs  #endif
cabal/cabal-install/Distribution/Client/JobControl.hs view
@@ -27,8 +27,9 @@   ) where  import Control.Monad-import Control.Concurrent-import Control.Exception+import Control.Concurrent hiding (QSem, newQSem, waitQSem, signalQSem)+import Control.Exception (SomeException, bracket_, mask, throw, try)+import Distribution.Client.Compat.Semaphore  data JobControl m a = JobControl {        spawnJob    :: m a -> m (),@@ -68,7 +69,6 @@     collect :: MVar (Either SomeException a) -> IO a     collect resultVar =       takeMVar resultVar >>= either throw return-  data JobLimit = JobLimit QSem
cabal/cabal-install/Distribution/Client/List.hs view
@@ -70,17 +70,16 @@          ( doesDirectoryExist )  --- |Show information about packages-list :: Verbosity-     -> PackageDBStack-     -> [Repo]-     -> Compiler-     -> ProgramConfiguration-     -> ListFlags-     -> [String]-     -> IO ()-list verbosity packageDBs repos comp conf listFlags pats = do-+-- | Return a list of packages matching given search strings.+getPkgList :: Verbosity+           -> PackageDBStack+           -> [Repo]+           -> Compiler+           -> ProgramConfiguration+           -> ListFlags+           -> [String]+           -> IO [PackageDisplayInfo]+getPkgList verbosity packageDBs repos comp conf listFlags pats = do     installedPkgIndex <- getInstalledPackages verbosity comp packageDBs conf     sourcePkgDb       <- getSourcePackages    verbosity repos     let sourcePkgIndex = packageIndex sourcePkgDb@@ -104,7 +103,27 @@                   , not onlyInstalled || not (null installedPkgs)                   , let pref        = prefs pkgname                         selectedPkg = latestWithPref pref sourcePkgs ]+    return matches+  where+    onlyInstalled = fromFlag (listInstalled listFlags)+    matchingPackages search index =+      [ pkg+      | pat <- pats+      , pkg <- search index pat ] ++-- | Show information about packages.+list :: Verbosity+     -> PackageDBStack+     -> [Repo]+     -> Compiler+     -> ProgramConfiguration+     -> ListFlags+     -> [String]+     -> IO ()+list verbosity packageDBs repos comp conf listFlags pats = do+    matches <- getPkgList verbosity packageDBs repos comp conf listFlags pats+     if simpleOutput       then putStr $ unlines              [ display (pkgName pkg) ++ " " ++ display version@@ -124,11 +143,6 @@     onlyInstalled = fromFlag (listInstalled listFlags)     simpleOutput  = fromFlag (listSimpleOutput listFlags) -    matchingPackages search index =-      [ pkg-      | pat <- pats-      , pkg <- search index pat ]- info :: Verbosity      -> PackageDBStack      -> [Repo]@@ -138,6 +152,9 @@      -> InfoFlags      -> [UserTarget]      -> IO ()+info verbosity _ _ _ _ _ _ [] =+    notice verbosity "No packages requested. Nothing to do."+ info verbosity packageDBs repos comp conf      globalFlags _listFlags userTargets = do @@ -184,9 +201,8 @@                                  sourcePkgs  selectedSourcePkg'                                  showPkgVersion       where-        pref           = prefs name-        installedPkgs  = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)-        sourcePkgs     =                         PackageIndex.lookupPackageName sourcePkgIndex name+        (pref, installedPkgs, sourcePkgs) =+          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex          selectedInstalledPkgs = InstalledPackageIndex.lookupDependency installedPkgIndex                                     (Dependency name verConstraint)@@ -205,10 +221,22 @@                                  selectedPkg True       where         name          = packageName pkg-        pref          = prefs name-        installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)-        sourcePkgs    =                         PackageIndex.lookupPackageName sourcePkgIndex name         selectedPkg   = Just pkg+        (pref, installedPkgs, sourcePkgs) =+          sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex++sourcePkgsInfo ::+  (PackageName -> VersionRange)+  -> PackageName+  -> InstalledPackageIndex.PackageIndex+  -> PackageIndex.PackageIndex SourcePackage+  -> (VersionRange, [Installed.InstalledPackageInfo], [SourcePackage])+sourcePkgsInfo prefs name installedPkgIndex sourcePkgIndex =+  (pref, installedPkgs, sourcePkgs)+  where+    pref          = prefs name+    installedPkgs = concatMap snd (InstalledPackageIndex.lookupPackageName installedPkgIndex name)+    sourcePkgs    =                         PackageIndex.lookupPackageName sourcePkgIndex name   -- | The info that we can display for each package. It is information per
− cabal/cabal-install/Distribution/Client/PackageEnvironment.hs 
@@ -1,380 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.PackageEnvironment--- Maintainer  :  cabal-devel@haskell.org--- Portability :  portable------ Utilities for working with the package environment file. Patterned after--- Distribution.Client.Config.--------------------------------------------------------------------------------module Distribution.Client.PackageEnvironment (-    PackageEnvironment(..)-  , loadOrCreatePackageEnvironment-  , tryLoadPackageEnvironment-  , readPackageEnvironmentFile-  , showPackageEnvironment-  , showPackageEnvironmentWithComments--  , basePackageEnvironment-  , initialPackageEnvironment-  , commentPackageEnvironment-  , defaultPackageEnvironmentFileName-  ) where--import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig,-                                         initialSavedConfig, loadConfig,-                                         configFieldDescriptions,-                                         installDirsFields, defaultCompiler )-import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )-import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)-                                       , InstallFlags(..) )-import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)-                                         , showCompilerId )-import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate,-                                         toPathTemplate )-import Distribution.Simple.Setup       ( Flag(..), ConfigFlags(..),-                                         fromFlagOrDefault, toFlag )-import Distribution.Simple.Utils       ( die, notice, warn, lowercase )-import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..),-                                         commaListField,-                                         liftField, lineNo, locatedErrorMsg,-                                         parseFilePathQ, readFields,-                                         showPWarning, simpleField, warning )-import Distribution.Verbosity          ( Verbosity, normal )-import Control.Monad                   ( foldM, when )-import Data.List                       ( partition )-import Data.Monoid                     ( Monoid(..) )-import Distribution.Compat.Exception   ( catchIO )-import System.Directory                ( renameFile )-import System.FilePath                 ( (<.>), (</>) )-import System.IO.Error                 ( isDoesNotExistError )-import Text.PrettyPrint                ( ($+$) )--import qualified Text.PrettyPrint          as Disp-import qualified Distribution.Compat.ReadP as Parse-import qualified Distribution.ParseUtils   as ParseUtils ( Field(..) )-import qualified Distribution.Text         as Text------- * Configuration saved in the package environment file------- TODO: would be nice to remove duplication between D.C.PackageEnvironment and--- D.C.Config.-data PackageEnvironment = PackageEnvironment {-  pkgEnvInherit       :: Flag FilePath,-  pkgEnvSavedConfig   :: SavedConfig-}--instance Monoid PackageEnvironment where-  mempty = PackageEnvironment {-    pkgEnvInherit       = mempty,-    pkgEnvSavedConfig   = mempty-    }--  mappend a b = PackageEnvironment {-    pkgEnvInherit       = combine pkgEnvInherit,-    pkgEnvSavedConfig   = combine pkgEnvSavedConfig-    }-    where-      combine f = f a `mappend` f b--defaultPackageEnvironmentFileName :: FilePath-defaultPackageEnvironmentFileName = "pkgenv"---- | Defaults common to 'initialPackageEnvironment' and--- 'commentPackageEnvironment'.-commonPackageEnvironmentConfig :: FilePath -> SavedConfig-commonPackageEnvironmentConfig pkgEnvDir =-  mempty {-    savedConfigureFlags = mempty {-       configUserInstall = toFlag False,-       configInstallDirs = sandboxInstallDirs-       },-    savedUserInstallDirs   = sandboxInstallDirs,-    savedGlobalInstallDirs = sandboxInstallDirs,-    savedGlobalFlags = mempty {-      globalLogsDir = toFlag $ pkgEnvDir </> "logs",-      -- Is this right? cabal-dev uses the global world file.-      globalWorldFile = toFlag $ pkgEnvDir </> "world"-      }-    }-  where-    sandboxInstallDirs = mempty { prefix = toFlag (toPathTemplate pkgEnvDir) }---- | These are the absolute basic defaults, the fields that must be--- initialised. When we load the package environment from the file we layer the--- loaded values over these ones.-basePackageEnvironment :: FilePath -> PackageEnvironment-basePackageEnvironment pkgEnvDir = do-  let baseConf = commonPackageEnvironmentConfig pkgEnvDir in-    mempty {-      pkgEnvSavedConfig = baseConf {-         savedConfigureFlags = (savedConfigureFlags baseConf) {-            configHcFlavor    = toFlag defaultCompiler,-            configVerbosity   = toFlag normal-            }-         }-      }---- | Initial configuration that we write out to the package environment file if--- it does not exist. When the package environment gets loaded it gets layered--- on top of 'basePackageEnvironment'.-initialPackageEnvironment :: FilePath -> Compiler -> IO PackageEnvironment-initialPackageEnvironment pkgEnvDir compiler = do-  initialConf' <- initialSavedConfig-  let baseConf =  commonPackageEnvironmentConfig pkgEnvDir-  let initialConf = initialConf' `mappend` baseConf-  return $ mempty {-    pkgEnvSavedConfig = initialConf {-       savedGlobalFlags = (savedGlobalFlags initialConf) {-          globalLocalRepos = [pkgEnvDir </> "packages"]-          },-       savedConfigureFlags = setPackageDB pkgEnvDir compiler-                             (savedConfigureFlags initialConf),-       savedInstallFlags = (savedInstallFlags initialConf) {-         installSummaryFile = [toPathTemplate (pkgEnvDir </>-                                               "logs" </> "build.log")]-         }-       }-    }---- | Use the package DB location specific for this compiler.-setPackageDB :: FilePath -> Compiler -> ConfigFlags -> ConfigFlags-setPackageDB pkgEnvDir compiler configFlags =-  configFlags {-    configPackageDBs = [Just (SpecificPackageDB $ pkgEnvDir-                              </> (showCompilerId compiler ++-                                   "-packages.conf.d"))]-    }---- | Default values that get used if no value is given. Used here to include in--- comments when we write out the initial package environment.-commentPackageEnvironment :: FilePath -> IO PackageEnvironment-commentPackageEnvironment pkgEnvDir = do-  commentConf  <- commentSavedConfig-  let baseConf =  commonPackageEnvironmentConfig pkgEnvDir-  return $ mempty {-    pkgEnvSavedConfig = commentConf `mappend` baseConf-    }---- | Given a package environment loaded from a file, layer it on top of the base--- package environment.-addBasePkgEnv :: Verbosity -> FilePath -> PackageEnvironment-                 -> IO PackageEnvironment-addBasePkgEnv verbosity pkgEnvDir extra = do-  let base     = basePackageEnvironment pkgEnvDir-      baseConf = pkgEnvSavedConfig base-  -- Does this package environment inherit from some config file?-  case pkgEnvInherit extra of-    NoFlag          ->-      return $ base `mappend` extra-    (Flag confPath) -> do-      conf <- loadConfig verbosity (Flag confPath) NoFlag-      let conf' = baseConf `mappend` conf `mappend` (pkgEnvSavedConfig extra)-      return $ extra { pkgEnvSavedConfig = conf' }---- | Try to load a package environment file, exiting with error if it doesn't--- exist.-tryLoadPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment-tryLoadPackageEnvironment verbosity pkgEnvDir = do-  let path = pkgEnvDir </> defaultPackageEnvironmentFileName-  minp <- readPackageEnvironmentFile mempty path-  pkgEnv <- case minp of-    Nothing -> die $-      "The package environment file '" ++ path ++ "' doesn't exist"-    Just (ParseOk warns parseResult) -> do-      when (not $ null warns) $ warn verbosity $-        unlines (map (showPWarning path) warns)-      return parseResult-    Just (ParseFailed err) -> do-      let (line, msg) = locatedErrorMsg err-      die $ "Error parsing package environment file " ++ path-        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg-  addBasePkgEnv verbosity pkgEnvDir pkgEnv---- | Load a package environment file, creating one if it doesn't exist. Note--- that the path parameter should be a name of an existing directory.-loadOrCreatePackageEnvironment :: Verbosity -> FilePath-                                  -> ConfigFlags -> Compiler-                                  -> IO PackageEnvironment-loadOrCreatePackageEnvironment verbosity pkgEnvDir configFlags compiler = do-  let path = pkgEnvDir </> defaultPackageEnvironmentFileName-  minp <- readPackageEnvironmentFile mempty path-  pkgEnv <- case minp of-    Nothing -> do-      notice verbosity $ "Writing default package environment to " ++ path-      commentPkgEnv <- commentPackageEnvironment pkgEnvDir-      initialPkgEnv <- initialPackageEnvironment pkgEnvDir compiler-      let pkgEnv = updateConfigFlags initialPkgEnv-                   (\flags -> flags `mappend` configFlags)-      writePackageEnvironmentFile path commentPkgEnv pkgEnv-      return initialPkgEnv-    Just (ParseOk warns parseResult) -> do-      when (not $ null warns) $ warn verbosity $-        unlines (map (showPWarning path) warns)--      -- Update the package environment file in case the user has changed some-      -- settings via the command-line (otherwise 'configure -w compiler-B' will-      -- fail for a sandbox already configured to use compiler-A).-      notice verbosity $ "Writing the updated package environment to " ++ path-      commentPkgEnv <- commentPackageEnvironment pkgEnvDir-      let pkgEnv = updateConfigFlags parseResult-                   (\flags ->-                     setPackageDB pkgEnvDir compiler flags-                     `mappend` configFlags)-      writePackageEnvironmentFile path commentPkgEnv pkgEnv--      return pkgEnv-    Just (ParseFailed err) -> do-      let (line, msg) = locatedErrorMsg err-      warn verbosity $-        "Error parsing package environment file " ++ path-        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg-      warn verbosity $ "Using default package environment."-      initialPackageEnvironment pkgEnvDir compiler-  addBasePkgEnv verbosity pkgEnvDir pkgEnv--  where-    updateConfigFlags :: PackageEnvironment -> (ConfigFlags -> ConfigFlags)-                         -> PackageEnvironment-    updateConfigFlags pkgEnv f =-      let pkgEnvConfig      = pkgEnvSavedConfig pkgEnv-          pkgEnvConfigFlags = savedConfigureFlags pkgEnvConfig-      in pkgEnv {-        pkgEnvSavedConfig = pkgEnvConfig {-           savedConfigureFlags = f pkgEnvConfigFlags-           }-        }---- | Descriptions of all fields in the package environment file.-pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]-pkgEnvFieldDescrs = [-  simpleField "inherit"-    (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)-    pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })--    -- FIXME: Should we make these fields part of ~/.cabal/config ?-  , commaListField "constraints"-    Text.disp Text.parse-    (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)-    (\v pkgEnv -> updateConfigureExFlags pkgEnv-                  (\flags -> flags { configExConstraints = v }))--  , commaListField "preferences"-    Text.disp Text.parse-    (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)-    (\v pkgEnv -> updateConfigureExFlags pkgEnv-                  (\flags -> flags { configPreferences = v }))-  ]-  ++ map toPkgEnv configFieldDescriptions'-  where-    optional = Parse.option mempty . fmap toFlag--    configFieldDescriptions' :: [FieldDescr SavedConfig]-    configFieldDescriptions' = filter-      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")-      configFieldDescriptions--    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment-    toPkgEnv fieldDescr =-      liftField pkgEnvSavedConfig-      (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})-      fieldDescr--    updateConfigureExFlags :: PackageEnvironment-                              -> (ConfigExFlags -> ConfigExFlags)-                              -> PackageEnvironment-    updateConfigureExFlags pkgEnv f = pkgEnv {-      pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {-         savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig-                                 $ pkgEnv-         }-      }---- | Read the package environment file.-readPackageEnvironmentFile :: PackageEnvironment -> FilePath-                              -> IO (Maybe (ParseResult PackageEnvironment))-readPackageEnvironmentFile initial file =-  handleNotExists $-  fmap (Just . parsePackageEnvironment initial) (readFile file)-  where-    handleNotExists action = catchIO action $ \ioe ->-      if isDoesNotExistError ioe-        then return Nothing-        else ioError ioe---- | Parse the package environment file.-parsePackageEnvironment :: PackageEnvironment -> String-                           -> ParseResult PackageEnvironment-parsePackageEnvironment initial str = do-  fields <- readFields str-  let (knownSections, others) = partition isKnownSection fields-  pkgEnv <- parse others-  let config       = pkgEnvSavedConfig pkgEnv-      installDirs0 = savedUserInstallDirs config-  -- 'install-dirs' is the only section that we care about.-  installDirs <- foldM parseSection installDirs0 knownSections-  return pkgEnv {-    pkgEnvSavedConfig = config {-       savedUserInstallDirs   = installDirs,-       savedGlobalInstallDirs = installDirs-       }-    }--  where-    isKnownSection :: ParseUtils.Field -> Bool-    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True-    isKnownSection _                                         = False--    parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment-    parse = parseFields pkgEnvFieldDescrs initial--    parseSection :: InstallDirs (Flag PathTemplate)-                    -> ParseUtils.Field-                    -> ParseResult (InstallDirs (Flag PathTemplate))-    parseSection accum (ParseUtils.Section _ "install-dirs" name fs)-      | name' == "" = do accum' <- parseFields installDirsFields accum fs-                         return accum'-      | otherwise   = do warning "The install-dirs section should be unnamed"-                         return accum-      where name' = lowercase name-    parseSection accum f = do-      warning $ "Unrecognized stanza on line " ++ show (lineNo f)-      return accum---- | Write out the package environment file.-writePackageEnvironmentFile :: FilePath -> PackageEnvironment-                               -> PackageEnvironment -> IO ()-writePackageEnvironmentFile path comments pkgEnv = do-  let tmpPath = (path <.> "tmp")-  writeFile tmpPath $ explanation-    ++ showPackageEnvironmentWithComments comments pkgEnv ++ "\n"-  renameFile tmpPath path-  where-    explanation = unlines-      ["-- This is a Cabal package environment file."-      ,""-      ,"-- 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."-      ,"",""-      ]---- | Pretty-print the package environment data.-showPackageEnvironment :: PackageEnvironment -> String-showPackageEnvironment = showPackageEnvironmentWithComments mempty--showPackageEnvironmentWithComments :: PackageEnvironment -> PackageEnvironment-                                      -> String-showPackageEnvironmentWithComments defPkgEnv pkgEnv = Disp.render $-      ppFields pkgEnvFieldDescrs defPkgEnv pkgEnv-  $+$ Disp.text ""-  $+$ ppSection "install-dirs" "" installDirsFields-                (field defPkgEnv) (field pkgEnv)-  where-    field = savedUserInstallDirs . pkgEnvSavedConfig
cabal/cabal-install/Distribution/Client/PackageIndex.hs view
@@ -63,7 +63,7 @@ import Data.Array ((!)) import Data.List (groupBy, sortBy, nub, isInfixOf) import Data.Monoid (Monoid(..))-import Data.Maybe (isJust, isNothing, fromMaybe)+import Data.Maybe (isJust, isNothing, fromMaybe, catMaybes)  import Distribution.Package          ( PackageName(..), PackageIdentifier(..)@@ -89,8 +89,11 @@    deriving (Show, Read) +instance Functor PackageIndex where+  fmap f (PackageIndex m) = PackageIndex (fmap (map f) m)+ instance Package pkg => Monoid (PackageIndex pkg) where-  mempty  = PackageIndex (Map.empty)+  mempty  = PackageIndex Map.empty   mappend = merge   --save one mappend with empty in the common case:   mconcat [] = mempty@@ -334,9 +337,9 @@                          , isNothing (lookupPackageId index pkg') ]   , not (null missing) ] --- | Tries to take the transative closure of the package dependencies.+-- | Tries to take the transitive closure of the package dependencies. ----- If the transative closure is complete then it returns that subset of the+-- If the transitive closure is complete then it returns that subset of the -- index. Otherwise it returns the broken packages as in 'brokenPackages'. -- -- * Note that if the result is @Right []@ it is because at least one of@@ -360,7 +363,7 @@           where completed' = insert pkg completed                 pkgids'    = depends pkg ++ pkgids --- | Takes the transative closure of the packages reverse dependencies.+-- | Takes the transitive closure of the packages reverse dependencies. -- -- * The given 'PackageIdentifier's must be in the index. --@@ -466,9 +469,8 @@                     PackageIdentifier -> Maybe Graph.Vertex) dependencyGraph index = (graph, vertexToPkg, pkgIdToVertex)   where-    graph = Array.listArray bounds-              [ [ v | Just v <- map pkgIdToVertex (depends pkg) ]-              | pkg <- pkgs ]+    graph = Array.listArray bounds $+            map (catMaybes . map pkgIdToVertex . depends) pkgs     vertexToPkg vertex = pkgTable ! vertex     pkgIdToVertex = binarySearch 0 topBound
cabal/cabal-install/Distribution/Client/ParseUtils.hs view
@@ -19,11 +19,11 @@ import Text.PrettyPrint ( (<>), (<+>), ($$) ) import qualified Data.Map as Map import qualified Text.PrettyPrint as Disp-         ( Doc, text, colon, vcat, isEmpty, nest )+         ( Doc, text, colon, vcat, empty, isEmpty, nest )  --FIXME: replace this with something better parseFields :: [FieldDescr a] -> a -> [ParseUtils.Field] -> ParseResult a-parseFields fields initial = foldM setField initial+parseFields fields = foldM setField   where     fieldMap = Map.fromList       [ (name, f) | f@(FieldDescr name _ _) <- fields ]@@ -37,19 +37,21 @@       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.+-- | This is a customised version of the functions from Distribution.ParseUtils+-- that also optionally print 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)+ppFields :: [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc+ppFields fields def cur = Disp.vcat [ ppField name (fmap 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+ppField :: String -> (Maybe Disp.Doc) -> Disp.Doc -> Disp.Doc+ppField name mdef cur+  | Disp.isEmpty cur = maybe Disp.empty+                       (\def -> Disp.text "--" <+> Disp.text name+                                <> Disp.colon <+> def) mdef+  | otherwise        = Disp.text name <> Disp.colon <+> cur -ppSection :: String -> String -> [FieldDescr a] -> a -> a -> Disp.Doc+ppSection :: String -> String -> [FieldDescr a] -> (Maybe a) -> a -> Disp.Doc ppSection name arg fields def cur =      Disp.text name <+> Disp.text arg   $$ Disp.nest 2 (ppFields fields def cur)
+ cabal/cabal-install/Distribution/Client/Run.hs view
@@ -0,0 +1,64 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Run+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Implementation of the 'run' command.+-----------------------------------------------------------------------------++module Distribution.Client.Run ( run, splitRunArgs )+       where++import Distribution.Client.Utils             (tryCanonicalizePath)++import Distribution.PackageDescription       (Executable (..),+                                              PackageDescription (..))+import Distribution.Simple.Build.PathsModule (pkgPathEnvVar)+import Distribution.Simple.BuildPaths        (exeExtension)+import Distribution.Simple.LocalBuildInfo    (LocalBuildInfo (..))+import Distribution.Simple.Utils             (die, rawSystemExitWithEnv)+import Distribution.Verbosity                (Verbosity)++import Data.Functor                          ((<$>))+import Data.List                             (find)+import System.Directory                      (getCurrentDirectory)+import Distribution.Compat.Environment       (getEnvironment)+import System.FilePath                       ((<.>), (</>))+++-- | Return the executable to run and any extra arguments that should be+-- forwarded to it.+splitRunArgs :: LocalBuildInfo -> [String] -> IO (Executable, [String])+splitRunArgs lbi args =+  case exes of+    []    -> die "Couldn't find any executables."+    [exe] -> case args of+      []                        -> return (exe, [])+      (x:xs) | x == exeName exe -> return (exe, xs)+             | otherwise        -> return (exe, args)+    _     -> case args of+      []     -> die $ "This package contains multiple executables. "+                ++ "You must pass the executable name as the first argument "+                ++ "to 'cabal run'."+      (x:xs) -> case find (\exe -> exeName exe == x) exes of+        Nothing  -> die $ "No executable named '" ++ x ++ "'."+        Just exe -> return (exe, xs)+  where+    pkg_descr = localPkgDescr lbi+    exes      = executables pkg_descr+++-- | Run a given executable.+run :: Verbosity -> LocalBuildInfo -> Executable -> [String] -> IO ()+run verbosity lbi exe exeArgs = do+  curDir <- getCurrentDirectory+  let buildPref     = buildDir lbi+      pkg_descr     = localPkgDescr lbi+      dataDirEnvVar = (pkgPathEnvVar pkg_descr "datadir",+                       curDir </> dataDir pkg_descr)++  path <- tryCanonicalizePath $+          buildPref </> exeName exe </> (exeName exe <.> exeExtension)+  env  <- (dataDirEnvVar:) <$> getEnvironment+  rawSystemExitWithEnv verbosity path exeArgs env
cabal/cabal-install/Distribution/Client/Sandbox.hs view
@@ -8,208 +8,747 @@ -----------------------------------------------------------------------------  module Distribution.Client.Sandbox (+    sandboxInit,+    sandboxDelete,+    sandboxAddSource,+    sandboxAddSourceSnapshot,+    sandboxDeleteSource,+    sandboxListSources,+    sandboxHcPkg,     dumpPackageEnvironment,+    withSandboxBinDirOnSearchPath, -    sandboxAddSource,-    sandboxConfigure,-    sandboxBuild,-    sandboxInstall+    getSandboxConfigFilePath,+    loadConfigOrSandboxConfig,+    initPackageDBIfNeeded,+    maybeWithSandboxDirOnSearchPath,++    WereDepsReinstalled(..),+    reinstallAddSourceDeps,+    maybeReinstallAddSourceDeps,++    SandboxPackageInfo(..),+    maybeWithSandboxPackageInfo,++    tryGetIndexFilePath,+    sandboxBuildDir,+    getInstalledPackagesInSandbox,+    updateSandboxConfigFileFlag,++    -- FIXME: move somewhere else+    configPackageDB', configCompilerAux'   ) where  import Distribution.Client.Setup-  ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), GlobalFlags(..)-  , InstallFlags(..), globalRepos-  , defaultInstallFlags, defaultConfigExFlags, defaultSandboxLocation-  , installCommand )+  ( SandboxFlags(..), ConfigFlags(..), ConfigExFlags(..), InstallFlags(..)+  , GlobalFlags(..), defaultConfigExFlags, defaultInstallFlags+  , defaultSandboxLocation, globalRepos )+import Distribution.Client.Sandbox.Timestamp  ( listModifiedDeps+                                              , maybeAddCompilerTimestampRecord+                                              , withAddTimestamps+                                              , withRemoveTimestamps ) import Distribution.Client.Config             ( SavedConfig(..), loadConfig )-import Distribution.Client.Configure          ( configure )-import Distribution.Client.Install            ( install )-import Distribution.Client.PackageEnvironment-  ( PackageEnvironment(..)-  , loadOrCreatePackageEnvironment, tryLoadPackageEnvironment-  , commentPackageEnvironment-  , showPackageEnvironmentWithComments, readPackageEnvironmentFile-  , basePackageEnvironment, defaultPackageEnvironmentFileName )-import Distribution.Client.SetupWrapper-  ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )-import Distribution.Client.Targets            ( readUserTargets )-import Distribution.Simple.Compiler           ( Compiler-                                              , PackageDB(..), PackageDBStack )-import Distribution.Simple.Configure          ( configCompilerAux-                                              , interpretPackageDbFlags )-import Distribution.Simple.Program            ( ProgramConfiguration-                                              , defaultProgramConfiguration )-import Distribution.Simple.Setup              ( Flag(..), toFlag-                                              , BuildFlags(..), HaddockFlags(..)-                                              , buildCommand, fromFlagOrDefault )-import Distribution.Simple.Utils              ( die, notice+import Distribution.Client.Dependency         ( foldProgress )+import Distribution.Client.IndexUtils         ( BuildTreeRefType(..) )+import Distribution.Client.Install            ( InstallArgs,+                                                makeInstallContext,+                                                makeInstallPlan,+                                                processInstallPlan )+import Distribution.Client.Sandbox.PackageEnvironment+  ( PackageEnvironment(..), IncludeComments(..), PackageEnvironmentType(..)+  , createPackageEnvironmentFile, classifyPackageEnvironment+  , tryLoadSandboxPackageEnvironmentFile, loadUserConfig+  , commentPackageEnvironment, showPackageEnvironmentWithComments+  , sandboxPackageEnvironmentFile, userPackageEnvironmentFile )+import Distribution.Client.Sandbox.Types      ( SandboxPackageInfo(..)+                                              , UseSandbox(..) )+import Distribution.Client.Types              ( PackageLocation(..)+                                              , SourcePackage(..) )+import Distribution.Client.Utils              ( inDir, tryCanonicalizePath )+import Distribution.PackageDescription.Configuration+                                              ( flattenPackageDescription )+import Distribution.PackageDescription.Parse  ( readPackageDescription )+import Distribution.Simple.Compiler           ( Compiler(..), PackageDB(..)+                                              , PackageDBStack )+import Distribution.Simple.Configure          ( configCompilerAuxEx+                                              , interpretPackageDbFlags+                                              , getPackageDBContents )+import Distribution.Simple.PreProcess         ( knownSuffixHandlers )+import Distribution.Simple.Program            ( ProgramConfiguration )+import Distribution.Simple.Setup              ( Flag(..), HaddockFlags(..)+                                              , fromFlagOrDefault )+import Distribution.Simple.SrcDist            ( prepareTree )+import Distribution.Simple.Utils              ( die, debug, notice, info, warn+                                              , debugNoWrap, defaultPackageDesc+                                              , tryFindPackageDesc+                                              , intercalate, topHandlerWith                                               , createDirectoryIfMissingVerbose )-import Distribution.ParseUtils                ( ParseResult(..) )+import Distribution.Package                   ( Package(..) )+import Distribution.System                    ( Platform )+import Distribution.Text                      ( display ) import Distribution.Verbosity                 ( Verbosity, lessVerbose )-import qualified Distribution.Client.Index as Index-import qualified Distribution.Simple.Register as Register-import Control.Monad                          ( unless, when )-import Data.Monoid                            ( mappend, mempty )-import System.Directory                       ( canonicalizePath+import Distribution.Client.Compat.Environment ( lookupEnv, setEnv )+import Distribution.Client.Compat.FilePerms   ( setFileHidden )+import qualified Distribution.Client.Sandbox.Index as Index+import qualified Distribution.Simple.PackageIndex  as InstalledPackageIndex+import qualified Distribution.Simple.Register      as Register+import qualified Data.Map                          as M+import qualified Data.Set                          as S+import Control.Exception                      ( assert, bracket_ )+import Control.Monad                          ( forM, liftM2, unless, when )+import Data.Bits                              ( shiftL, shiftR, xor )+import Data.Char                              ( ord )+import Data.IORef                             ( newIORef, writeIORef, readIORef )+import Data.List                              ( delete, foldl' )+import Data.Maybe                             ( fromJust, fromMaybe )+import Data.Monoid                            ( mempty, mappend )+import Data.Word                              ( Word32 )+import Numeric                                ( showHex )+import System.Directory                       ( createDirectory                                               , doesDirectoryExist-                                              , doesFileExist )-import System.FilePath                        ( (</>) )+                                              , doesFileExist+                                              , getCurrentDirectory+                                              , removeDirectoryRecursive+                                              , removeFile+                                              , renameDirectory )+import System.FilePath                        ( (</>), getSearchPath+                                              , searchPathSeparator+                                              , takeDirectory )  --- | Given a 'SandboxFlags' record, return a canonical path to the--- sandbox. Exits with error if the sandbox directory does not exist or is not--- properly initialised.-getSandboxLocation :: Verbosity -> SandboxFlags -> IO FilePath-getSandboxLocation verbosity sandboxFlags = do-  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation-                    (sandboxLocation sandboxFlags)-  sandboxDir <- canonicalizePath sandboxDir'-  dirExists  <- doesDirectoryExist sandboxDir-  pkgEnvExists <- doesFileExist $-                  sandboxDir </> defaultPackageEnvironmentFileName-  unless (dirExists && pkgEnvExists) $-    die ("No sandbox exists at " ++ sandboxDir)-  notice verbosity $ "Using a sandbox located at " ++ sandboxDir-  return sandboxDir+--+-- * Constants+-- +-- | The name of the sandbox subdirectory where we keep snapshots of add-source+-- dependencies.+snapshotDirectoryName :: FilePath+snapshotDirectoryName = "snapshots"++-- | Non-standard build dir that is used for building add-source deps instead of+-- "dist". Fixes surprising behaviour in some cases (see issue #1281).+sandboxBuildDir :: FilePath -> FilePath+sandboxBuildDir sandboxDir = "dist/dist-sandbox-" ++ showHex sandboxDirHash ""+  where+    sandboxDirHash = jenkins sandboxDir++    -- See http://en.wikipedia.org/wiki/Jenkins_hash_function+    jenkins :: String -> Word32+    jenkins str = loop_finish $ foldl' loop 0 str+      where+        loop :: Word32 -> Char -> Word32+        loop hash key_i' = hash'''+          where+            key_i   = toEnum . ord $ key_i'+            hash'   = hash + key_i+            hash''  = hash' + (shiftL hash' 10)+            hash''' = hash'' `xor` (shiftR hash'' 6)++        loop_finish :: Word32 -> Word32+        loop_finish hash = hash'''+          where+            hash'   = hash + (shiftL hash 3)+            hash''  = hash' `xor` (shiftR hash' 11)+            hash''' = hash'' + (shiftL hash'' 15)++--+-- * Basic sandbox functions.+--++-- | If @--sandbox-config-file@ wasn't given on the command-line, set it to the+-- value of the @CABAL_SANDBOX_CONFIG@ environment variable, or else to+-- 'NoFlag'.+updateSandboxConfigFileFlag :: GlobalFlags -> IO GlobalFlags+updateSandboxConfigFileFlag globalFlags =+  case globalSandboxConfigFile globalFlags of+    Flag _ -> return globalFlags+    NoFlag -> do+      f' <- fmap (fromMaybe NoFlag . fmap Flag) . lookupEnv+            $ "CABAL_SANDBOX_CONFIG"+      return globalFlags { globalSandboxConfigFile = f' }++-- | Return the path to the sandbox config file - either the default or the one+-- specified with @--sandbox-config-file@.+getSandboxConfigFilePath :: GlobalFlags -> IO FilePath+getSandboxConfigFilePath globalFlags = do+  let sandboxConfigFileFlag = globalSandboxConfigFile globalFlags+  case sandboxConfigFileFlag of+    NoFlag -> do pkgEnvDir <- getCurrentDirectory+                 return (pkgEnvDir </> sandboxPackageEnvironmentFile)+    Flag path -> return path++-- | Load the @cabal.sandbox.config@ file (and possibly the optional+-- @cabal.config@). In addition to a @PackageEnvironment@, also return a+-- canonical path to the sandbox. Exit with error if the sandbox directory or+-- the package environment file do not exist.+tryLoadSandboxConfig :: Verbosity -> GlobalFlags+                        -> IO (FilePath, PackageEnvironment)+tryLoadSandboxConfig verbosity globalFlags = do+  path <- getSandboxConfigFilePath globalFlags+  tryLoadSandboxPackageEnvironmentFile verbosity path+    (globalConfigFile globalFlags)+ -- | Return the name of the package index file for this package environment.-getIndexFilePath :: PackageEnvironment -> IO FilePath-getIndexFilePath pkgEnv = do-  let paths = globalLocalRepos . savedGlobalFlags . pkgEnvSavedConfig $ pkgEnv+tryGetIndexFilePath :: SavedConfig -> IO FilePath+tryGetIndexFilePath config = tryGetIndexFilePath' (savedGlobalFlags config)++-- | The same as 'tryGetIndexFilePath', but takes 'GlobalFlags' instead of+-- 'SavedConfig'.+tryGetIndexFilePath' :: GlobalFlags -> IO FilePath+tryGetIndexFilePath' globalFlags = do+  let paths = globalLocalRepos globalFlags   case paths of-    []  -> die $ "Distribution.Client.Sandbox.getIndexFilePath: " ++-           "no local repos found"-    [p] -> return $ p </> Index.defaultIndexFileName-    _   -> die $ "Distribution.Client.Sandbox.getIndexFilePath: " ++-           "too many local repos found"+    []  -> die $ "Distribution.Client.Sandbox.tryGetIndexFilePath: " +++           "no local repos found. " ++ checkConfiguration+    _   -> return $ (last paths) </> Index.defaultIndexFileName+  where+    checkConfiguration = "Please check your configuration ('"+                         ++ userPackageEnvironmentFile ++ "')." --- | Entry point for the 'cabal dump-pkgenv' command.-dumpPackageEnvironment :: Verbosity -> SandboxFlags -> IO ()-dumpPackageEnvironment verbosity sandboxFlags = do-  pkgEnvDir <- getSandboxLocation verbosity sandboxFlags+-- | Try to extract a 'PackageDB' from 'ConfigFlags'. Gives a better error+-- message than just pattern-matching.+getSandboxPackageDB :: ConfigFlags -> IO PackageDB+getSandboxPackageDB configFlags = do+  case configPackageDBs configFlags of+    [Just sandboxDB@(SpecificPackageDB _)] -> return sandboxDB+    -- TODO: should we allow multiple package DBs (e.g. with 'inherit')? -  pkgEnv        <- tryLoadPackageEnvironment verbosity pkgEnvDir-  commentPkgEnv <- commentPackageEnvironment pkgEnvDir-  putStrLn . showPackageEnvironmentWithComments commentPkgEnv $ pkgEnv+    []                                     ->+      die $ "Sandbox package DB is not specified. " ++ sandboxConfigCorrupt+    [_]                                    ->+      die $ "Unexpected contents of the 'package-db' field. "+            ++ sandboxConfigCorrupt+    _                                      ->+      die $ "Too many package DBs provided. " ++ sandboxConfigCorrupt --- | Entry point for the 'cabal sandbox-configure' command.-sandboxConfigure :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags-                    -> [String] -> GlobalFlags -> IO ()-sandboxConfigure verbosity-  sandboxFlags configFlags configExFlags extraArgs globalFlags = do-  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation-                    (sandboxLocation sandboxFlags)-  createDirectoryIfMissingVerbose verbosity True sandboxDir'-  sandboxDir   <- canonicalizePath sandboxDir'-  (comp, conf) <- configCompilerSandbox sandboxDir-  notice verbosity $ "Using a sandbox located at " ++ sandboxDir+  where+    sandboxConfigCorrupt = "Your 'cabal.sandbox.config' is probably corrupt." -  pkgEnv <- loadOrCreatePackageEnvironment verbosity sandboxDir configFlags comp -  let config         = pkgEnvSavedConfig pkgEnv-      configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-      [Just (SpecificPackageDB dbPath)]-                     = configPackageDBs configFlags'+-- | Which packages are installed in the sandbox package DB?+getInstalledPackagesInSandbox :: Verbosity -> ConfigFlags+                                 -> Compiler -> ProgramConfiguration+                                 -> IO InstalledPackageIndex.PackageIndex+getInstalledPackagesInSandbox verbosity configFlags comp conf = do+    sandboxDB <- getSandboxPackageDB configFlags+    getPackageDBContents verbosity comp sandboxDB conf -  indexFile <- getIndexFilePath pkgEnv-  Index.createEmpty verbosity indexFile+-- | Temporarily add $SANDBOX_DIR/bin to $PATH.+withSandboxBinDirOnSearchPath :: FilePath -> IO a -> IO a+withSandboxBinDirOnSearchPath sandboxDir = bracket_ addBinDir rmBinDir+  where+    -- TODO: Instead of modifying the global process state, it'd be better to+    -- set the environment individually for each subprocess invocation. This+    -- will have to wait until the Shell monad is implemented; without it the+    -- required changes are too intrusive.+    addBinDir :: IO ()+    addBinDir = do+      mbOldPath <- lookupEnv "PATH"+      let newPath = maybe sandboxBin ((++) sandboxBin . (:) searchPathSeparator)+                    mbOldPath+      setEnv "PATH" newPath++    rmBinDir :: IO ()+    rmBinDir = do+      oldPath <- getSearchPath+      let newPath = intercalate [searchPathSeparator]+                    (delete sandboxBin oldPath)+      setEnv "PATH" newPath++    sandboxBin = sandboxDir </> "bin"++-- | Initialise a package DB for this compiler if it doesn't exist.+initPackageDBIfNeeded :: Verbosity -> ConfigFlags+                         -> Compiler -> ProgramConfiguration+                         -> IO ()+initPackageDBIfNeeded verbosity configFlags comp conf = do+  SpecificPackageDB dbPath <- getSandboxPackageDB configFlags   packageDBExists <- doesDirectoryExist dbPath   unless packageDBExists $     Register.initPackageDB verbosity comp conf dbPath   when packageDBExists $-    notice verbosity $ "The package database already exists: " ++ dbPath-  configure verbosity-            (configPackageDB' configFlags') (globalRepos globalFlags')-            comp conf configFlags' configExFlags' extraArgs+    debug verbosity $ "The package database already exists: " ++ dbPath++-- | Entry point for the 'cabal sandbox dump-pkgenv' command.+dumpPackageEnvironment :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()+dumpPackageEnvironment verbosity _sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  commentPkgEnv        <- commentPackageEnvironment sandboxDir+  putStrLn . showPackageEnvironmentWithComments (Just commentPkgEnv) $ pkgEnv++-- | Entry point for the 'cabal sandbox init' command.+sandboxInit :: Verbosity -> SandboxFlags  -> GlobalFlags -> IO ()+sandboxInit verbosity sandboxFlags globalFlags = do+  -- Warn if there's a 'cabal-dev' sandbox.+  isCabalDevSandbox <- liftM2 (&&) (doesDirectoryExist "cabal-dev")+                       (doesFileExist $ "cabal-dev" </> "cabal.config")+  when isCabalDevSandbox $+    warn verbosity $+    "You are apparently using a legacy (cabal-dev) sandbox. "+    ++ "Legacy sandboxes may interact badly with native Cabal sandboxes. "+    ++ "You may want to delete the 'cabal-dev' directory to prevent issues."++  -- Create the sandbox directory.+  let sandboxDir' = fromFlagOrDefault defaultSandboxLocation+                    (sandboxLocation sandboxFlags)+  createDirectoryIfMissingVerbose verbosity True sandboxDir'+  sandboxDir <- tryCanonicalizePath sandboxDir'+  setFileHidden sandboxDir++  -- Determine which compiler to use (using the value from ~/.cabal/config).+  userConfig <- loadConfig verbosity (globalConfigFile globalFlags) NoFlag+  (comp, platform, conf) <- configCompilerAuxEx (savedConfigureFlags userConfig)++  -- Create the package environment file.+  pkgEnvFile <- getSandboxConfigFilePath globalFlags+  createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile+    NoComments comp platform+  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  let config      = pkgEnvSavedConfig pkgEnv+      configFlags = savedConfigureFlags config++  -- Create the index file if it doesn't exist.+  indexFile <- tryGetIndexFilePath config+  indexFileExists <- doesFileExist indexFile+  if indexFileExists+    then notice verbosity $ "Using an existing sandbox located at " ++ sandboxDir+    else notice verbosity $ "Creating a new sandbox at " ++ sandboxDir+  Index.createEmpty verbosity indexFile++  -- Create the package DB for the default compiler.+  initPackageDBIfNeeded verbosity configFlags comp conf+  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+    (compilerId comp) platform++-- | Entry point for the 'cabal sandbox delete' command.+sandboxDelete :: Verbosity -> SandboxFlags -> GlobalFlags -> IO ()+sandboxDelete verbosity _sandboxFlags globalFlags = do+  (useSandbox, _) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  case useSandbox of+    NoSandbox -> die "Not in a sandbox."+    UseSandbox sandboxDir -> do+      curDir     <- getCurrentDirectory+      pkgEnvFile <- getSandboxConfigFilePath globalFlags++      -- Remove the @cabal.sandbox.config@ file, unless it's in a non-standard+      -- location.+      let isNonDefaultConfigLocation =+            pkgEnvFile /= (curDir </> sandboxPackageEnvironmentFile)++      if isNonDefaultConfigLocation+        then warn verbosity $ "Sandbox config file is in non-default location: '"+                    ++ pkgEnvFile ++ "'.\n Please delete manually."+        else removeFile pkgEnvFile++      -- Remove the sandbox directory, unless we're using a shared sandbox.+      let isNonDefaultSandboxLocation =+            sandboxDir /= (curDir </> defaultSandboxLocation)++      when isNonDefaultSandboxLocation $+        die $ "Non-default sandbox location used: '" ++ sandboxDir+        ++ "'.\nAssuming a shared sandbox. Please delete '"+        ++ sandboxDir ++ "' manually."++      notice verbosity $ "Deleting the sandbox located at " ++ sandboxDir+      removeDirectoryRecursive sandboxDir++-- Common implementation of 'sandboxAddSource' and 'sandboxAddSourceSnapshot'.+doAddSource :: Verbosity -> [FilePath] -> FilePath -> PackageEnvironment+               -> BuildTreeRefType+               -> IO ()+doAddSource verbosity buildTreeRefs sandboxDir pkgEnv refType = do+  let savedConfig       = pkgEnvSavedConfig pkgEnv+  indexFile            <- tryGetIndexFilePath savedConfig++  -- If we're running 'sandbox add-source' for the first time for this compiler,+  -- we need to create an initial timestamp record.+  (comp, platform, _) <- configCompilerAuxEx . savedConfigureFlags $ savedConfig+  maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+    (compilerId comp) platform++  withAddTimestamps sandboxDir $ do+    -- FIXME: path canonicalisation is done in addBuildTreeRefs, but we do it+    -- twice because of the timestamps file.+    buildTreeRefs' <- mapM tryCanonicalizePath buildTreeRefs+    Index.addBuildTreeRefs verbosity indexFile buildTreeRefs' refType+    return buildTreeRefs'++-- | Entry point for the 'cabal sandbox add-source' command.+sandboxAddSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags+                    -> IO ()+sandboxAddSource verbosity buildTreeRefs sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags++  if fromFlagOrDefault False (sandboxSnapshot sandboxFlags)+    then sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv+    else doAddSource verbosity buildTreeRefs sandboxDir pkgEnv LinkRef++-- | Entry point for the 'cabal sandbox add-source --snapshot' command.+sandboxAddSourceSnapshot :: Verbosity -> [FilePath] -> FilePath+                            -> PackageEnvironment+                            -> IO ()+sandboxAddSourceSnapshot verbosity buildTreeRefs sandboxDir pkgEnv = do+  let snapshotDir = sandboxDir </> snapshotDirectoryName++  -- Use 'D.S.SrcDist.prepareTree' to copy each package's files to our private+  -- location.+  createDirectoryIfMissingVerbose verbosity True snapshotDir++  -- Collect the package descriptions first, so that if some path does not refer+  -- to a cabal package, we fail immediately.+  pkgs      <- forM buildTreeRefs $ \buildTreeRef ->+    inDir (Just buildTreeRef) $+    return . flattenPackageDescription+            =<< readPackageDescription verbosity+            =<< defaultPackageDesc     verbosity++  -- Copy the package sources to "snapshots/$PKGNAME-$VERSION-tmp". If+  -- 'prepareTree' throws an error at any point, the old snapshots will still be+  -- in consistent state.+  tmpDirs <- forM (zip buildTreeRefs pkgs) $ \(buildTreeRef, pkg) ->+    inDir (Just buildTreeRef) $ do+      let targetDir    = snapshotDir </> (display . packageId $ pkg)+          targetTmpDir = targetDir ++ "-tmp"+      dirExists <- doesDirectoryExist targetTmpDir+      when dirExists $+        removeDirectoryRecursive targetDir+      createDirectory targetTmpDir+      prepareTree verbosity pkg Nothing targetTmpDir knownSuffixHandlers+      return (targetTmpDir, targetDir)++  -- Now rename the "snapshots/$PKGNAME-$VERSION-tmp" dirs to+  -- "snapshots/$PKGNAME-$VERSION".+  snapshots <- forM tmpDirs $ \(targetTmpDir, targetDir) -> do+    dirExists <- doesDirectoryExist targetDir+    when dirExists $+      removeDirectoryRecursive targetDir+    renameDirectory targetTmpDir targetDir+    return targetDir++  -- Once the packages are copied, just 'add-source' them as usual.+  doAddSource verbosity snapshots sandboxDir pkgEnv SnapshotRef++-- | Entry point for the 'cabal sandbox delete-source' command.+sandboxDeleteSource :: Verbosity -> [FilePath] -> SandboxFlags -> GlobalFlags+                       -> IO ()+sandboxDeleteSource verbosity buildTreeRefs _sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)++  withRemoveTimestamps sandboxDir $ do+    Index.removeBuildTreeRefs verbosity indexFile buildTreeRefs++  notice verbosity $ "Note: 'sandbox delete-source' only unregisters the " +++    "source dependency, but does not remove the package " +++    "from the sandbox package DB.\n\n" +++    "Use 'sandbox hc-pkg -- unregister' to do that."++-- | Entry point for the 'cabal sandbox list-sources' command.+sandboxListSources :: Verbosity -> SandboxFlags -> GlobalFlags+                      -> IO ()+sandboxListSources verbosity _sandboxFlags globalFlags = do+  (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  indexFile            <- tryGetIndexFilePath (pkgEnvSavedConfig pkgEnv)++  refs <- Index.listBuildTreeRefs verbosity+          Index.ListIgnored Index.LinksAndSnapshots indexFile+  when (null refs) $+    notice verbosity $ "Index file '" ++ indexFile+    ++ "' has no references to local build trees."+  when (not . null $ refs) $ do+    notice verbosity $ "Source dependencies registered "+      ++ "in the current sandbox ('" ++ sandboxDir ++ "'):\n\n"+    mapM_ putStrLn refs+    notice verbosity $ "\nTo unregister source dependencies, "+                       ++ "use the 'sandbox delete-source' command."++-- | Entry point for the 'cabal sandbox hc-pkg' command. Invokes the @hc-pkg@+-- tool with provided arguments, restricted to the sandbox.+sandboxHcPkg :: Verbosity -> SandboxFlags -> GlobalFlags -> [String] -> IO ()+sandboxHcPkg verbosity _sandboxFlags globalFlags extraArgs = do+  (_sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+  let configFlags = savedConfigureFlags . pkgEnvSavedConfig $ pkgEnv+      dbStack     = configPackageDB' configFlags+  (comp, _platform, conf) <- configCompilerAux' configFlags++  Register.invokeHcPkg verbosity comp conf dbStack extraArgs++-- | Check which type of package environment we're in and return a+-- correctly-initialised @SavedConfig@ and a @UseSandbox@ value that indicates+-- whether we're working in a sandbox.+loadConfigOrSandboxConfig :: Verbosity+                             -> GlobalFlags  -- ^ For @--config-file@ and+                                             -- @--sandbox-config-file@.+                             -> Flag Bool    -- ^ Ignored if we're in a sandbox.+                             -> IO (UseSandbox, SavedConfig)+loadConfigOrSandboxConfig verbosity globalFlags userInstallFlag = do+  let configFileFlag        = globalConfigFile        globalFlags+      sandboxConfigFileFlag = globalSandboxConfigFile globalFlags+      ignoreSandboxFlag     = globalIgnoreSandbox globalFlags++  pkgEnvDir  <- getPkgEnvDir sandboxConfigFileFlag+  pkgEnvType <- classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag+                                           ignoreSandboxFlag+  case pkgEnvType of+    -- A @cabal.sandbox.config@ file (and possibly @cabal.config@) is present.+    SandboxPackageEnvironment -> do+      (sandboxDir, pkgEnv) <- tryLoadSandboxConfig verbosity globalFlags+                              -- ^ Prints an error message and exits on error.+      let config = pkgEnvSavedConfig pkgEnv+      return (UseSandbox sandboxDir, config)++    -- Only @cabal.config@ is present.+    UserPackageEnvironment    -> do+      config <- loadConfig verbosity configFileFlag userInstallFlag+      userConfig <- loadUserConfig verbosity pkgEnvDir+      let config' = config `mappend` userConfig+      dieIfSandboxRequired config'+      return (NoSandbox, config')++    -- Neither @cabal.sandbox.config@ nor @cabal.config@ are present.+    AmbientPackageEnvironment -> do+      config <- loadConfig verbosity configFileFlag userInstallFlag+      dieIfSandboxRequired config+      return (NoSandbox, config)+   where-    -- We need to know the compiler version so that the correct package DB is-    -- used. We try to read it from the package environment file, which might-    -- not exist.-    configCompilerSandbox :: FilePath -> IO (Compiler, ProgramConfiguration)-    configCompilerSandbox sandboxDir = do-      -- Build a ConfigFlags record...-      let basePkgEnv = basePackageEnvironment sandboxDir-      userConfig    <- loadConfig verbosity NoFlag NoFlag-      mPkgEnv       <- readPackageEnvironmentFile mempty-                       (sandboxDir </> defaultPackageEnvironmentFileName)-      let pkgEnv     = case mPkgEnv of-            Just (ParseOk _warns parseResult) -> parseResult-            _                                 -> mempty-      let basePkgEnvConfig = pkgEnvSavedConfig basePkgEnv-          pkgEnvConfig     = pkgEnvSavedConfig pkgEnv-          configFlags'     = savedConfigureFlags basePkgEnvConfig-                             `mappend` savedConfigureFlags userConfig-                             `mappend` savedConfigureFlags pkgEnvConfig-                             `mappend` configFlags-      -- ...and pass it to configCompilerAux.-      configCompilerAux configFlags'+    -- Return the path to the package environment directory - either the+    -- current directory or the one that @--sandbox-config-file@ resides in.+    getPkgEnvDir :: (Flag FilePath) -> IO FilePath+    getPkgEnvDir sandboxConfigFileFlag = do+      case sandboxConfigFileFlag of+        NoFlag    -> getCurrentDirectory+        Flag path -> tryCanonicalizePath . takeDirectory $ path --- | Entry point for the 'cabal sandbox-add-source' command.-sandboxAddSource :: Verbosity -> SandboxFlags -> [FilePath] -> IO ()-sandboxAddSource verbosity sandboxFlags buildTreeRefs = do-  sandboxDir <- getSandboxLocation verbosity sandboxFlags-  pkgEnv     <- tryLoadPackageEnvironment verbosity sandboxDir-  indexFile  <- getIndexFilePath pkgEnv-  Index.addBuildTreeRefs verbosity indexFile buildTreeRefs+    -- Die if @--require-sandbox@ was specified and we're not inside a sandbox.+    dieIfSandboxRequired :: SavedConfig -> IO ()+    dieIfSandboxRequired config = checkFlag flag+      where+        flag = (globalRequireSandbox . savedGlobalFlags $ config)+               `mappend` (globalRequireSandbox globalFlags)+        checkFlag (Flag True)  =+          die $ "'require-sandbox' is set to True, but no sandbox is present."+        checkFlag (Flag False) = return ()+        checkFlag (NoFlag)     = return () --- | Entry point for the 'cabal sandbox-build' command.-sandboxBuild :: Verbosity -> SandboxFlags -> BuildFlags -> [String] -> IO ()-sandboxBuild verbosity sandboxFlags buildFlags' extraArgs = do-  -- Check that the sandbox exists.-  _ <- getSandboxLocation verbosity sandboxFlags+-- | If we're in a sandbox, call @withSandboxBinDirOnSearchPath@, otherwise do+-- nothing.+maybeWithSandboxDirOnSearchPath :: UseSandbox -> IO a -> IO a+maybeWithSandboxDirOnSearchPath NoSandbox               act = act+maybeWithSandboxDirOnSearchPath (UseSandbox sandboxDir) act =+  withSandboxBinDirOnSearchPath sandboxDir $ act -  let setupScriptOptions = defaultSetupScriptOptions {-        useDistPref = fromFlagOrDefault-                      (useDistPref defaultSetupScriptOptions)-                      (buildDistPref buildFlags)-        }-      buildFlags = buildFlags' {-        buildVerbosity = toFlag verbosity-        }-  setupWrapper verbosity setupScriptOptions Nothing-    (buildCommand defaultProgramConfiguration) (const buildFlags) extraArgs+-- | Had reinstallAddSourceDeps actually reinstalled any dependencies?+data WereDepsReinstalled = ReinstalledSomeDeps | NoDepsReinstalled --- | Entry point for the 'cabal sandbox-install' command.-sandboxInstall :: Verbosity -> SandboxFlags -> ConfigFlags -> ConfigExFlags-                  -> InstallFlags -> HaddockFlags -> [String] -> GlobalFlags-                  -> IO ()-sandboxInstall verbosity _sandboxFlags _configFlags _configExFlags-  installFlags _haddockFlags _extraArgs _globalFlags-  | fromFlagOrDefault False (installOnly installFlags)-  = setupWrapper verbosity defaultSetupScriptOptions Nothing-    installCommand (const mempty) []+-- | Reinstall those add-source dependencies that have been modified since+-- we've last installed them. Assumes that we're working inside a sandbox.+reinstallAddSourceDeps :: Verbosity+                          -> ConfigFlags  -> ConfigExFlags+                          -> InstallFlags -> GlobalFlags+                          -> FilePath+                          -> IO WereDepsReinstalled+reinstallAddSourceDeps verbosity configFlags' configExFlags+                       installFlags globalFlags sandboxDir = topHandler' $ do+  let sandboxDistPref     = sandboxBuildDir sandboxDir+      configFlags         = configFlags'+                            { configDistPref  = Flag sandboxDistPref }+      haddockFlags        = mempty+                            { haddockDistPref = Flag sandboxDistPref }+  (comp, platform, conf) <- configCompilerAux' configFlags+  retVal                 <- newIORef NoDepsReinstalled -sandboxInstall verbosity sandboxFlags configFlags configExFlags-  installFlags haddockFlags extraArgs globalFlags = do-  sandboxDir <- getSandboxLocation verbosity sandboxFlags+  withSandboxPackageInfo verbosity configFlags globalFlags+                         comp platform conf sandboxDir $ \sandboxPkgInfo ->+    unless (null $ modifiedAddSourceDependencies sandboxPkgInfo) $ do -  pkgEnv <- tryLoadPackageEnvironment verbosity sandboxDir-  targets    <- readUserTargets verbosity extraArgs-  let config        = pkgEnvSavedConfig pkgEnv-      configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = defaultConfigExFlags         `mappend`-                       savedConfigureExFlags config `mappend` configExFlags-      installFlags'  = defaultInstallFlags          `mappend`-                       savedInstallFlags     config `mappend` installFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags'-  install verbosity-          (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf-          globalFlags' configFlags' configExFlags' installFlags' haddockFlags-          targets+      let args :: InstallArgs+          args = ((configPackageDB' configFlags)+                 ,(globalRepos globalFlags)+                 ,comp, platform, conf+                 ,UseSandbox sandboxDir, Just sandboxPkgInfo+                 ,globalFlags, configFlags, configExFlags, installFlags+                 ,haddockFlags) +      -- This can actually be replaced by a call to 'install', but we use a+      -- lower-level API because of layer separation reasons. Additionally, we+      -- might want to use some lower-level features this in the future.+      withSandboxBinDirOnSearchPath sandboxDir $ do+        installContext <- makeInstallContext verbosity args Nothing+        installPlan    <- foldProgress logMsg die' return =<<+                          makeInstallPlan verbosity args installContext++        processInstallPlan verbosity args installContext installPlan+        writeIORef retVal ReinstalledSomeDeps++  readIORef retVal++    where+      die' message = die (message ++ installFailedInSandbox)+      -- TODO: use a better error message, remove duplication.+      installFailedInSandbox =+        "Note: when using a sandbox, all packages are required to have \+        \consistent dependencies. \+        \Try reinstalling/unregistering the offending packages or \+        \recreating the sandbox."+      logMsg message rest = debugNoWrap verbosity message >> rest++      topHandler' = topHandlerWith $ \_ -> do+        warn verbosity "Couldn't reinstall some add-source dependencies."+        -- Here we can't know whether any deps have been reinstalled, so we have+        -- to be conservative.+        return ReinstalledSomeDeps++-- | Produce a 'SandboxPackageInfo' and feed it to the given action. Note that+-- we don't update the timestamp file here - this is done in+-- 'postInstallActions'.+withSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags+                          -> Compiler -> Platform -> ProgramConfiguration+                          -> FilePath+                          -> (SandboxPackageInfo -> IO ())+                          -> IO ()+withSandboxPackageInfo verbosity configFlags globalFlags+                       comp platform conf sandboxDir cont = do+  -- List all add-source deps.+  indexFile              <- tryGetIndexFilePath' globalFlags+  buildTreeRefs          <- Index.listBuildTreeRefs verbosity+                            Index.DontListIgnored Index.OnlyLinks indexFile+  let allAddSourceDepsSet = S.fromList buildTreeRefs++  -- List all packages installed in the sandbox.+  installedPkgIndex <- getInstalledPackagesInSandbox verbosity+                       configFlags comp conf++  -- Get the package descriptions for all add-source deps.+  depsCabalFiles <- mapM tryFindPackageDesc buildTreeRefs+  depsPkgDescs   <- mapM (readPackageDescription verbosity) depsCabalFiles+  let depsMap           = M.fromList (zip buildTreeRefs depsPkgDescs)+      isInstalled pkgid = not . null+        . InstalledPackageIndex.lookupSourcePackageId installedPkgIndex $ pkgid+      installedDepsMap  = M.filter (isInstalled . packageId) depsMap++  -- Get the package ids of modified (and installed) add-source deps.+  modifiedAddSourceDeps <- listModifiedDeps verbosity sandboxDir+                           (compilerId comp) platform installedDepsMap+  -- 'fromJust' here is safe because 'modifiedAddSourceDeps' are guaranteed to+  -- be a subset of the keys of 'depsMap'.+  let modifiedDeps    = [ (modDepPath, fromJust $ M.lookup modDepPath depsMap)+                        | modDepPath <- modifiedAddSourceDeps ]+      modifiedDepsMap = M.fromList modifiedDeps++  assert (all (`S.member` allAddSourceDepsSet) modifiedAddSourceDeps) (return ())+  if (null modifiedDeps)+    then info   verbosity $ "Found no modified add-source deps."+    else notice verbosity $ "Some add-source dependencies have been modified. "+                            ++ "They will be reinstalled..."++  -- Get the package ids of the remaining add-source deps (some are possibly not+  -- installed).+  let otherDeps = M.assocs (depsMap `M.difference` modifiedDepsMap)++  -- Finally, assemble a 'SandboxPackageInfo'.+  cont $ SandboxPackageInfo (map toSourcePackage modifiedDeps)+    (map toSourcePackage otherDeps) installedPkgIndex allAddSourceDepsSet++  where+    toSourcePackage (path, pkgDesc) = SourcePackage+      (packageId pkgDesc) pkgDesc (LocalUnpackedPackage path) Nothing++-- | Same as 'withSandboxPackageInfo' if we're inside a sandbox and a no-op+-- otherwise.+maybeWithSandboxPackageInfo :: Verbosity -> ConfigFlags -> GlobalFlags+                               -> Compiler -> Platform -> ProgramConfiguration+                               -> UseSandbox+                               -> (Maybe SandboxPackageInfo -> IO ())+                               -> IO ()+maybeWithSandboxPackageInfo verbosity configFlags globalFlags+                            comp platform conf useSandbox cont =+  case useSandbox of+    NoSandbox             -> cont Nothing+    UseSandbox sandboxDir -> withSandboxPackageInfo verbosity+                             configFlags globalFlags+                             comp platform conf sandboxDir+                             (\spi -> cont (Just spi))++-- | Check if a sandbox is present and call @reinstallAddSourceDeps@ in that+-- case.+maybeReinstallAddSourceDeps :: Verbosity+                               -> Flag (Maybe Int) -- ^ The '-j' flag+                               -> ConfigFlags      -- ^ Saved configure flags+                                                   -- (from dist/setup-config)+                               -> GlobalFlags+                               -> IO (UseSandbox, SavedConfig+                                     ,WereDepsReinstalled)+maybeReinstallAddSourceDeps verbosity numJobsFlag configFlags' globalFlags' = do+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags'+                          (configUserInstall configFlags')+  case useSandbox of+    NoSandbox             -> return (NoSandbox, config, NoDepsReinstalled)+    UseSandbox sandboxDir -> do+      -- Reinstall the modified add-source deps.+      let configFlags    = savedConfigureFlags config+                           `mappendSomeSavedFlags`+                           configFlags'+          configExFlags  = defaultConfigExFlags+                           `mappend` savedConfigureExFlags config+          installFlags'  = defaultInstallFlags+                           `mappend` savedInstallFlags config+          installFlags   = installFlags' {+            installNumJobs    = installNumJobs installFlags'+                                `mappend` numJobsFlag+            }+          globalFlags    = savedGlobalFlags config+          -- This makes it possible to override things like 'remote-repo-cache'+          -- from the command line. These options are hidden, and are only+          -- useful for debugging, so this should be fine.+                           `mappend` globalFlags'+      depsReinstalled <- reinstallAddSourceDeps verbosity+                         configFlags configExFlags installFlags globalFlags+                         sandboxDir+      return (UseSandbox sandboxDir, config, depsReinstalled)++  where++    -- NOTE: we can't simply do @sandboxConfigFlags `mappend` savedFlags@+    -- because we don't want to auto-enable things like 'library-profiling' for+    -- all add-source dependencies even if the user has passed+    -- '--enable-library-profiling' to 'cabal configure'. These options are+    -- supposed to be set in 'cabal.config'.+    mappendSomeSavedFlags :: ConfigFlags -> ConfigFlags -> ConfigFlags+    mappendSomeSavedFlags sandboxConfigFlags savedFlags =+      sandboxConfigFlags {+        configHcFlavor     = configHcFlavor sandboxConfigFlags+                             `mappend` configHcFlavor savedFlags,+        configHcPath       = configHcPath sandboxConfigFlags+                             `mappend` configHcPath savedFlags,+        configHcPkg        = configHcPkg sandboxConfigFlags+                             `mappend` configHcPkg savedFlags,+        configProgramPaths = configProgramPaths sandboxConfigFlags+                             `mappend` configProgramPaths savedFlags,+        configProgramArgs  = configProgramArgs sandboxConfigFlags+                             `mappend` configProgramArgs savedFlags+        -- NOTE: We don't touch the @configPackageDBs@ field because+        -- @sandboxConfigFlags@ contains the sandbox location which was set when+        -- creating @cabal.sandbox.config@.+        -- FIXME: Is this compatible with the 'inherit' feature?+        }++--+-- Utils (transitionary)+--+-- FIXME: configPackageDB' and configCompilerAux' don't really belong in this+-- module+--+ configPackageDB' :: ConfigFlags -> PackageDBStack configPackageDB' cfg =-  interpretPackageDbFlags userInstall (configPackageDBs cfg)+    interpretPackageDbFlags userInstall (configPackageDBs cfg)   where     userInstall = fromFlagOrDefault True (configUserInstall cfg)  configCompilerAux' :: ConfigFlags-                      -> IO (Compiler, ProgramConfiguration)+                   -> IO (Compiler, Platform, ProgramConfiguration) configCompilerAux' configFlags =-  configCompilerAux configFlags+  configCompilerAuxEx configFlags     --FIXME: make configCompilerAux use a sensible verbosity     { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
+ cabal/cabal-install/Distribution/Client/Sandbox/Index.hs view
@@ -0,0 +1,237 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.Index+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Querying and modifying local build tree references in the package index.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.Index (+    createEmpty,+    addBuildTreeRefs,+    removeBuildTreeRefs,+    ListIgnoredBuildTreeRefs(..), RefTypesToList(..),+    listBuildTreeRefs,+    validateIndexPath,++    defaultIndexFileName+  ) where++import qualified Distribution.Client.Tar as Tar+import Distribution.Client.IndexUtils ( BuildTreeRefType(..)+                                      , refTypeFromTypeCode+                                      , typeCodeFromRefType+                                      , getSourcePackagesStrict )+import Distribution.Client.PackageIndex ( allPackages )+import Distribution.Client.Types ( Repo(..), LocalRepo(..)+                                 , SourcePackageDb(..)+                                 , SourcePackage(..), PackageLocation(..) )+import Distribution.Client.Utils ( byteStringToFilePath, filePathToByteString+                                 , makeAbsoluteToCwd, tryCanonicalizePath+                                 , canonicalizePathNoThrow )++import Distribution.Simple.Utils ( die, debug, tryFindPackageDesc )+import Distribution.Verbosity    ( Verbosity )++import qualified Data.ByteString.Lazy as BS+import Control.Exception         ( evaluate )+import Control.Monad             ( liftM, unless )+import Data.List                 ( (\\), intersect, nub )+import Data.Maybe                ( catMaybes )+import System.Directory          ( createDirectoryIfMissing,+                                   doesDirectoryExist, doesFileExist,+                                   renameFile )+import System.FilePath           ( (</>), (<.>), takeDirectory, takeExtension )+import System.IO                 ( IOMode(..), SeekMode(..)+                                 , hSeek, withBinaryFile )++-- | A reference to a local build tree.+data BuildTreeRef = BuildTreeRef {+  buildTreeRefType :: !BuildTreeRefType,+  buildTreePath     :: !FilePath+  }++defaultIndexFileName :: FilePath+defaultIndexFileName = "00-index.tar"++-- | Given a path, ensure that it refers to a local build tree.+buildTreeRefFromPath :: BuildTreeRefType -> FilePath -> IO (Maybe BuildTreeRef)+buildTreeRefFromPath refType dir = do+  dirExists <- doesDirectoryExist dir+  unless dirExists $+    die $ "directory '" ++ dir ++ "' does not exist"+  _ <- tryFindPackageDesc dir+  return . Just $ BuildTreeRef refType dir++-- | Given a tar archive entry, try to parse it as a local build tree reference.+readBuildTreeRef :: Tar.Entry -> Maybe BuildTreeRef+readBuildTreeRef entry = case Tar.entryContent entry of+  (Tar.OtherEntryType typeCode bs size)+    | (Tar.isBuildTreeRefTypeCode typeCode)+      && (size == BS.length bs) -> Just $! BuildTreeRef+                                   (refTypeFromTypeCode typeCode)+                                   (byteStringToFilePath bs)+    | otherwise                 -> Nothing+  _ -> Nothing++-- | Given a sequence of tar archive entries, extract all references to local+-- build trees.+readBuildTreeRefs :: Tar.Entries -> [BuildTreeRef]+readBuildTreeRefs =+  catMaybes+  . Tar.foldrEntries (\e r -> readBuildTreeRef e : r)+  [] error++-- | Given a path to a tar archive, extract all references to local build trees.+readBuildTreeRefsFromFile :: FilePath -> IO [BuildTreeRef]+readBuildTreeRefsFromFile = liftM (readBuildTreeRefs . Tar.read) . BS.readFile++-- | Given a local build tree ref, serialise it to a tar archive entry.+writeBuildTreeRef :: BuildTreeRef -> Tar.Entry+writeBuildTreeRef (BuildTreeRef refType path) = Tar.simpleEntry tarPath content+  where+    bs       = filePathToByteString path+    -- Provide a filename for tools that treat custom entries as ordinary files.+    tarPath' = "local-build-tree-reference"+    -- fromRight can't fail because the path is shorter than 255 characters.+    tarPath  = fromRight $ Tar.toTarPath True tarPath'+    content  = Tar.OtherEntryType (typeCodeFromRefType refType) bs (BS.length bs)++    -- TODO: Move this to D.C.Utils?+    fromRight (Left err) = error err+    fromRight (Right a)  = a++-- | Check that the provided path is either an existing directory, or a tar+-- archive in an existing directory.+validateIndexPath :: FilePath -> IO FilePath+validateIndexPath path' = do+   path <- makeAbsoluteToCwd path'+   if (== ".tar") . takeExtension $ path+     then return path+     else do dirExists <- doesDirectoryExist path+             unless dirExists $+               die $ "directory does not exist: '" ++ path ++ "'"+             return $ path </> defaultIndexFileName++-- | Create an empty index file.+createEmpty :: Verbosity -> FilePath -> IO ()+createEmpty verbosity path = do+  indexExists <- doesFileExist path+  if indexExists+    then debug verbosity $ "Package index already exists: " ++ path+    else do+    debug verbosity $ "Creating the index file '" ++ path ++ "'"+    createDirectoryIfMissing True (takeDirectory path)+    -- Equivalent to 'tar cvf empty.tar --files-from /dev/null'.+    let zeros = BS.replicate (512*20) 0+    BS.writeFile path zeros++-- | Add given local build tree references to the index.+addBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> BuildTreeRefType+                    -> IO ()+addBuildTreeRefs _         _   []  _ =+  error "Distribution.Client.Sandbox.Index.addBuildTreeRefs: unexpected"+addBuildTreeRefs verbosity path l' refType = do+  checkIndexExists path+  l <- liftM nub . mapM tryCanonicalizePath $ l'+  treesInIndex <- fmap (map buildTreePath) (readBuildTreeRefsFromFile path)+  -- Add only those paths that aren't already in the index.+  treesToAdd <- mapM (buildTreeRefFromPath refType) (l \\ treesInIndex)+  let entries = map writeBuildTreeRef (catMaybes treesToAdd)+  unless (null entries) $ do+    offset <-+      fmap (Tar.foldrEntries (\e acc -> Tar.entrySizeInBytes e + acc) 0 error+            . Tar.read) $ BS.readFile path+    _ <- evaluate offset+    debug verbosity $ "Writing at offset: " ++ show offset+    withBinaryFile path ReadWriteMode $ \h -> do+      hSeek h AbsoluteSeek (fromIntegral offset)+      BS.hPut h (Tar.write entries)+      debug verbosity $ "Successfully appended to '" ++ path ++ "'"++-- | Remove given local build tree references from the index.+removeBuildTreeRefs :: Verbosity -> FilePath -> [FilePath] -> IO [FilePath]+removeBuildTreeRefs _         _   [] =+  error "Distribution.Client.Sandbox.Index.removeBuildTreeRefs: unexpected"+removeBuildTreeRefs verbosity path l' = do+  checkIndexExists path+  l <- mapM canonicalizePathNoThrow l'+  let tmpFile = path <.> "tmp"+  -- Performance note: on my system, it takes 'index --remove-source'+  -- approx. 3,5s to filter a 65M file. Real-life indices are expected to be+  -- much smaller.+  BS.writeFile tmpFile . Tar.writeEntries . Tar.filterEntries (p l) . Tar.read+    =<< BS.readFile path+  -- This invalidates the cache, so we don't have to update it explicitly.+  renameFile tmpFile path+  debug verbosity $ "Successfully renamed '" ++ tmpFile+    ++ "' to '" ++ path ++ "'"+  -- FIXME: return only the refs that vere actually removed.+  return l+    where+      p l entry = case readBuildTreeRef entry of+        Nothing                     -> True+        -- FIXME: removing snapshot deps is done with `delete-source+        -- .cabal-sandbox/snapshots/$SNAPSHOT_NAME`. Perhaps we also want to+        -- support removing snapshots by providing the original path.+        (Just (BuildTreeRef _ pth)) -> pth `notElem` l++-- | A build tree ref can become ignored if the user later adds a build tree ref+-- with the same package ID. We display ignored build tree refs when the user+-- runs 'cabal sandbox list-sources', but do not look at their timestamps in+-- 'reinstallAddSourceDeps'.+data ListIgnoredBuildTreeRefs = ListIgnored | DontListIgnored++-- | Which types of build tree refs should be listed?+data RefTypesToList = OnlySnapshots | OnlyLinks | LinksAndSnapshots++-- | List the local build trees that are referred to from the index.+listBuildTreeRefs :: Verbosity -> ListIgnoredBuildTreeRefs -> RefTypesToList+                     -> FilePath+                     -> IO [FilePath]+listBuildTreeRefs verbosity listIgnored refTypesToList path = do+  checkIndexExists path+  buildTreeRefs <-+    case listIgnored of+      DontListIgnored -> do+        paths <- listWithoutIgnored+        case refTypesToList of+          LinksAndSnapshots -> return paths+          _                 -> do+            allPathsFiltered <- fmap (map buildTreePath . filter predicate)+                                listWithIgnored+            _ <- evaluate (length allPathsFiltered)+            return (paths `intersect` allPathsFiltered)++      ListIgnored -> fmap (map buildTreePath . filter predicate) listWithIgnored++  _ <- evaluate (length buildTreeRefs)+  return buildTreeRefs++    where+      predicate :: BuildTreeRef -> Bool+      predicate = case refTypesToList of+        OnlySnapshots     -> (==) SnapshotRef . buildTreeRefType+        OnlyLinks         -> (==) LinkRef     . buildTreeRefType+        LinksAndSnapshots -> const True++      listWithIgnored :: IO [BuildTreeRef]+      listWithIgnored = readBuildTreeRefsFromFile $ path++      listWithoutIgnored :: IO [FilePath]+      listWithoutIgnored = do+        let repo = Repo { repoKind = Right LocalRepo+                        , repoLocalDir = takeDirectory path }+        pkgIndex <- fmap packageIndex+                    . getSourcePackagesStrict verbosity $ [repo]+        return [ pkgPath | (LocalUnpackedPackage pkgPath) <-+                    map packageSource . allPackages $ pkgIndex ]+++-- | Check that the package index file exists and exit with error if it does not.+checkIndexExists :: FilePath -> IO ()+checkIndexExists path = do+  indexExists <- doesFileExist path+  unless indexExists $+    die $ "index does not exist: '" ++ path ++ "'"
+ cabal/cabal-install/Distribution/Client/Sandbox/PackageEnvironment.hs view
@@ -0,0 +1,528 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.PackageEnvironment+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Utilities for working with the package environment file. Patterned after+-- Distribution.Client.Config.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.PackageEnvironment (+    PackageEnvironment(..)+  , IncludeComments(..)+  , PackageEnvironmentType(..)+  , classifyPackageEnvironment+  , createPackageEnvironmentFile+  , tryLoadSandboxPackageEnvironmentFile+  , readPackageEnvironmentFile+  , showPackageEnvironment+  , showPackageEnvironmentWithComments+  , setPackageDB+  , loadUserConfig++  , basePackageEnvironment+  , initialPackageEnvironment+  , commentPackageEnvironment+  , sandboxPackageEnvironmentFile+  , userPackageEnvironmentFile+  ) where++import Distribution.Client.Config      ( SavedConfig(..), commentSavedConfig+                                       , loadConfig, configFieldDescriptions+                                       , installDirsFields, defaultCompiler )+import Distribution.Client.ParseUtils  ( parseFields, ppFields, ppSection )+import Distribution.Client.Setup       ( GlobalFlags(..), ConfigExFlags(..)+                                       , InstallFlags(..)+                                       , defaultSandboxLocation )+import Distribution.Simple.Command     ( ShowOrParseArgs(..), viewAsFieldDescr )+import Distribution.Simple.Compiler    ( Compiler, PackageDB(..)+                                       , compilerFlavor, showCompilerId )+import Distribution.Simple.InstallDirs ( InstallDirs(..), PathTemplate+                                       , defaultInstallDirs, combineInstallDirs+                                       , fromPathTemplate, toPathTemplate )+import Distribution.Simple.Program     ( defaultProgramConfiguration )+import Distribution.Simple.Setup       ( Flag(..), ConfigFlags(..)+                                       , programConfigurationOptions+                                       , fromFlagOrDefault, toFlag, flagToMaybe )+import Distribution.Simple.Utils       ( die, info, notice, warn, lowercase )+import Distribution.ParseUtils         ( FieldDescr(..), ParseResult(..)+                                       , commaListField+                                       , liftField, lineNo, locatedErrorMsg+                                       , parseFilePathQ, readFields+                                       , showPWarning, simpleField, syntaxError )+import Distribution.System             ( Platform )+import Distribution.Verbosity          ( Verbosity, normal )+import Control.Monad                   ( foldM, liftM2, when, unless )+import Data.List                       ( partition )+import Data.Maybe                      ( isJust )+import Data.Monoid                     ( Monoid(..) )+import Distribution.Compat.Exception   ( catchIO )+import System.Directory                ( doesDirectoryExist, doesFileExist+                                       , renameFile )+import System.FilePath                 ( (<.>), (</>), takeDirectory )+import System.IO.Error                 ( isDoesNotExistError )+import Text.PrettyPrint                ( ($+$) )++import qualified Text.PrettyPrint          as Disp+import qualified Distribution.Compat.ReadP as Parse+import qualified Distribution.ParseUtils   as ParseUtils ( Field(..) )+import qualified Distribution.Text         as Text+++--+-- * Configuration saved in the package environment file+--++-- TODO: would be nice to remove duplication between+-- D.C.Sandbox.PackageEnvironment and D.C.Config.+data PackageEnvironment = PackageEnvironment {+  -- The 'inherit' feature is not used ATM, but could be useful in the future+  -- for constructing nested sandboxes (see discussion in #1196).+  pkgEnvInherit       :: Flag FilePath,+  pkgEnvSavedConfig   :: SavedConfig+}++instance Monoid PackageEnvironment where+  mempty = PackageEnvironment {+    pkgEnvInherit       = mempty,+    pkgEnvSavedConfig   = mempty+    }++  mappend a b = PackageEnvironment {+    pkgEnvInherit       = combine pkgEnvInherit,+    pkgEnvSavedConfig   = combine pkgEnvSavedConfig+    }+    where+      combine f = f a `mappend` f b++-- | The automatically-created package environment file that should not be+-- touched by the user.+sandboxPackageEnvironmentFile :: FilePath+sandboxPackageEnvironmentFile = "cabal.sandbox.config"++-- | Optional package environment file that can be used to customize the default+-- settings. Created by the user.+userPackageEnvironmentFile :: FilePath+userPackageEnvironmentFile = "cabal.config"++-- | Type of the current package environment.+data PackageEnvironmentType =+  SandboxPackageEnvironment   -- ^ './cabal.sandbox.config'+  | UserPackageEnvironment    -- ^ './cabal.config'+  | AmbientPackageEnvironment -- ^ '~/.cabal/config'++-- | Is there a 'cabal.sandbox.config' or 'cabal.config' in this+-- directory?+classifyPackageEnvironment :: FilePath -> Flag FilePath -> Flag Bool+                              -> IO PackageEnvironmentType+classifyPackageEnvironment pkgEnvDir sandboxConfigFileFlag ignoreSandboxFlag =+  do isSandbox <- liftM2 (||) (return forceSandboxConfig)+                  (configExists sandboxPackageEnvironmentFile)+     isUser    <- configExists userPackageEnvironmentFile+     return (classify isSandbox isUser)+  where+    configExists fname   = doesFileExist (pkgEnvDir </> fname)+    ignoreSandbox        = fromFlagOrDefault False ignoreSandboxFlag+    forceSandboxConfig   = isJust . flagToMaybe $ sandboxConfigFileFlag++    classify :: Bool -> Bool -> PackageEnvironmentType+    classify True _+      | not ignoreSandbox = SandboxPackageEnvironment+    classify _    True    = UserPackageEnvironment+    classify _    False   = AmbientPackageEnvironment++-- | Defaults common to 'initialPackageEnvironment' and+-- 'commentPackageEnvironment'.+commonPackageEnvironmentConfig :: FilePath -> SavedConfig+commonPackageEnvironmentConfig sandboxDir =+  mempty {+    savedConfigureFlags = mempty {+       -- TODO: Currently, we follow cabal-dev and set 'user-install: False' in+       -- the config file. In the future we may want to distinguish between+       -- global, sandbox and user install types.+       configUserInstall = toFlag False,+       configInstallDirs = installDirs+       },+    savedUserInstallDirs   = installDirs,+    savedGlobalInstallDirs = installDirs,+    savedGlobalFlags = mempty {+      globalLogsDir = toFlag $ sandboxDir </> "logs",+      -- Is this right? cabal-dev uses the global world file.+      globalWorldFile = toFlag $ sandboxDir </> "world"+      }+    }+  where+    installDirs = sandboxInstallDirs sandboxDir++-- | 'commonPackageEnvironmentConfig' wrapped inside a 'PackageEnvironment'.+commonPackageEnvironment :: FilePath -> PackageEnvironment+commonPackageEnvironment sandboxDir = mempty {+  pkgEnvSavedConfig = commonPackageEnvironmentConfig sandboxDir+  }++-- | Given a path to a sandbox, return the corresponding InstallDirs record.+sandboxInstallDirs :: FilePath -> InstallDirs (Flag PathTemplate)+sandboxInstallDirs sandboxDir = mempty {+  prefix = toFlag (toPathTemplate sandboxDir)+  }++-- | These are the absolute basic defaults, the fields that must be+-- initialised. When we load the package environment from the file we layer the+-- loaded values over these ones.+basePackageEnvironment :: PackageEnvironment+basePackageEnvironment =+    mempty {+      pkgEnvSavedConfig = mempty {+         savedConfigureFlags = mempty {+            configHcFlavor    = toFlag defaultCompiler,+            configVerbosity   = toFlag normal+            }+         }+      }++-- | Initial configuration that we write out to the package environment file if+-- it does not exist. When the package environment gets loaded this+-- configuration gets layered on top of 'basePackageEnvironment'.+initialPackageEnvironment :: FilePath -> Compiler -> Platform+                             -> IO PackageEnvironment+initialPackageEnvironment sandboxDir compiler platform = do+  defInstallDirs <- defaultInstallDirs (compilerFlavor compiler)+                    {- userInstall= -} False {- _hasLibs= -} False+  let initialConfig = commonPackageEnvironmentConfig sandboxDir+      installDirs   = combineInstallDirs (\d f -> Flag $ fromFlagOrDefault d f)+                      defInstallDirs (savedUserInstallDirs initialConfig)+  return $ mempty {+    pkgEnvSavedConfig = initialConfig {+       savedUserInstallDirs   = installDirs,+       savedGlobalInstallDirs = installDirs,+       savedGlobalFlags = (savedGlobalFlags initialConfig) {+          globalLocalRepos = [sandboxDir </> "packages"]+          },+       savedConfigureFlags = setPackageDB sandboxDir compiler platform+                             (savedConfigureFlags initialConfig),+       savedInstallFlags = (savedInstallFlags initialConfig) {+         installSummaryFile = [toPathTemplate (sandboxDir </>+                                               "logs" </> "build.log")]+         }+       }+    }++-- | Use the package DB location specific for this compiler.+setPackageDB :: FilePath -> Compiler -> Platform -> ConfigFlags -> ConfigFlags+setPackageDB sandboxDir compiler platform configFlags =+  configFlags {+    configPackageDBs = [Just (SpecificPackageDB $ sandboxDir+                              </> (Text.display platform ++ "-"+                                   ++ showCompilerId compiler+                                   ++ "-packages.conf.d"))]+    }++-- | Almost the same as 'savedConf `mappend` pkgEnv', but some settings are+-- overridden instead of mappend'ed.+overrideSandboxSettings :: PackageEnvironment -> PackageEnvironment ->+                           PackageEnvironment+overrideSandboxSettings pkgEnv0 pkgEnv =+  pkgEnv {+    pkgEnvSavedConfig = mappendedConf {+         savedConfigureFlags = (savedConfigureFlags mappendedConf) {+          configPackageDBs = configPackageDBs pkgEnvConfigureFlags+          }+       , savedInstallFlags = (savedInstallFlags mappendedConf) {+          installSummaryFile = installSummaryFile pkgEnvInstallFlags+          }+       },+    pkgEnvInherit = pkgEnvInherit pkgEnv0+    }+  where+    pkgEnvConf           = pkgEnvSavedConfig pkgEnv+    mappendedConf        = (pkgEnvSavedConfig pkgEnv0) `mappend` pkgEnvConf+    pkgEnvConfigureFlags = savedConfigureFlags pkgEnvConf+    pkgEnvInstallFlags   = savedInstallFlags pkgEnvConf++-- | Default values that get used if no value is given. Used here to include in+-- comments when we write out the initial package environment.+commentPackageEnvironment :: FilePath -> IO PackageEnvironment+commentPackageEnvironment sandboxDir = do+  commentConf  <- commentSavedConfig+  let baseConf =  commonPackageEnvironmentConfig sandboxDir+  return $ mempty {+    pkgEnvSavedConfig = commentConf `mappend` baseConf+    }++-- | If this package environment inherits from some other package environment,+-- return that package environment; otherwise return mempty.+inheritedPackageEnvironment :: Verbosity -> PackageEnvironment+                               -> IO PackageEnvironment+inheritedPackageEnvironment verbosity pkgEnv = do+  case (pkgEnvInherit pkgEnv) of+    NoFlag                -> return mempty+    confPathFlag@(Flag _) -> do+      conf <- loadConfig verbosity confPathFlag NoFlag+      return $ mempty { pkgEnvSavedConfig = conf }++-- | Load the user package environment if it exists (the optional "cabal.config"+-- file).+userPackageEnvironment :: Verbosity -> FilePath -> IO PackageEnvironment+userPackageEnvironment verbosity pkgEnvDir = do+  let path = pkgEnvDir </> userPackageEnvironmentFile+  minp <- readPackageEnvironmentFile mempty path+  case minp of+    Nothing -> return mempty+    Just (ParseOk warns parseResult) -> do+      when (not $ null warns) $ warn verbosity $+        unlines (map (showPWarning path) warns)+      return parseResult+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      warn verbosity $ "Error parsing user package environment file " ++ path+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg+      return mempty++-- | Same as @userPackageEnvironmentFile@, but returns a SavedConfig.+loadUserConfig :: Verbosity -> FilePath -> IO SavedConfig+loadUserConfig verbosity pkgEnvDir = fmap pkgEnvSavedConfig+                                     $ userPackageEnvironment verbosity pkgEnvDir++-- | Common error handling code used by 'tryLoadSandboxPackageEnvironment' and+-- 'updatePackageEnvironment'.+handleParseResult :: Verbosity -> FilePath+                     -> Maybe (ParseResult PackageEnvironment)+                     -> IO PackageEnvironment+handleParseResult verbosity path minp =+  case minp of+    Nothing -> die $+      "The package environment file '" ++ path ++ "' doesn't exist"+    Just (ParseOk warns parseResult) -> do+      when (not $ null warns) $ warn verbosity $+        unlines (map (showPWarning path) warns)+      return parseResult+    Just (ParseFailed err) -> do+      let (line, msg) = locatedErrorMsg err+      die $ "Error parsing package environment file " ++ path+        ++ maybe "" (\n -> ":" ++ show n) line ++ ":\n" ++ msg++-- | Try to load the given package environment file, exiting with error if it+-- doesn't exist. Also returns the path to the sandbox directory. The path+-- parameter should refer to an existing file.+tryLoadSandboxPackageEnvironmentFile :: Verbosity -> FilePath -> (Flag FilePath)+                                        -> IO (FilePath, PackageEnvironment)+tryLoadSandboxPackageEnvironmentFile verbosity pkgEnvFile configFileFlag = do+  let pkgEnvDir = takeDirectory pkgEnvFile+  minp   <- readPackageEnvironmentFile mempty pkgEnvFile+  pkgEnv <- handleParseResult verbosity pkgEnvFile minp++  -- Get the saved sandbox directory.+  -- TODO: Use substPathTemplate with compilerTemplateEnv ++ platformTemplateEnv.+  let sandboxDir = fromFlagOrDefault defaultSandboxLocation+                   . fmap fromPathTemplate . prefix . savedUserInstallDirs+                   . pkgEnvSavedConfig $ pkgEnv++  -- Do some sanity checks+  dirExists            <- doesDirectoryExist sandboxDir+  -- TODO: Also check for an initialised package DB?+  unless dirExists $+    die ("No sandbox exists at " ++ sandboxDir)+  info verbosity $ "Using a sandbox located at " ++ sandboxDir++  let base   = basePackageEnvironment+  let common = commonPackageEnvironment sandboxDir+  user      <- userPackageEnvironment verbosity pkgEnvDir+  inherited <- inheritedPackageEnvironment verbosity user++  -- Layer the package environment settings over settings from ~/.cabal/config.+  cabalConfig <- fmap unsetSymlinkBinDir $+                 loadConfig verbosity configFileFlag NoFlag+  return (sandboxDir,+          updateInstallDirs $+          (base `mappend` (toPkgEnv cabalConfig) `mappend`+           common `mappend` inherited `mappend` user)+          `overrideSandboxSettings` pkgEnv)+    where+      toPkgEnv config = mempty { pkgEnvSavedConfig = config }++      updateInstallDirs pkgEnv =+        let config         = pkgEnvSavedConfig    pkgEnv+            configureFlags = savedConfigureFlags  config+            installDirs    = savedUserInstallDirs config+        in pkgEnv {+          pkgEnvSavedConfig = config {+             savedConfigureFlags = configureFlags {+                configInstallDirs = installDirs+                }+             }+          }++      -- We don't want to inherit the value of 'symlink-bindir' from+      -- '~/.cabal/config'. See #1514.+      unsetSymlinkBinDir config =+        let installFlags = savedInstallFlags config+        in config {+          savedInstallFlags = installFlags {+             installSymlinkBinDir = NoFlag+             }+          }++-- | Should the generated package environment file include comments?+data IncludeComments = IncludeComments | NoComments++-- | Create a new package environment file, replacing the existing one if it+-- exists. Note that the path parameters should point to existing directories.+createPackageEnvironmentFile :: Verbosity -> FilePath -> FilePath+                                -> IncludeComments+                                -> Compiler+                                -> Platform+                                -> IO ()+createPackageEnvironmentFile verbosity sandboxDir pkgEnvFile incComments+  compiler platform = do+  notice verbosity $ "Writing a default package environment file to "+    ++ pkgEnvFile++  commentPkgEnv <- commentPackageEnvironment sandboxDir+  initialPkgEnv <- initialPackageEnvironment sandboxDir compiler platform+  writePackageEnvironmentFile pkgEnvFile incComments commentPkgEnv initialPkgEnv++-- | Descriptions of all fields in the package environment file.+pkgEnvFieldDescrs :: [FieldDescr PackageEnvironment]+pkgEnvFieldDescrs = [+  simpleField "inherit"+    (fromFlagOrDefault Disp.empty . fmap Disp.text) (optional parseFilePathQ)+    pkgEnvInherit (\v pkgEnv -> pkgEnv { pkgEnvInherit = v })++    -- FIXME: Should we make these fields part of ~/.cabal/config ?+  , commaListField "constraints"+    Text.disp Text.parse+    (configExConstraints . savedConfigureExFlags . pkgEnvSavedConfig)+    (\v pkgEnv -> updateConfigureExFlags pkgEnv+                  (\flags -> flags { configExConstraints = v }))++  , commaListField "preferences"+    Text.disp Text.parse+    (configPreferences . savedConfigureExFlags . pkgEnvSavedConfig)+    (\v pkgEnv -> updateConfigureExFlags pkgEnv+                  (\flags -> flags { configPreferences = v }))+  ]+  ++ map toPkgEnv configFieldDescriptions'+  ++ map toPkgEnv programOptionsFields+  where+    optional = Parse.option mempty . fmap toFlag++    configFieldDescriptions' :: [FieldDescr SavedConfig]+    configFieldDescriptions' = filter+      (\(FieldDescr name _ _) -> name /= "preference" && name /= "constraint")+      configFieldDescriptions++    programOptionsFields :: [FieldDescr SavedConfig]+    programOptionsFields =+      map viewAsFieldDescr $+      programConfigurationOptions defaultProgramConfiguration ParseArgs+      (configProgramArgs . savedConfigureFlags)+      (\v cfg -> cfg { savedConfigureFlags =+                          (savedConfigureFlags cfg) { configProgramArgs = v } })++    toPkgEnv :: FieldDescr SavedConfig -> FieldDescr PackageEnvironment+    toPkgEnv fieldDescr =+      liftField pkgEnvSavedConfig+      (\savedConfig pkgEnv -> pkgEnv { pkgEnvSavedConfig = savedConfig})+      fieldDescr++    updateConfigureExFlags :: PackageEnvironment+                              -> (ConfigExFlags -> ConfigExFlags)+                              -> PackageEnvironment+    updateConfigureExFlags pkgEnv f = pkgEnv {+      pkgEnvSavedConfig = (pkgEnvSavedConfig pkgEnv) {+         savedConfigureExFlags = f . savedConfigureExFlags . pkgEnvSavedConfig+                                 $ pkgEnv+         }+      }++-- | Read the package environment file.+readPackageEnvironmentFile :: PackageEnvironment -> FilePath+                              -> IO (Maybe (ParseResult PackageEnvironment))+readPackageEnvironmentFile initial file =+  handleNotExists $+  fmap (Just . parsePackageEnvironment initial) (readFile file)+  where+    handleNotExists action = catchIO action $ \ioe ->+      if isDoesNotExistError ioe+        then return Nothing+        else ioError ioe++-- | Parse the package environment file.+parsePackageEnvironment :: PackageEnvironment -> String+                           -> ParseResult PackageEnvironment+parsePackageEnvironment initial str = do+  fields <- readFields str+  let (knownSections, others) = partition isKnownSection fields+  pkgEnv <- parse others+  let config       = pkgEnvSavedConfig pkgEnv+      installDirs0 = savedUserInstallDirs config+  -- 'install-dirs' is the only section that we care about.+  installDirs <- foldM parseSection installDirs0 knownSections+  return pkgEnv {+    pkgEnvSavedConfig = config {+       savedUserInstallDirs   = installDirs,+       savedGlobalInstallDirs = installDirs+       }+    }++  where+    isKnownSection :: ParseUtils.Field -> Bool+    isKnownSection (ParseUtils.Section _ "install-dirs" _ _) = True+    isKnownSection _                                         = False++    parse :: [ParseUtils.Field] -> ParseResult PackageEnvironment+    parse = parseFields pkgEnvFieldDescrs initial++    parseSection :: InstallDirs (Flag PathTemplate)+                    -> ParseUtils.Field+                    -> ParseResult (InstallDirs (Flag PathTemplate))+    parseSection accum (ParseUtils.Section line "install-dirs" name fs)+      | name' == "" = do accum' <- parseFields installDirsFields accum fs+                         return accum'+      | otherwise   =+        syntaxError line $+        "Named 'install-dirs' section: '" ++ name+        ++ "'. Note that named 'install-dirs' sections are not allowed in the '"+        ++ userPackageEnvironmentFile ++ "' file."+      where name' = lowercase name+    parseSection _accum f =+      syntaxError (lineNo f)  "Unrecognized stanza."++-- | Write out the package environment file.+writePackageEnvironmentFile :: FilePath -> IncludeComments+                               -> PackageEnvironment -> PackageEnvironment+                               -> IO ()+writePackageEnvironmentFile path incComments comments pkgEnv = do+  let tmpPath = (path <.> "tmp")+  writeFile tmpPath $ explanation ++ pkgEnvStr ++ "\n"+  renameFile tmpPath path+  where+    pkgEnvStr = case incComments of+      IncludeComments -> showPackageEnvironmentWithComments+                         (Just comments) pkgEnv+      NoComments      -> showPackageEnvironment pkgEnv+    explanation = unlines+      ["-- This is a Cabal package environment file."+      ,"-- THIS FILE IS AUTO-GENERATED. DO NOT EDIT DIRECTLY."+      ,"-- Please create a 'cabal.config' file in the same directory"+      ,"-- if you want to change the default settings for this sandbox."+      ,"",""+      ]++-- | Pretty-print the package environment.+showPackageEnvironment :: PackageEnvironment -> String+showPackageEnvironment pkgEnv = showPackageEnvironmentWithComments Nothing pkgEnv++-- | Pretty-print the package environment with default values for empty fields+-- commented out (just like the default ~/.cabal/config).+showPackageEnvironmentWithComments :: (Maybe PackageEnvironment)+                                      -> PackageEnvironment+                                      -> String+showPackageEnvironmentWithComments mdefPkgEnv pkgEnv = Disp.render $+      ppFields pkgEnvFieldDescrs mdefPkgEnv pkgEnv+  $+$ Disp.text ""+  $+$ ppSection "install-dirs" "" installDirsFields+                (fmap installDirsSection mdefPkgEnv) (installDirsSection pkgEnv)+  where+    installDirsSection = savedUserInstallDirs . pkgEnvSavedConfig
+ cabal/cabal-install/Distribution/Client/Sandbox/Timestamp.hs view
@@ -0,0 +1,288 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.Timestamp+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Timestamp file handling (for add-source dependencies).+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.Timestamp (+  AddSourceTimestamp,+  withAddTimestamps,+  withRemoveTimestamps,+  withUpdateTimestamps,+  maybeAddCompilerTimestampRecord,+  isDepModified,+  listModifiedDeps,+  ) where++import Control.Monad                                 (filterM, forM, when)+import Data.Char                                     (isSpace)+import Data.List                                     (partition)+import System.Directory                              (renameFile)+import System.FilePath                               ((<.>), (</>))+import qualified Data.Map as M++import Distribution.Compiler                         (CompilerId)+import Distribution.Package                          (packageName)+import Distribution.PackageDescription.Configuration (flattenPackageDescription)+import Distribution.PackageDescription.Parse         (readPackageDescription)+import Distribution.Simple.Setup                     (Flag (..),+                                                      SDistFlags (..),+                                                      defaultSDistFlags,+                                                      sdistCommand)+import Distribution.Simple.Utils                     (debug, die,+                                                      tryFindPackageDesc, warn)+import Distribution.System                           (Platform)+import Distribution.Text                             (display)+import Distribution.Verbosity                        (Verbosity, lessVerbose,+                                                      normal)+import Distribution.Version                          (Version (..),+                                                      orLaterVersion)++import Distribution.Client.Sandbox.Index+  (ListIgnoredBuildTreeRefs (DontListIgnored), RefTypesToList(OnlyLinks)+  ,listBuildTreeRefs)+import Distribution.Client.SetupWrapper              (SetupScriptOptions (..),+                                                      defaultSetupScriptOptions,+                                                      setupWrapper)+import Distribution.Client.Utils                     (inDir, removeExistingFile,+                                                      tryCanonicalizePath)++import Distribution.Compat.Exception                 (catchIO)+import Distribution.Client.Compat.Time               (EpochTime, getCurTime,+                                                      getModTime)+++-- | Timestamp of an add-source dependency.+type AddSourceTimestamp  = (FilePath, EpochTime)+-- | Timestamp file record - a string identifying the compiler & platform plus a+-- list of add-source timestamps.+type TimestampFileRecord = (String, [AddSourceTimestamp])++timestampRecordKey :: CompilerId -> Platform -> String+timestampRecordKey compId platform = display platform ++ "-" ++ display compId++-- | The 'add-source-timestamps' file keeps the timestamps of all add-source+-- dependencies. It is initially populated by 'sandbox add-source' and kept+-- current by 'reinstallAddSourceDeps' and 'configure -w'. The user can install+-- add-source deps manually with 'cabal install' after having edited them, so we+-- can err on the side of caution sometimes.+-- FIXME: We should keep this info in the index file, together with build tree+-- refs.+timestampFileName :: FilePath+timestampFileName = "add-source-timestamps"++-- | Read the timestamp file. Exits with error if the timestamp file is+-- corrupted. Returns an empty list if the file doesn't exist.+readTimestampFile :: FilePath -> IO [TimestampFileRecord]+readTimestampFile timestampFile = do+  timestampString <- readFile timestampFile `catchIO` \_ -> return "[]"+  case reads timestampString of+    [(timestamps, s)] | all isSpace s -> return timestamps+    _                                 ->+      die $ "The timestamps file is corrupted. "+      ++ "Please delete & recreate the sandbox."++-- | Write the timestamp file, atomically.+writeTimestampFile :: FilePath -> [TimestampFileRecord] -> IO ()+writeTimestampFile timestampFile timestamps = do+  writeFile  timestampTmpFile (show timestamps)+  renameFile timestampTmpFile timestampFile+  where+    timestampTmpFile = timestampFile <.> "tmp"++-- | Read, process and write the timestamp file in one go.+withTimestampFile :: FilePath+                     -> ([TimestampFileRecord] -> IO [TimestampFileRecord])+                     -> IO ()+withTimestampFile sandboxDir process = do+  let timestampFile = sandboxDir </> timestampFileName+  timestampRecords <- readTimestampFile timestampFile >>= process+  writeTimestampFile timestampFile timestampRecords++-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps+-- we've added and an initial timestamp, add an 'AddSourceTimestamp' to the list+-- for each path. If a timestamp for a given path already exists in the list,+-- update it.+addTimestamps :: EpochTime -> [AddSourceTimestamp] -> [FilePath]+                 -> [AddSourceTimestamp]+addTimestamps initial timestamps newPaths =+  [ (p, initial) | p <- newPaths ] ++ oldTimestamps+  where+    (oldTimestamps, _toBeUpdated) =+      partition (\(path, _) -> path `notElem` newPaths) timestamps++-- | Given a list of 'AddSourceTimestamp's, a list of paths to add-source deps+-- we've reinstalled and a new timestamp value, update the timestamp value for+-- the deps in the list. If there are new paths in the list, ignore them.+updateTimestamps :: [AddSourceTimestamp] -> [FilePath] -> EpochTime+                    -> [AddSourceTimestamp]+updateTimestamps timestamps pathsToUpdate newTimestamp =+  foldr updateTimestamp [] timestamps+  where+    updateTimestamp t@(path, _oldTimestamp) rest+      | path `elem` pathsToUpdate = (path, newTimestamp) : rest+      | otherwise                 = t : rest++-- | Given a list of 'TimestampFileRecord's and a list of paths to add-source+-- deps we've removed, remove those deps from the list.+removeTimestamps :: [AddSourceTimestamp] -> [FilePath] -> [AddSourceTimestamp]+removeTimestamps l pathsToRemove = foldr removeTimestamp [] l+  where+    removeTimestamp t@(path, _oldTimestamp) rest =+      if path `elem` pathsToRemove+      then rest+      else t : rest++-- | If a timestamp record for this compiler doesn't exist, add a new one.+maybeAddCompilerTimestampRecord :: Verbosity -> FilePath -> FilePath+                                   -> CompilerId -> Platform+                                   -> IO ()+maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+                                compId platform = do+  buildTreeRefs <- listBuildTreeRefs verbosity DontListIgnored OnlyLinks+                                     indexFile+  withTimestampFile sandboxDir $ \timestampRecords -> do+    let key = timestampRecordKey compId platform+    case lookup key timestampRecords of+      Just _  -> return timestampRecords+      Nothing -> do now <- getCurTime+                    let timestamps = map (\p -> (p, now)) buildTreeRefs+                    return $ (key, timestamps):timestampRecords++-- | Given an IO action that returns a list of build tree refs, add those+-- build tree refs to the timestamps file (for all compilers).+withAddTimestamps :: FilePath -> IO [FilePath] -> IO ()+withAddTimestamps sandboxDir act = do+  let initialTimestamp = 0+  withActionOnAllTimestamps (addTimestamps initialTimestamp) sandboxDir act++-- | Given an IO action that returns a list of build tree refs, remove those+-- build tree refs from the timestamps file (for all compilers).+withRemoveTimestamps :: FilePath -> IO [FilePath] -> IO ()+withRemoveTimestamps = withActionOnAllTimestamps removeTimestamps++-- | Given an IO action that returns a list of build tree refs, update the+-- timestamps of the returned build tree refs to the current time (only for the+-- given compiler & platform).+withUpdateTimestamps :: FilePath -> CompilerId -> Platform+                        ->([AddSourceTimestamp] -> IO [FilePath])+                        -> IO ()+withUpdateTimestamps =+  withActionOnCompilerTimestamps updateTimestamps++-- | Helper for implementing 'withAddTimestamps' and+-- 'withRemoveTimestamps'. Runs a given action on the list of+-- 'AddSourceTimestamp's for all compilers, applies 'f' to the result and then+-- updates the timestamp file. The IO action is run only once.+withActionOnAllTimestamps :: ([AddSourceTimestamp] -> [FilePath]+                              -> [AddSourceTimestamp])+                             -> FilePath+                             -> IO [FilePath]+                             -> IO ()+withActionOnAllTimestamps f sandboxDir act =+  withTimestampFile sandboxDir $ \timestampRecords -> do+    paths <- act+    return [(key, f timestamps paths) | (key, timestamps) <- timestampRecords]++-- | Helper for implementing 'withUpdateTimestamps'. Runs a given action on the+-- list of 'AddSourceTimestamp's for this compiler, applies 'f' to the result+-- and then updates the timestamp file record. The IO action is run only once.+withActionOnCompilerTimestamps :: ([AddSourceTimestamp]+                                   -> [FilePath] -> EpochTime+                                   -> [AddSourceTimestamp])+                                  -> FilePath+                                  -> CompilerId+                                  -> Platform+                                  -> ([AddSourceTimestamp] -> IO [FilePath])+                                  -> IO ()+withActionOnCompilerTimestamps f sandboxDir compId platform act = do+  let needle = timestampRecordKey compId platform+  withTimestampFile sandboxDir $ \timestampRecords -> do+    timestampRecords' <- forM timestampRecords $ \r@(key, timestamps) ->+      if key == needle+      then do paths <- act timestamps+              now   <- getCurTime+              return (key, f timestamps paths now)+      else return r+    return timestampRecords'++-- | List all source files of a given add-source dependency. Exits with error if+-- something is wrong (e.g. there is no .cabal file in the given directory).+-- FIXME: This function is not thread-safe because of 'inDir'.+allPackageSourceFiles :: Verbosity -> FilePath -> IO [FilePath]+allPackageSourceFiles verbosity packageDir = inDir (Just packageDir) $ do+  pkg <- fmap (flattenPackageDescription)+         . readPackageDescription verbosity =<< tryFindPackageDesc packageDir++  let file      = "cabal-sdist-list-sources"+      flags     = defaultSDistFlags {+        sDistVerbosity   = Flag $ if verbosity == normal+                                  then lessVerbose verbosity else verbosity,+        sDistListSources = Flag file+        }+      setupOpts = defaultSetupScriptOptions {+        -- 'sdist --list-sources' was introduced in Cabal 1.18.+        useCabalVersion = orLaterVersion $ Version [1,18,0] []+        }++      doListSources :: IO [FilePath]+      doListSources = do+        setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags) []+        srcs <- fmap lines . readFile $ file+        mapM tryCanonicalizePath srcs++      onFailedListSources :: IO ()+      onFailedListSources = warn verbosity $+          "Could not list sources of the add-source dependency '"+          ++ display (packageName pkg) ++ "'. Skipping the timestamp check."++  -- Run setup sdist --list-sources=TMPFILE+  ret <- doListSources `catchIO` (\_ -> onFailedListSources >> return [])+  removeExistingFile file+  return ret++-- | Has this dependency been modified since we have last looked at it?+isDepModified :: Verbosity -> EpochTime -> AddSourceTimestamp -> IO Bool+isDepModified verbosity now (packageDir, timestamp) = do+  debug verbosity ("Checking whether the dependency is modified: " ++ packageDir)+  depSources <- allPackageSourceFiles verbosity packageDir+  go depSources++  where+    go []         = return False+    go (dep:rest) = do+      -- FIXME: What if the clock jumps backwards at any point? For now we only+      -- print a warning.+      modTime <- getModTime dep+      when (modTime > now) $+        warn verbosity $ "File '" ++ dep+                         ++ "' has a modification time that is in the future."+      if modTime >= timestamp+        then do+          debug verbosity ("Dependency has a modified source file: " ++ dep)+          return True+        else go rest++-- | List all modified dependencies.+listModifiedDeps :: Verbosity -> FilePath -> CompilerId -> Platform+                    -> M.Map FilePath a+                       -- ^ The set of all installed add-source deps.+                    -> IO [FilePath]+listModifiedDeps verbosity sandboxDir compId platform installedDepsMap = do+  timestampRecords <- readTimestampFile (sandboxDir </> timestampFileName)+  let needle        = timestampRecordKey compId platform+  timestamps       <- maybe noTimestampRecord return+                      (lookup needle timestampRecords)+  now <- getCurTime+  fmap (map fst) . filterM (isDepModified verbosity now)+    . filter (\ts -> fst ts `M.member` installedDepsMap)+    $ timestamps++  where+    noTimestampRecord = die $ "Сouldn't find a timestamp record for the given "+                        ++ "compiler/platform pair. "+                        ++ "Please report this on the Cabal bug tracker: "+                        ++ "https://github.com/haskell/cabal/issues/new ."
+ cabal/cabal-install/Distribution/Client/Sandbox/Types.hs view
@@ -0,0 +1,61 @@+-----------------------------------------------------------------------------+-- |+-- Module      :  Distribution.Client.Sandbox.Types+-- Maintainer  :  cabal-devel@haskell.org+-- Portability :  portable+--+-- Helpers for writing code that works both inside and outside a sandbox.+-----------------------------------------------------------------------------++module Distribution.Client.Sandbox.Types (+  UseSandbox(..), isUseSandbox, whenUsingSandbox,+  SandboxPackageInfo(..)+  ) where++import qualified Distribution.Simple.PackageIndex as InstalledPackageIndex+import Distribution.Client.Types (SourcePackage)++import Data.Monoid+import qualified Data.Set as S++-- | Are we using a sandbox?+data UseSandbox = UseSandbox FilePath | NoSandbox++instance Monoid UseSandbox where+  mempty = NoSandbox++  NoSandbox        `mappend` s                  = s+  u0@(UseSandbox _) `mappend` NoSandbox         = u0+  (UseSandbox   _)  `mappend` u1@(UseSandbox _) = u1++-- | Convert a @UseSandbox@ value to a boolean. Useful in conjunction with+-- @when@.+isUseSandbox :: UseSandbox -> Bool+isUseSandbox (UseSandbox _) = True+isUseSandbox NoSandbox      = False++-- | Execute an action only if we're in a sandbox, feeding to it the path to the+-- sandbox directory.+whenUsingSandbox :: UseSandbox -> (FilePath -> IO ()) -> IO ()+whenUsingSandbox NoSandbox               _   = return ()+whenUsingSandbox (UseSandbox sandboxDir) act = act sandboxDir++-- | Data about the packages installed in the sandbox that is passed from+-- 'reinstallAddSourceDeps' to the solver.+data SandboxPackageInfo = SandboxPackageInfo {+  modifiedAddSourceDependencies :: ![SourcePackage],+  -- ^ Modified add-source deps that we want to reinstall. These are guaranteed+  -- to be already installed in the sandbox.++  otherAddSourceDependencies    :: ![SourcePackage],+  -- ^ Remaining add-source deps. Some of these may be not installed in the+  -- sandbox.++  otherInstalledSandboxPackages :: !InstalledPackageIndex.PackageIndex,+  -- ^ All packages installed in the sandbox. Intersection with+  -- 'modifiedAddSourceDependencies' and/or 'otherAddSourceDependencies' can be+  -- non-empty.++  allAddSourceDependencies      :: !(S.Set FilePath)+  -- ^ A set of paths to all add-source dependencies, for convenience.+  }
cabal/cabal-install/Distribution/Client/Setup.hs view
@@ -11,28 +11,28 @@ -- ----------------------------------------------------------------------------- module Distribution.Client.Setup-    ( globalCommand, GlobalFlags(..), globalRepos+    ( globalCommand, GlobalFlags(..), defaultGlobalFlags, globalRepos     , configureCommand, ConfigFlags(..), filterConfigureFlags     , configureExCommand, ConfigExFlags(..), defaultConfigExFlags                         , configureExOptions-    , buildCommand, BuildFlags(..)+    , buildCommand, BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+    , testCommand, benchmarkCommand     , installCommand, InstallFlags(..), installOptions, defaultInstallFlags     , listCommand, ListFlags(..)     , updateCommand     , upgradeCommand     , infoCommand, InfoFlags(..)     , fetchCommand, FetchFlags(..)+    , freezeCommand, FreezeFlags(..)+    , getCommand, unpackCommand, GetFlags(..)     , checkCommand     , uploadCommand, UploadFlags(..)     , reportCommand, ReportFlags(..)-    , unpackCommand, UnpackFlags(..)+    , runCommand     , initCommand, IT.InitFlags(..)     , sdistCommand, SDistFlags(..), SDistExFlags(..), ArchiveFormat(..)     , win32SelfUpgradeCommand, Win32SelfUpgradeFlags(..)-    , indexCommand, IndexFlags(..)-    , dumpPkgEnvCommand, sandboxConfigureCommand, sandboxAddSourceCommand-    , sandboxBuildCommand, sandboxInstallCommand, defaultSandboxLocation-    , SandboxFlags(..)+    , sandboxCommand, defaultSandboxLocation, SandboxFlags(..)      , parsePackageArgs     --TODO: stop exporting these:@@ -45,35 +45,39 @@ import Distribution.Client.BuildReports.Types          ( ReportLevel(..) ) import Distribution.Client.Dependency.Types-         ( PreSolver(..) )+         ( AllowNewer(..), PreSolver(..) ) import qualified Distribution.Client.Init.Types as IT          ( InitFlags(..), PackageType(..) ) import Distribution.Client.Targets          ( UserConstraint, readUserConstraint ) +import Distribution.Simple.Compiler (PackageDB) import Distribution.Simple.Program          ( defaultProgramConfiguration )-import Distribution.Simple.Command hiding (boolOpt)+import Distribution.Simple.Command hiding (boolOpt, boolOpt')+import qualified Distribution.Simple.Command as Command import qualified Distribution.Simple.Setup as Cabal-         ( configureCommand, buildCommand, sdistCommand, haddockCommand-         , buildOptions, defaultBuildFlags ) import Distribution.Simple.Setup-         ( ConfigFlags(..), BuildFlags(..), SDistFlags(..), HaddockFlags(..) )-import Distribution.Simple.Setup-         ( Flag(..), toFlag, fromFlag, flagToMaybe, flagToList-         , optionVerbosity, boolOpt, trueArg, falseArg )+         ( ConfigFlags(..), BuildFlags(..), TestFlags(..), BenchmarkFlags(..)+         , SDistFlags(..), HaddockFlags(..)+         , readPackageDbList, showPackageDbList+         , Flag(..), toFlag, fromFlag, flagToMaybe, flagToList+         , optionVerbosity, boolOpt, boolOpt', trueArg, falseArg, optionNumJobs ) import Distribution.Simple.InstallDirs-         ( PathTemplate, toPathTemplate, fromPathTemplate )+         ( PathTemplate, InstallDirs(sysconfdir)+         , toPathTemplate, fromPathTemplate ) import Distribution.Version          ( Version(Version), anyVersion, thisVersion ) import Distribution.Package          ( PackageIdentifier, packageName, packageVersion, Dependency(..) )+import Distribution.PackageDescription+         ( RepoKind(..) ) import Distribution.Text          ( Text(..), display ) import Distribution.ReadE          ( ReadE(..), readP_to_E, succeedReadE ) import qualified Distribution.Compat.ReadP as Parse-         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, (+++) )+         ( ReadP, readP_to_S, readS_to_P, char, munch1, pfail, sepBy1, (+++) ) import Distribution.Verbosity          ( Verbosity, normal ) import Distribution.Simple.Utils@@ -100,26 +104,32 @@  -- | Flags that apply at the top level, not to any sub-command. data GlobalFlags = GlobalFlags {-    globalVersion        :: Flag Bool,-    globalNumericVersion :: Flag Bool,-    globalConfigFile     :: Flag FilePath,-    globalRemoteRepos    :: [RemoteRepo],     -- ^ Available Hackage servers.-    globalCacheDir       :: Flag FilePath,-    globalLocalRepos     :: [FilePath],-    globalLogsDir        :: Flag FilePath,-    globalWorldFile      :: Flag FilePath+    globalVersion           :: Flag Bool,+    globalNumericVersion    :: Flag Bool,+    globalConfigFile        :: Flag FilePath,+    globalSandboxConfigFile :: Flag FilePath,+    globalRemoteRepos       :: [RemoteRepo],     -- ^ Available Hackage servers.+    globalCacheDir          :: Flag FilePath,+    globalLocalRepos        :: [FilePath],+    globalLogsDir           :: Flag FilePath,+    globalWorldFile         :: Flag FilePath,+    globalRequireSandbox    :: Flag Bool,+    globalIgnoreSandbox     :: Flag Bool   }  defaultGlobalFlags :: GlobalFlags defaultGlobalFlags  = GlobalFlags {-    globalVersion        = Flag False,-    globalNumericVersion = Flag False,-    globalConfigFile     = mempty,-    globalRemoteRepos    = [],-    globalCacheDir       = mempty,-    globalLocalRepos     = mempty,-    globalLogsDir        = mempty,-    globalWorldFile      = mempty+    globalVersion           = Flag False,+    globalNumericVersion    = Flag False,+    globalConfigFile        = mempty,+    globalSandboxConfigFile = mempty,+    globalRemoteRepos       = mempty,+    globalCacheDir          = mempty,+    globalLocalRepos        = mempty,+    globalLogsDir           = mempty,+    globalWorldFile         = mempty,+    globalRequireSandbox    = Flag False,+    globalIgnoreSandbox     = Flag False   }  globalCommand :: CommandUI GlobalFlags@@ -137,9 +147,9 @@       ++ "  " ++ pname ++ " install foo [--dry-run]\n\n"       ++ "Occasionally you need to update the list of available packages:\n"       ++ "  " ++ pname ++ " update\n",-    commandDefaultFlags = defaultGlobalFlags,+    commandDefaultFlags = mempty,     commandOptions      = \showOrParseArgs ->-      (case showOrParseArgs of ShowArgs -> take 2; ParseArgs -> id)+      (case showOrParseArgs of ShowArgs -> take 6; ParseArgs -> id)       [option ['V'] ["version"]          "Print version information"          globalVersion (\v flags -> flags { globalVersion = v })@@ -155,6 +165,22 @@          globalConfigFile (\v flags -> flags { globalConfigFile = v })          (reqArgFlag "FILE") +      ,option [] ["sandbox-config-file"]+         "Set an alternate location for the sandbox config file \+         \(default: './cabal.sandbox.config')"+         globalConfigFile (\v flags -> flags { globalSandboxConfigFile = v })+         (reqArgFlag "FILE")++      ,option [] ["require-sandbox"]+         "requiring the presence of a sandbox for sandbox-aware commands"+         globalRequireSandbox (\v flags -> flags { globalRequireSandbox = v })+         (boolOpt' ([], ["require-sandbox"]) ([], ["no-require-sandbox"]))++      ,option [] ["ignore-sandbox"]+         "Ignore any existing sandbox"+         globalIgnoreSandbox (\v flags -> flags { globalIgnoreSandbox = v })+         trueArg+       ,option [] ["remote-repo"]          "The name and url for a remote repository"          globalRemoteRepos (\v flags -> flags { globalRemoteRepos = v })@@ -184,24 +210,30 @@  instance Monoid GlobalFlags where   mempty = GlobalFlags {-    globalVersion        = mempty,-    globalNumericVersion = mempty,-    globalConfigFile     = mempty,-    globalRemoteRepos    = mempty,-    globalCacheDir       = mempty,-    globalLocalRepos     = mempty,-    globalLogsDir        = mempty,-    globalWorldFile      = mempty+    globalVersion           = mempty,+    globalNumericVersion    = mempty,+    globalConfigFile        = mempty,+    globalSandboxConfigFile = mempty,+    globalRemoteRepos       = mempty,+    globalCacheDir          = mempty,+    globalLocalRepos        = mempty,+    globalLogsDir           = mempty,+    globalWorldFile         = mempty,+    globalRequireSandbox    = mempty,+    globalIgnoreSandbox     = mempty   }   mappend a b = GlobalFlags {-    globalVersion        = combine globalVersion,-    globalNumericVersion = combine globalNumericVersion,-    globalConfigFile     = combine globalConfigFile,-    globalRemoteRepos    = combine globalRemoteRepos,-    globalCacheDir       = combine globalCacheDir,-    globalLocalRepos     = combine globalLocalRepos,-    globalLogsDir        = combine globalLogsDir,-    globalWorldFile      = combine globalWorldFile+    globalVersion           = combine globalVersion,+    globalNumericVersion    = combine globalNumericVersion,+    globalConfigFile        = combine globalConfigFile,+    globalSandboxConfigFile = combine globalConfigFile,+    globalRemoteRepos       = combine globalRemoteRepos,+    globalCacheDir          = combine globalCacheDir,+    globalLocalRepos        = combine globalLocalRepos,+    globalLogsDir           = combine globalLogsDir,+    globalWorldFile         = combine globalWorldFile,+    globalRequireSandbox    = combine globalRequireSandbox,+    globalIgnoreSandbox     = combine globalIgnoreSandbox   }     where combine field = field a `mappend` field b @@ -231,10 +263,34 @@  filterConfigureFlags :: ConfigFlags -> Version -> ConfigFlags filterConfigureFlags flags cabalLibVersion-  | cabalLibVersion >= Version [1,3,10] [] = flags-    -- older Cabal does not grok the constraints flag:-  | otherwise = flags { configConstraints = [] }+  | cabalLibVersion >= Version [1,19,2] [] = flags_latest+  | cabalLibVersion <  Version [1,3,10] [] = flags_1_3_10+  | cabalLibVersion <  Version [1,10,0] [] = flags_1_10_0+  | cabalLibVersion <  Version [1,14,0] [] = flags_1_14_0+  | cabalLibVersion <  Version [1,18,0] [] = flags_1_18_0+  | cabalLibVersion <  Version [1,19,1] [] = flags_1_19_0+  | cabalLibVersion <  Version [1,19,2] [] = flags_1_19_1+  | otherwise = flags_latest+  where+    -- Cabal >= 1.19.1 uses '--dependency' and does not need '--constraint'.+    flags_latest = flags        { configConstraints = [] } +    -- Cabal < 1.19.2 doesn't know about '--exact-configuration'.+    flags_1_19_1 = flags_latest { configExactConfiguration = NoFlag }+    -- Cabal < 1.19.1 uses '--constraint' instead of '--dependency'.+    flags_1_19_0 = flags_1_19_1 { configDependencies = []+                                , configConstraints  = configConstraints flags }+    -- Cabal < 1.18.0 doesn't know about --extra-prog-path and --sysconfdir.+    flags_1_18_0 = flags_1_19_0 { configProgramPathExtra = []+                                , configInstallDirs = configInstallDirs_1_18_0}+    configInstallDirs_1_18_0 = (configInstallDirs flags) { sysconfdir = NoFlag }+    -- Cabal < 1.14.0 doesn't know about '--disable-benchmarks'.+    flags_1_14_0 = flags_1_18_0 { configBenchmarks  = NoFlag }+    -- Cabal < 1.10.0 doesn't know about '--disable-tests'.+    flags_1_10_0 = flags_1_14_0 { configTests       = NoFlag }+    -- Cabal < 1.3.10 does not grok the '--constraints' flag.+    flags_1_3_10 = flags_1_10_0 { configConstraints = [] }+ -- ------------------------------------------------------------ -- * Config extra flags -- ------------------------------------------------------------@@ -245,18 +301,21 @@     configCabalVersion :: Flag Version,     configExConstraints:: [UserConstraint],     configPreferences  :: [Dependency],-    configSolver       :: Flag PreSolver+    configSolver       :: Flag PreSolver,+    configAllowNewer   :: Flag AllowNewer   }  defaultConfigExFlags :: ConfigExFlags-defaultConfigExFlags = mempty { configSolver = Flag defaultSolver }+defaultConfigExFlags = mempty { configSolver     = Flag defaultSolver+                              , configAllowNewer = Flag AllowNewerNone }  configureExCommand :: CommandUI (ConfigFlags, ConfigExFlags) configureExCommand = configureCommand {     commandDefaultFlags = (mempty, defaultConfigExFlags),     commandOptions      = \showOrParseArgs ->-         liftOptions fst setFst (filter ((/="constraint") . optionName) $-                                 configureOptions   showOrParseArgs)+         liftOptions fst setFst+         (filter ((`notElem` ["constraint", "dependency", "exact-configuration"])+                  . optionName) $ configureOptions  showOrParseArgs)       ++ liftOptions snd setSnd (configureExOptions showOrParseArgs)   }   where@@ -288,6 +347,14 @@               (map display))    , optionSolver configSolver (\v flags -> flags { configSolver = v })++  , option [] ["allow-newer"]+    "Ignore upper bounds in dependencies on some or all packages."+    configAllowNewer (\v flags -> flags { configAllowNewer = v})+    (optArg "PKGS"+     (fmap Flag allowNewerParser) (Flag AllowNewerAll)+     allowNewerPrinter)+   ]  instance Monoid ConfigExFlags where@@ -295,13 +362,15 @@     configCabalVersion = mempty,     configExConstraints= mempty,     configPreferences  = mempty,-    configSolver       = mempty+    configSolver       = mempty,+    configAllowNewer   = mempty   }   mappend a b = ConfigExFlags {     configCabalVersion = combine configCabalVersion,     configExConstraints= combine configExConstraints,     configPreferences  = combine configPreferences,-    configSolver       = combine configSolver+    configSolver       = combine configSolver,+    configAllowNewer   = combine configAllowNewer   }     where combine field = field a `mappend` field b @@ -309,12 +378,98 @@ -- * Build flags -- ------------------------------------------------------------ -buildCommand :: CommandUI BuildFlags-buildCommand = (Cabal.buildCommand defaultProgramConfiguration) {-    commandDefaultFlags = mempty+data SkipAddSourceDepsCheck =+  SkipAddSourceDepsCheck | DontSkipAddSourceDepsCheck+  deriving Eq++data BuildExFlags = BuildExFlags {+  buildOnly     :: Flag SkipAddSourceDepsCheck+}++buildExOptions :: ShowOrParseArgs -> [OptionField BuildExFlags]+buildExOptions _showOrParseArgs =+  option [] ["only"]+  "Don't reinstall add-source dependencies (sandbox-only)"+  buildOnly (\v flags -> flags { buildOnly = v })+  (noArg (Flag SkipAddSourceDepsCheck))++  : []++buildCommand :: CommandUI (BuildFlags, BuildExFlags)+buildCommand = parent {+    commandDefaultFlags = (commandDefaultFlags parent, mempty),+    commandOptions      =+      \showOrParseArgs -> liftOptions fst setFst+                          (commandOptions parent showOrParseArgs)+                          +++                          liftOptions snd setSnd (buildExOptions showOrParseArgs)   }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b) +    parent = Cabal.buildCommand defaultProgramConfiguration++instance Monoid BuildExFlags where+  mempty = BuildExFlags {+    buildOnly    = mempty+  }+  mappend a b = BuildExFlags {+    buildOnly    = combine buildOnly+  }+    where combine field = field a `mappend` field b+ -- ------------------------------------------------------------+-- * Test command+-- ------------------------------------------------------------++testCommand :: CommandUI (TestFlags, BuildFlags, BuildExFlags)+testCommand = parent {+  commandDefaultFlags = (commandDefaultFlags parent,+                         Cabal.defaultBuildFlags, mempty),+  commandOptions      =+    \showOrParseArgs -> liftOptions get1 set1+                        (commandOptions parent showOrParseArgs)+                        +++                        liftOptions get2 set2+                        (Cabal.buildOptions progConf showOrParseArgs)+                        +++                        liftOptions get3 set3 (buildExOptions 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)++    parent   = Cabal.testCommand+    progConf = defaultProgramConfiguration++-- ------------------------------------------------------------+-- * Bench command+-- ------------------------------------------------------------++benchmarkCommand :: CommandUI (BenchmarkFlags, BuildFlags, BuildExFlags)+benchmarkCommand = parent {+  commandDefaultFlags = (commandDefaultFlags parent,+                         Cabal.defaultBuildFlags, mempty),+  commandOptions      =+    \showOrParseArgs -> liftOptions get1 set1+                        (commandOptions parent showOrParseArgs)+                        +++                        liftOptions get2 set2+                        (Cabal.buildOptions progConf showOrParseArgs)+                        +++                        liftOptions get3 set3 (buildExOptions 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)++    parent   = Cabal.benchmarkCommand+    progConf = defaultProgramConfiguration++-- ------------------------------------------------------------ -- * Fetch command -- ------------------------------------------------------------ @@ -385,15 +540,66 @@   }  -- ------------------------------------------------------------+-- * Freeze command+-- ------------------------------------------------------------++data FreezeFlags = FreezeFlags {+      freezeDryRun           :: Flag Bool,+      freezeSolver           :: Flag PreSolver,+      freezeMaxBackjumps     :: Flag Int,+      freezeReorderGoals     :: Flag Bool,+      freezeIndependentGoals :: Flag Bool,+      freezeShadowPkgs       :: Flag Bool,+      freezeVerbosity        :: Flag Verbosity+    }++defaultFreezeFlags :: FreezeFlags+defaultFreezeFlags = FreezeFlags {+    freezeDryRun           = toFlag False,+    freezeSolver           = Flag defaultSolver,+    freezeMaxBackjumps     = Flag defaultMaxBackjumps,+    freezeReorderGoals     = Flag False,+    freezeIndependentGoals = Flag False,+    freezeShadowPkgs       = Flag False,+    freezeVerbosity        = toFlag normal+   }++freezeCommand :: CommandUI FreezeFlags+freezeCommand = CommandUI {+    commandName         = "freeze",+    commandSynopsis     = "Freeze dependencies.",+    commandDescription  = Nothing,+    commandUsage        = usagePackages "freeze",+    commandDefaultFlags = defaultFreezeFlags,+    commandOptions      = \ showOrParseArgs -> [+         optionVerbosity freezeVerbosity (\v flags -> flags { freezeVerbosity = v })++       , option [] ["dry-run"]+           "Do not freeze anything, only print what would be frozen"+           freezeDryRun (\v flags -> flags { freezeDryRun = v })+           trueArg++       ] ++++       optionSolver      freezeSolver           (\v flags -> flags { freezeSolver           = v }) :+       optionSolverFlags showOrParseArgs+                         freezeMaxBackjumps     (\v flags -> flags { freezeMaxBackjumps     = v })+                         freezeReorderGoals     (\v flags -> flags { freezeReorderGoals     = v })+                         freezeIndependentGoals (\v flags -> flags { freezeIndependentGoals = v })+                         freezeShadowPkgs       (\v flags -> flags { freezeShadowPkgs       = v })++  }++-- ------------------------------------------------------------ -- * Other commands -- ------------------------------------------------------------  updateCommand  :: CommandUI (Flag Verbosity) updateCommand = CommandUI {     commandName         = "update",-    commandSynopsis     = "Updates list of known packages",+    commandSynopsis     = "Updates list of known packages.",     commandDescription  = Nothing,-    commandUsage        = usagePackages "update",+    commandUsage        = usageFlags "update",     commandDefaultFlags = toFlag normal,     commandOptions      = \_ -> [optionVerbosity id const]   }@@ -403,7 +609,7 @@     commandName         = "upgrade",     commandSynopsis     = "(command disabled, use install instead)",     commandDescription  = Nothing,-    commandUsage        = usagePackages "upgrade",+    commandUsage        = usageFlagsOrPackages "upgrade",     commandDefaultFlags = (mempty, mempty, mempty, mempty),     commandOptions      = commandOptions installCommand   }@@ -422,13 +628,36 @@ checkCommand  :: CommandUI (Flag Verbosity) checkCommand = CommandUI {     commandName         = "check",-    commandSynopsis     = "Check the package for common mistakes",+    commandSynopsis     = "Check the package for common mistakes.",     commandDescription  = Nothing,     commandUsage        = \pname -> "Usage: " ++ pname ++ " check\n",     commandDefaultFlags = toFlag normal,     commandOptions      = \_ -> []   } +runCommand :: CommandUI (BuildFlags, BuildExFlags)+runCommand = CommandUI {+    commandName         = "run",+    commandSynopsis     = "Runs the compiled executable.",+    commandDescription  = Nothing,+    commandUsage        =+      \pname -> "Usage: " ++ pname+                ++ " run [FLAGS] [EXECUTABLE] [-- EXECUTABLE_FLAGS]\n\n"+                ++ "Flags for run:",+    commandDefaultFlags = mempty,+    commandOptions      =+      \showOrParseArgs -> liftOptions fst setFst+                          (Cabal.buildOptions progConf showOrParseArgs)+                          +++                          liftOptions snd setSnd+                          (buildExOptions showOrParseArgs)+  }+  where+    setFst a (_,b) = (a,b)+    setSnd b (a,_) = (a,b)++    progConf = defaultProgramConfiguration+ -- ------------------------------------------------------------ -- * Report flags -- ------------------------------------------------------------@@ -486,43 +715,79 @@     where combine field = field a `mappend` field b  -- --------------------------------------------------------------- * Unpack flags+-- * Get flags -- ------------------------------------------------------------ -data UnpackFlags = UnpackFlags {-      unpackDestDir :: Flag FilePath,-      unpackVerbosity :: Flag Verbosity-    }+data GetFlags = GetFlags {+    getDestDir          :: Flag FilePath,+    getPristine         :: Flag Bool,+    getSourceRepository :: Flag (Maybe RepoKind),+    getVerbosity        :: Flag Verbosity+  } -defaultUnpackFlags :: UnpackFlags-defaultUnpackFlags = UnpackFlags {-    unpackDestDir = mempty,-    unpackVerbosity = toFlag normal+defaultGetFlags :: GetFlags+defaultGetFlags = GetFlags {+    getDestDir          = mempty,+    getPristine         = mempty,+    getSourceRepository = mempty,+    getVerbosity        = toFlag normal    } -unpackCommand :: CommandUI UnpackFlags-unpackCommand = CommandUI {-    commandName         = "unpack",-    commandSynopsis     = "Unpacks packages for user inspection.",-    commandDescription  = Nothing,-    commandUsage        = usagePackages "unpack",-    commandDefaultFlags = mempty,+getCommand :: CommandUI GetFlags+getCommand = CommandUI {+    commandName         = "get",+    commandSynopsis     = "Gets a package's source code.",+    commandDescription  = Just $ \_ ->+          "Creates a local copy of a package's source code. By default it gets "+       ++ "the source\ntarball and unpacks it in a local subdirectory. "+       ++ "Alternatively, with -s it will\nget the code from the source "+       ++ "repository specified by the package.\n",+    commandUsage        = usagePackages "get",+    commandDefaultFlags = defaultGetFlags,     commandOptions      = \_ -> [-        optionVerbosity unpackVerbosity (\v flags -> flags { unpackVerbosity = v })+        optionVerbosity getVerbosity (\v flags -> flags { getVerbosity = v })         ,option "d" ["destdir"]-         "where to unpack the packages, defaults to the current directory."-         unpackDestDir (\v flags -> flags { unpackDestDir = v })+         "Where to place the package source, defaults to the current directory."+         getDestDir (\v flags -> flags { getDestDir = v })          (reqArgFlag "PATH")++       ,option "s" ["source-repository"]+         "Copy the package's source repository (ie git clone, darcs get, etc as appropriate)."+         getSourceRepository (\v flags -> flags { getSourceRepository = v })+        (optArg "[head|this|...]" (readP_to_E (const "invalid source-repository")+                                              (fmap (toFlag . Just) parse))+                                  (Flag Nothing)+                                  (map (fmap show) . flagToList))++       , option [] ["pristine"]+           ("Unpack the original pristine tarball, rather than updating the "+           ++ ".cabal file with the latest revision from the package archive.")+           getPristine (\v flags -> flags { getPristine = v })+           trueArg        ]   } -instance Monoid UnpackFlags where-  mempty = defaultUnpackFlags-  mappend a b = UnpackFlags {-     unpackDestDir = combine unpackDestDir-    ,unpackVerbosity = combine unpackVerbosity+-- 'cabal unpack' is a deprecated alias for 'cabal get'.+unpackCommand :: CommandUI GetFlags+unpackCommand = getCommand {+  commandName  = "unpack",+  commandUsage = usagePackages "unpack"   }++instance Monoid GetFlags where+  mempty = GetFlags {+    getDestDir          = mempty,+    getPristine         = mempty,+    getSourceRepository = mempty,+    getVerbosity        = mempty+    }+  mappend a b = GetFlags {+    getDestDir          = combine getDestDir,+    getPristine         = combine getPristine,+    getSourceRepository = combine getSourceRepository,+    getVerbosity        = combine getVerbosity+  }     where combine field = field a `mappend` field b  -- ------------------------------------------------------------@@ -530,16 +795,18 @@ -- ------------------------------------------------------------  data ListFlags = ListFlags {-    listInstalled :: Flag Bool,+    listInstalled    :: Flag Bool,     listSimpleOutput :: Flag Bool,-    listVerbosity :: Flag Verbosity+    listVerbosity    :: Flag Verbosity,+    listPackageDBs   :: [Maybe PackageDB]   }  defaultListFlags :: ListFlags defaultListFlags = ListFlags {-    listInstalled = Flag False,+    listInstalled    = Flag False,     listSimpleOutput = Flag False,-    listVerbosity = toFlag normal+    listVerbosity    = toFlag normal,+    listPackageDBs   = []   }  listCommand  :: CommandUI ListFlags@@ -547,7 +814,7 @@     commandName         = "list",     commandSynopsis     = "List packages matching a search string.",     commandDescription  = Nothing,-    commandUsage        = usagePackages "list",+    commandUsage        = usageFlagsOrPackages "list",     commandDefaultFlags = defaultListFlags,     commandOptions      = \_ -> [         optionVerbosity listVerbosity (\v flags -> flags { listVerbosity = v })@@ -562,15 +829,26 @@             listSimpleOutput (\v flags -> flags { listSimpleOutput = v })             trueArg +        , option "" ["package-db"]+          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          listPackageDBs (\v flags -> flags { listPackageDBs = v })+          (reqArg' "DB" readPackageDbList showPackageDbList)+         ]   }  instance Monoid ListFlags where-  mempty = defaultListFlags+  mempty = ListFlags {+    listInstalled    = mempty,+    listSimpleOutput = mempty,+    listVerbosity    = mempty,+    listPackageDBs   = mempty+    }   mappend a b = ListFlags {-    listInstalled = combine listInstalled,+    listInstalled    = combine listInstalled,     listSimpleOutput = combine listSimpleOutput,-    listVerbosity = combine listVerbosity+    listVerbosity    = combine listVerbosity,+    listPackageDBs   = combine listPackageDBs   }     where combine field = field a `mappend` field b @@ -579,12 +857,14 @@ -- ------------------------------------------------------------  data InfoFlags = InfoFlags {-    infoVerbosity :: Flag Verbosity+    infoVerbosity  :: Flag Verbosity,+    infoPackageDBs :: [Maybe PackageDB]   }  defaultInfoFlags :: InfoFlags defaultInfoFlags = InfoFlags {-    infoVerbosity = toFlag normal+    infoVerbosity  = toFlag normal,+    infoPackageDBs = []   }  infoCommand  :: CommandUI InfoFlags@@ -596,13 +876,23 @@     commandDefaultFlags = defaultInfoFlags,     commandOptions      = \_ -> [         optionVerbosity infoVerbosity (\v flags -> flags { infoVerbosity = v })++        , option "" ["package-db"]+          "Use a given package database. May be a specific file, 'global', 'user' or 'clear'."+          infoPackageDBs (\v flags -> flags { infoPackageDBs = v })+          (reqArg' "DB" readPackageDbList showPackageDbList)+         ]   }  instance Monoid InfoFlags where-  mempty = defaultInfoFlags+  mempty = InfoFlags {+    infoVerbosity  = mempty,+    infoPackageDBs = mempty+    }   mappend a b = InfoFlags {-    infoVerbosity = combine infoVerbosity+    infoVerbosity  = combine infoVerbosity,+    infoPackageDBs = combine infoPackageDBs   }     where combine field = field a `mappend` field b @@ -661,6 +951,27 @@   where     docIndexFile = toPathTemplate ("$datadir" </> "doc" </> "index.html") +allowNewerParser :: ReadE AllowNewer+allowNewerParser = ReadE $ \s ->+  case s of+    ""      -> Right AllowNewerNone+    "False" -> Right AllowNewerNone+    "True"  -> Right AllowNewerAll+    _       ->+      case readPToMaybe pkgsParser s of+        Just pkgs -> Right . AllowNewerSome $ pkgs+        Nothing   -> Left ("Cannot parse the list of packages: " ++ s)+  where+    pkgsParser = Parse.sepBy1 parse (Parse.char ',')++allowNewerPrinter :: Flag AllowNewer -> [Maybe String]+allowNewerPrinter (Flag AllowNewerNone)        = [Just "False"]+allowNewerPrinter (Flag AllowNewerAll)         = [Just "True"]+allowNewerPrinter (Flag (AllowNewerSome pkgs)) =+  [Just . intercalate "," . map display $ pkgs]+allowNewerPrinter NoFlag                       = []++ defaultMaxBackjumps :: Int defaultMaxBackjumps = 200 @@ -674,7 +985,7 @@ installCommand = CommandUI {   commandName         = "install",   commandSynopsis     = "Installs a list of packages.",-  commandUsage        = usagePackages "install",+  commandUsage        = usageFlagsOrPackages "install",   commandDescription  = Just $ \pname ->     let original = case commandDescription configureCommand of           Just desc -> desc pname ++ "\n"@@ -691,7 +1002,10 @@      ++ "    Constrained package version\n",   commandDefaultFlags = (mempty, mempty, mempty, mempty),   commandOptions      = \showOrParseArgs ->-       liftOptions get1 set1 (filter ((/="constraint") . optionName) $+       liftOptions get1 set1+       (filter ((`notElem` ["constraint", "dependency"+                           , "exact-configuration"])+                . optionName) $                               configureOptions   showOrParseArgs)     ++ liftOptions get2 set2 (configureExOptions showOrParseArgs)     ++ liftOptions get3 set3 (installOptions     showOrParseArgs)@@ -772,6 +1086,11 @@           installOnlyDeps (\v flags -> flags { installOnlyDeps = v })           (yesNoOpt showOrParseArgs) +      , option [] ["dependencies-only"]+          "A synonym for --only-dependencies"+          installOnlyDeps (\v flags -> flags { installOnlyDeps = v })+          (yesNoOpt showOrParseArgs)+       , option [] ["root-cmd"]           "Command used to gain root privileges, when installing with --global."           installRootCmd (\v flags -> flags { installRootCmd = v })@@ -806,23 +1125,19 @@           installOneShot (\v flags -> flags { installOneShot = v })           (yesNoOpt showOrParseArgs) -      , option "j" ["jobs"]-        "Run NUM jobs simultaneously."+      , optionNumJobs         installNumJobs (\v flags -> flags { installNumJobs = v })-        (optArg "NUM" (readP_to_E (\_ -> "jobs should be a number")-                                  (fmap (toFlag . Just)-                                        (Parse.readS_to_P reads)))-                      (Flag Nothing)-                      (map (fmap show) . flagToList))-      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install" avoids++      ] ++ case showOrParseArgs of      -- TODO: remove when "cabal install"+                                        -- avoids           ParseArgs ->-            option [] ["only"]+            [ option [] ["only"]               "Only installs the package in the current directory."               installOnly (\v flags -> flags { installOnly = v })-              trueArg-             : []+              trueArg ]           _ -> [] + instance Monoid InstallFlags where   mempty = InstallFlags {     installDocumentation   = mempty,@@ -892,7 +1207,7 @@ uploadCommand :: CommandUI UploadFlags uploadCommand = CommandUI {     commandName         = "upload",-    commandSynopsis     = "Uploads source packages to Hackage",+    commandSynopsis     = "Uploads source packages to Hackage.",     commandDescription  = Just $ \_ ->          "You can store your Hackage login in the ~/.cabal/config file\n",     commandUsage        = \pname ->@@ -1046,6 +1361,12 @@         (reqArg' "CATEGORY" (\s -> toFlag $ maybe (Left s) Right (readMaybe s))                             (flagToList . fmap (either id show))) +      , option ['x'] ["extra-source-file"]+        "Extra source file to be distributed with tarball."+        IT.extraSrc (\v flags -> flags { IT.extraSrc = v })+        (reqArg' "FILE" (Just . (:[]))+                        (fromMaybe []))+       , option [] ["is-library"]         "Build a library."         IT.packageType (\v flags -> flags { IT.packageType = v })@@ -1071,14 +1392,22 @@         (\v flags -> flags { IT.exposedModules = v })         (reqArg "MODULE" (readP_to_E ("Cannot parse module name: "++)                                      ((Just . (:[])) `fmap` parse))-                         (fromMaybe [] . fmap (fmap display)))+                         (maybe [] (fmap display))) +      , option [] ["extension"]+        "Use a LANGUAGE extension (in the other-extensions field)."+        IT.otherExts+        (\v flags -> flags { IT.otherExts = v })+        (reqArg "EXTENSION" (readP_to_E ("Cannot parse extension: "++)+                                        ((Just . (:[])) `fmap` parse))+                            (maybe [] (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)))+                          (maybe [] (fmap display)))        , option [] ["source-dir"]         "Directory containing package source."@@ -1179,83 +1508,12 @@ }  instance Monoid Win32SelfUpgradeFlags where-  mempty = defaultWin32SelfUpgradeFlags+  mempty      = Win32SelfUpgradeFlags {+    win32SelfUpgradeVerbosity = mempty+    }   mappend a b = Win32SelfUpgradeFlags {     win32SelfUpgradeVerbosity = combine win32SelfUpgradeVerbosity-  }-    where combine field = field a `mappend` field b---- --------------------------------------------------------------- * Index flags--- --------------------------------------------------------------data IndexFlags = IndexFlags {-  indexInit         :: Flag Bool,-  indexList         :: Flag Bool,-  indexLinkSource   :: [FilePath],-  indexRemoveSource :: [String],-  indexVerbosity    :: Flag Verbosity-}--defaultIndexFlags :: IndexFlags-defaultIndexFlags = IndexFlags {-  indexInit         = mempty,-  indexList         = mempty,-  indexLinkSource   = [],-  indexRemoveSource = [],-  indexVerbosity    = toFlag normal-}--indexCommand :: CommandUI IndexFlags-indexCommand = CommandUI {-  commandName         = "index",-  commandSynopsis     = "Query and modify the index file",-  commandDescription  = Nothing,-  commandUsage        = \pname ->-    "Usage: " ++ pname ++ " index FLAGS PATH\n\n"-     ++ "Flags for index:",-  commandDefaultFlags = defaultIndexFlags,-  commandOptions      = \_ ->-      [optionVerbosity indexVerbosity-       (\v flags -> flags { indexVerbosity = v})--      ,option [] ["init"]-       "Create the index"-       indexInit (\v flags -> flags { indexInit = v })-       trueArg--      ,option [] ["link-source"]-       "Add a reference to a local build tree to the index"-       indexLinkSource (\v flags -> flags { indexLinkSource = v })-       (reqArg' "PATH" (\x -> [x]) id)--      ,option [] ["remove-source"]-       "Remove a reference to a local build tree from the index"-       indexRemoveSource (\v flags -> flags { indexRemoveSource = v })-       (reqArg' "PATH" (\x -> [x]) id)--      ,option [] ["list"]-       "List the local build trees that are referred to from the index"-       indexList (\v flags -> flags { indexList = v })-       trueArg-      ]-}--instance Monoid IndexFlags where-  mempty = IndexFlags {-    indexInit         = mempty,-    indexList         = mempty,-    indexLinkSource   = mempty,-    indexRemoveSource = mempty,-    indexVerbosity    = mempty-  }-  mappend a b = IndexFlags {-    indexInit         = combine indexInit,-    indexList         = combine indexList,-    indexLinkSource   = combine indexLinkSource,-    indexRemoveSource = combine indexRemoveSource,-    indexVerbosity    = combine indexVerbosity-  }+    }     where combine field = field a `mappend` field b  -- ------------------------------------------------------------@@ -1264,6 +1522,8 @@  data SandboxFlags = SandboxFlags {   sandboxVerbosity :: Flag Verbosity,+  sandboxSnapshot  :: Flag Bool, -- FIXME: this should be an 'add-source'-only+                                 -- flag.   sandboxLocation  :: Flag FilePath } @@ -1273,113 +1533,53 @@ defaultSandboxFlags :: SandboxFlags defaultSandboxFlags = SandboxFlags {   sandboxVerbosity = toFlag normal,+  sandboxSnapshot  = toFlag False,   sandboxLocation  = toFlag defaultSandboxLocation   } -commonSandboxOptions :: ShowOrParseArgs -> [OptionField SandboxFlags]-commonSandboxOptions _showOrParseArgs =-  [ optionVerbosity sandboxVerbosity (\v flags -> flags { sandboxVerbosity = v })--    , option [] ["sandbox"]-      "Sandbox location (default: './.cabal-sandbox')."-      sandboxLocation (\v flags -> flags { sandboxLocation = v })-      (reqArgFlag "DIR")-  ]--sandboxConfigureCommand :: CommandUI (SandboxFlags, ConfigFlags, ConfigExFlags)-sandboxConfigureCommand = CommandUI {-  commandName         = "sandbox-configure",-  commandSynopsis     = "Configure a package inside a sandbox",+sandboxCommand :: CommandUI SandboxFlags+sandboxCommand = CommandUI {+  commandName         = "sandbox",+  commandSynopsis     = "Create/modify/delete a sandbox.",   commandDescription  = Nothing,-  commandUsage        = \pname -> usageFlags pname "sandbox-configure",-  commandDefaultFlags = (defaultSandboxFlags, mempty, defaultConfigExFlags),-  commandOptions      = \showOrParseArgs ->-    liftOptions get1 set1 (commonSandboxOptions showOrParseArgs)-    ++ liftOptions get2 set2-             (filter ((\n -> n /= "constraint" && n /= "verbose") . optionName) $-              configureOptions showOrParseArgs)-    ++ liftOptions get3 set3 (configureExOptions 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)+  commandUsage        = \pname ->+       "Usage: " ++ pname ++ " sandbox init\n"+    ++ "   or: " ++ pname ++ " sandbox delete\n"+    ++ "   or: " ++ pname ++ " sandbox add-source  [PATHS]\n\n"+    ++ "   or: " ++ pname ++ " sandbox hc-pkg      -- [ARGS]\n"+    ++ "   or: " ++ pname ++ " sandbox list-sources\n\n"+    ++ "Flags for sandbox:", -sandboxAddSourceCommand :: CommandUI SandboxFlags-sandboxAddSourceCommand = CommandUI {-  commandName         = "sandbox-add-source",-  commandSynopsis     = "Make a source package available in a sandbox",-  commandDescription  = Nothing,-  commandUsage        = \pname -> usageFlags pname "sandbox-add-source",   commandDefaultFlags = defaultSandboxFlags,-  commandOptions      = commonSandboxOptions-  }--sandboxBuildCommand :: CommandUI (SandboxFlags, BuildFlags)-sandboxBuildCommand = CommandUI {-  commandName         = "sandbox-build",-  commandSynopsis     = "Build a package inside a sandbox",-  commandDescription  = Nothing,-  commandUsage        = \pname -> usageFlags pname "sandbox-build",-  commandDefaultFlags = (defaultSandboxFlags, Cabal.defaultBuildFlags),-  commandOptions      = \showOrParseArgs ->-    liftOptions fst setFst (commonSandboxOptions showOrParseArgs)-    ++ liftOptions snd setSnd (filter ((/= "verbose") . optionName) $-                               Cabal.buildOptions progConf showOrParseArgs)-  }-  where-    progConf = defaultProgramConfiguration--    setFst a (_,b) = (a,b)-    setSnd b (a,_) = (a,b)+  commandOptions      = \_ ->+    [ optionVerbosity sandboxVerbosity+      (\v flags -> flags { sandboxVerbosity = v }) -sandboxInstallCommand :: CommandUI (SandboxFlags, ConfigFlags, ConfigExFlags,-                                    InstallFlags, HaddockFlags)-sandboxInstallCommand = CommandUI {-  commandName         = "sandbox-install",-  commandSynopsis     = "Install a list of packages into a sandbox",-  commandDescription  = commandDescription installCommand,-  commandUsage        = \pname -> usagePackages pname "sandbox-install",-  commandDefaultFlags = (defaultSandboxFlags, mempty, mempty, mempty, mempty),-  commandOptions      = \showOrParseArgs ->-       liftOptions get1 set1 (commonSandboxOptions showOrParseArgs)-    ++ liftOptions get2 set2-       (filter ((\n -> n /= "constraint" && n /= "verbose") . optionName) $-        configureOptions showOrParseArgs)-    ++ liftOptions get3 set3 (configureExOptions showOrParseArgs)-    ++ liftOptions get4 set4 (installOptions showOrParseArgs)-    ++ liftOptions get5 set5 (haddockOptions showOrParseArgs)-  }-  where-    get1 (a,_,_,_,_) = a; set1 a (_,b,c,d,e) = (a,b,c,d,e)-    get2 (_,b,_,_,_) = b; set2 b (a,_,c,d,e) = (a,b,c,d,e)-    get3 (_,_,c,_,_) = c; set3 c (a,b,_,d,e) = (a,b,c,d,e)-    get4 (_,_,_,d,_) = d; set4 d (a,b,c,_,e) = (a,b,c,d,e)-    get5 (_,_,_,_,e) = e; set5 e (a,b,c,d,_) = (a,b,c,d,e)+    , option [] ["snapshot"]+      "Take a snapshot instead of creating a link (only applies to 'add-source')"+      sandboxSnapshot (\v flags -> flags { sandboxSnapshot = v })+      trueArg -dumpPkgEnvCommand :: CommandUI SandboxFlags-dumpPkgEnvCommand = CommandUI {-  commandName         = "dump-pkgenv",-  commandSynopsis     = "Dump a parsed package environment file",-  commandDescription  = Nothing,-  commandUsage        = \pname -> usageFlags pname "dump-pkgenv",-  commandDefaultFlags = defaultSandboxFlags,-  commandOptions      = commonSandboxOptions+    , option [] ["sandbox"]+      "Sandbox location (default: './.cabal-sandbox')."+      sandboxLocation (\v flags -> flags { sandboxLocation = v })+      (reqArgFlag "DIR")+    ]   }  instance Monoid SandboxFlags where   mempty = SandboxFlags {     sandboxVerbosity = mempty,+    sandboxSnapshot  = mempty,     sandboxLocation  = mempty     }   mappend a b = SandboxFlags {     sandboxVerbosity = combine sandboxVerbosity,+    sandboxSnapshot  = combine sandboxSnapshot,     sandboxLocation  = combine sandboxLocation     }     where combine field = field a `mappend` field b - -- ------------------------------------------------------------ -- * GetOpt Utils -- ------------------------------------------------------------@@ -1392,9 +1592,9 @@             -> [OptionField a] -> [OptionField b] liftOptions get set = map (liftOption get set) -yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> (b -> b)) b+yesNoOpt :: ShowOrParseArgs -> MkOptDescr (b -> Flag Bool) (Flag Bool -> b -> b) b yesNoOpt ShowArgs sf lf = trueArg sf lf-yesNoOpt _        sf lf = boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf+yesNoOpt _        sf lf = Command.boolOpt' flagToMaybe Flag (sf, lf) ([], map ("no-" ++) lf) sf lf  optionSolver :: (flags -> Flag PreSolver)              -> (Flag PreSolver -> flags -> flags)@@ -1438,10 +1638,15 @@   ]  -usagePackages :: String -> String -> String-usagePackages name pname =+usageFlagsOrPackages :: String -> String -> String+usageFlagsOrPackages name pname =      "Usage: " ++ pname ++ " " ++ name ++ " [FLAGS]\n"   ++ "   or: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"+  ++ "Flags for " ++ name ++ ":"++usagePackages :: String -> String -> String+usagePackages name pname =+     "Usage: " ++ pname ++ " " ++ name ++ " [PACKAGES]\n\n"   ++ "Flags for " ++ name ++ ":"  usageFlags :: String -> String -> String
cabal/cabal-install/Distribution/Client/SetupWrapper.hs view
@@ -26,8 +26,10 @@          ( Version(..), VersionRange, anyVersion          , intersectVersionRanges, orLaterVersion          , withinRange )+import Distribution.InstalledPackageInfo (installedPackageId) import Distribution.Package-         ( PackageIdentifier(..), PackageName(..), Package(..), packageName+         ( InstalledPackageId(..), PackageIdentifier(..),+           PackageName(..), Package(..), packageName          , packageVersion, Dependency(..) ) import Distribution.PackageDescription          ( GenericPackageDescription(packageDescription)@@ -36,19 +38,26 @@ import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Configure-         ( configCompiler )+         ( configCompilerEx )+import Distribution.Compiler ( buildCompilerId ) import Distribution.Simple.Compiler-         ( CompilerFlavor(GHC), Compiler, compilerVersion, showCompilerId+         ( CompilerFlavor(GHC), Compiler(compilerId)          , PackageDB(..), PackageDBStack )+import Distribution.Simple.PreProcess+         ( runSimplePreProcessor, ppUnlit ) import Distribution.Simple.Program          ( ProgramConfiguration, emptyProgramConfiguration-         , getDbProgramOutput, runDbProgram, ghcProgram )+         , getProgramSearchPath, getDbProgramOutput, runDbProgram, ghcProgram )+import Distribution.Simple.Program.Find+         ( programSearchPathAsPATHVar )+import Distribution.Simple.Program.Run+         ( getEffectiveEnvironment ) import Distribution.Simple.BuildPaths          ( defaultDistPref, exeExtension ) import Distribution.Simple.Command          ( CommandUI(..), commandShowOptions )-import Distribution.Simple.GHC-         ( ghcVerbosityOptions )+import Distribution.Simple.Program.GHC+         ( GhcMode(..), GhcOptions(..), renderGhcOptions ) import qualified Distribution.Simple.PackageIndex as PackageIndex import Distribution.Simple.PackageIndex (PackageIndex) import Distribution.Client.Config@@ -57,12 +66,16 @@          ( getInstalledPackages ) import Distribution.Client.JobControl          ( Lock, criticalSection )+import Distribution.Simple.Setup+         ( Flag(..) ) import Distribution.Simple.Utils-         ( die, debug, info, cabalVersion, findPackageDesc, comparing+         ( die, debug, info, cabalVersion, tryFindPackageDesc, comparing          , createDirectoryIfMissingVerbose, installExecutableFile-         , rewriteFile, intercalate )+         , copyFileVerbose, rewriteFile, intercalate ) import Distribution.Client.Utils-         ( moreRecentFile, inDir )+         ( inDir, tryCanonicalizePath+         , existsAndIsMoreRecentThan, moreRecentFile )+import Distribution.System ( Platform(..), buildPlatform ) import Distribution.Text          ( display ) import Distribution.Verbosity@@ -70,19 +83,22 @@ import Distribution.Compat.Exception          ( catchIO ) -import System.Directory  ( doesFileExist )-import System.FilePath   ( (</>), (<.>) )-import System.IO         ( Handle, hPutStr )-import System.Exit       ( ExitCode(..), exitWith )-import System.Process    ( runProcess, waitForProcess )-import Control.Monad     ( when, unless )-import Data.List         ( maximumBy )-import Data.Maybe        ( fromMaybe, isJust )-import Data.Char         ( isSpace )+import System.Directory    ( doesFileExist )+import System.FilePath     ( (</>), (<.>) )+import System.IO           ( Handle, hPutStr )+import System.Exit         ( ExitCode(..), exitWith )+import System.Process      ( runProcess, waitForProcess )+import Control.Applicative ( (<$>), (<*>) )+import Control.Monad       ( when, unless )+import Data.List           ( foldl1' )+import Data.Maybe          ( fromMaybe, isJust )+import Data.Monoid         ( mempty )+import Data.Char           ( isSpace )  data SetupScriptOptions = SetupScriptOptions {     useCabalVersion          :: VersionRange,     useCompiler              :: Maybe Compiler,+    usePlatform              :: Maybe Platform,     usePackageDB             :: PackageDBStack,     usePackageIndex          :: Maybe PackageIndex,     useProgramConfig         :: ProgramConfiguration,@@ -93,6 +109,16 @@      -- Used only when calling setupWrapper from parallel code to serialise     -- access to the setup cache; should be Nothing otherwise.+    --+    -- Note: setup exe cache+    ------------------------+    -- When we are installing in parallel, we always use the external setup+    -- method. Since compiling the setup script each time adds noticeable+    -- overhead, we use a shared setup script cache+    -- ('~/.cabal/setup-exe-cache'). For each (compiler, platform, Cabal+    -- version) combination the cache holds a compiled setup script+    -- executable. This only affects the Simple build type; for the Custom,+    -- Configure and Make build types we always compile the setup script anew.     setupCacheLock           :: Maybe Lock   } @@ -100,6 +126,7 @@ defaultSetupScriptOptions = SetupScriptOptions {     useCabalVersion          = anyVersion,     useCompiler              = Nothing,+    usePlatform              = Nothing,     usePackageDB             = [GlobalPackageDB, UserPackageDB],     usePackageIndex          = Nothing,     useProgramConfig         = emptyProgramConfiguration,@@ -132,7 +159,7 @@   checkBuildType buildType'   setupMethod verbosity options' (packageId pkg) buildType' mkArgs   where-    getPkg = findPackageDesc (fromMaybe "." (useWorkingDir options))+    getPkg = tryFindPackageDesc (fromMaybe "." (useWorkingDir options))          >>= readPackageDescription verbosity          >>= return . packageDescription @@ -188,57 +215,146 @@ 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+  (cabalLibVersion, mCabalLibInstalledPkgId, options') <- cabalLibVersionToUse   debug verbosity $ "Using Cabal library version " ++ display cabalLibVersion-  setupHs <- updateSetupScript cabalLibVersion bt-  debug verbosity $ "Using " ++ setupHs ++ " as setup script."-  path <- case bt of-    Simple -> getCachedSetupExecutable options' cabalLibVersion setupHs-    _      -> compileSetupExecutable options' cabalLibVersion setupHs-  invokeSetupScript path (mkargs cabalLibVersion)+  path <- if useCachedSetupExecutable+          then getCachedSetupExecutable options'+               cabalLibVersion mCabalLibInstalledPkgId+          else compileSetupExecutable   options'+               cabalLibVersion mCabalLibInstalledPkgId False+  invokeSetupScript options' path (mkargs cabalLibVersion)    where   workingDir       = case fromMaybe "" (useWorkingDir options) of                        []  -> "."                        dir -> dir   setupDir         = workingDir </> useDistPref options </> "setup"-  setupVersionFile = setupDir </> "setup" <.> "version"+  setupVersionFile = setupDir   </> "setup" <.> "version"+  setupHs          = setupDir   </> "setup" <.> "hs"+  setupProgFile    = setupDir   </> "setup" <.> exeExtension -  cabalLibVersionToUse :: IO (Version, SetupScriptOptions)+  useCachedSetupExecutable = (bt == Simple || bt == Configure || bt == Make)++  maybeGetInstalledPackages :: SetupScriptOptions -> Compiler+                               -> ProgramConfiguration -> IO PackageIndex+  maybeGetInstalledPackages options' comp conf =+    case usePackageIndex options' of+      Just index -> return index+      Nothing    -> getInstalledPackages verbosity+                    comp (usePackageDB options') conf++  cabalLibVersionToUse :: IO (Version, (Maybe InstalledPackageId)+                             ,SetupScriptOptions)   cabalLibVersionToUse = do-    savedVersion <- savedCabalVersion-    case savedVersion of+    savedVer <- savedVersion+    case savedVer 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')+        -> do updateSetupScript version bt+              -- Does the previously compiled setup executable still exist and+              -- is it up-to date?+              useExisting <- canUseExistingSetup version+              if useExisting+                then return (version, Nothing, options)+                else installedVersion+      _ -> installedVersion+    where+      -- This check duplicates the checks in 'getCachedSetupExecutable' /+      -- 'compileSetupExecutable'. Unfortunately, we have to perform it twice+      -- because the selected Cabal version may change as a result of this+      -- check.+      canUseExistingSetup :: Version -> IO Bool+      canUseExistingSetup version =+        if useCachedSetupExecutable+        then do+          (_, cachedSetupProgFile) <- cachedSetupDirAndProg options version+          doesFileExist cachedSetupProgFile+        else+          (&&) <$> setupProgFile `existsAndIsMoreRecentThan` setupHs+               <*> setupProgFile `existsAndIsMoreRecentThan` setupVersionFile -  savedCabalVersion = do-    versionString <- readFile setupVersionFile `catchIO` \_ -> return ""-    case reads versionString of-      [(version,s)] | all isSpace s -> return (Just version)-      _                             -> return Nothing+      installedVersion :: IO (Version, Maybe InstalledPackageId+                             ,SetupScriptOptions)+      installedVersion = do+        (comp,    conf,    options')  <- configureCompiler options+        (version, mipkgid, options'') <- installedCabalVersion options' comp conf+        updateSetupScript version bt+        writeFile setupVersionFile (show version ++ "\n")+        return (version, mipkgid, options'') -  installedCabalVersion :: SetupScriptOptions -> Compiler-                        -> ProgramConfiguration -> IO Version-  installedCabalVersion _ _ _ | packageName pkg == PackageName "Cabal" =-    return (packageVersion pkg)-  installedCabalVersion options' comp conf = do-    index <- case usePackageIndex options' of-      Just index -> return index-      Nothing    -> getInstalledPackages verbosity-                      comp (usePackageDB options') conf+      savedVersion :: IO (Maybe Version)+      savedVersion = do+        versionString <- readFile setupVersionFile `catchIO` \_ -> return ""+        case reads versionString of+          [(version,s)] | all isSpace s -> return (Just version)+          _                             -> return Nothing -    let cabalDep = Dependency (PackageName "Cabal") (useCabalVersion options)+  -- | Update a Setup.hs script, creating it if necessary.+  updateSetupScript :: Version -> BuildType -> IO ()+  updateSetupScript _ Custom = do+    useHs  <- doesFileExist customSetupHs+    useLhs <- doesFileExist customSetupLhs+    unless (useHs || useLhs) $ die+      "Using 'build-type: Custom' but there is no Setup.hs or Setup.lhs script."+    let src = (if useHs then customSetupHs else customSetupLhs)+    srcNewer <- src `moreRecentFile` setupHs+    when srcNewer $ if useHs+                    then copyFileVerbose verbosity src setupHs+                    else runSimplePreProcessor ppUnlit src setupHs verbosity+    where+      customSetupHs   = workingDir </> "Setup.hs"+      customSetupLhs  = workingDir </> "Setup.lhs"++  updateSetupScript cabalLibVersion _ =+    rewriteFile setupHs (buildTypeScript cabalLibVersion)++  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"++  installedCabalVersion :: SetupScriptOptions -> Compiler -> ProgramConfiguration+                        -> IO (Version, Maybe InstalledPackageId+                              ,SetupScriptOptions)+  installedCabalVersion options' _ _ | packageName pkg == PackageName "Cabal" =+    return (packageVersion pkg, Nothing, options')+  installedCabalVersion options' compiler conf = do+    index <- maybeGetInstalledPackages options' compiler conf+    let cabalDep   = Dependency (PackageName "Cabal") (useCabalVersion options')+        options''  = options' { usePackageIndex = Just index }     case PackageIndex.lookupDependency index cabalDep of-      []   -> die $ "The package requires Cabal library version "+      []   -> die $ "The package '" ++ display (packageName pkg)+                 ++ "' requires Cabal library version "                  ++ display (useCabalVersion options)                  ++ " but no suitable version is installed."-      pkgs -> return $ bestVersion (map fst pkgs)+      pkgs -> let ipkginfo = head . snd . bestVersion fst $ pkgs+              in return (packageVersion ipkginfo+                        ,Just . installedPackageId $ ipkginfo, options'')++  bestVersion :: (a -> Version) -> [a] -> a+  bestVersion f = firstMaximumBy (comparing (preference . f))     where-      bestVersion          = maximumBy (comparing preference)+      -- Like maximumBy, but picks the first maximum element instead of the+      -- last. In general, we expect the preferred version to go first in the+      -- list. For the default case, this has the effect of choosing the version+      -- installed in the user package DB instead of the global one. See #1463.+      --+      -- Note: firstMaximumBy could be written as just+      -- `maximumBy cmp . reverse`, but the problem is that the behaviour of+      -- maximumBy is not fully specified in the case when there is not a single+      -- greatest element.+      firstMaximumBy :: (a -> a -> Ordering) -> [a] -> a+      firstMaximumBy _ []   =+        error "Distribution.Client.firstMaximumBy: empty list"+      firstMaximumBy cmp xs =  foldl1' maxBy xs+        where+          maxBy x y = case cmp x y of { GT -> x; EQ -> x; LT -> y; }+       preference version   = (sameVersion, sameMajorVersion                              ,stableVersion, latestVersion)         where@@ -255,97 +371,100 @@   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,+      Nothing   -> do (comp, _, conf) <-+                        configCompilerEx (Just GHC) Nothing Nothing+                        (useProgramConfig options') verbosity+                      return (comp, conf)+    -- Whenever we need to call configureCompiler, we also need to access the+    -- package index, so let's cache it here.+    index <- maybeGetInstalledPackages options' comp conf+    return (comp, conf, options' { useCompiler      = Just comp,+                                   usePackageIndex  = Just index,                                    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"+  -- | Path to the setup exe cache directory and path to the cached setup+  -- executable.+  cachedSetupDirAndProg :: SetupScriptOptions -> Version+                        -> IO (FilePath, FilePath)+  cachedSetupDirAndProg options' cabalLibVersion = do+    cabalDir <- defaultCabalDir+    let setupCacheDir       = cabalDir </> "setup-exe-cache"+        cachedSetupProgFile = setupCacheDir+                              </> ("setup-" ++ buildTypeString ++ "-"+                                   ++ cabalVersionString ++ "-"+                                   ++ platformString ++ "-"+                                   ++ compilerVersionString)+                              <.> exeExtension+    return (setupCacheDir, cachedSetupProgFile)+      where+        buildTypeString       = show bt+        cabalVersionString    = "Cabal-" ++ (display cabalLibVersion)+        compilerVersionString = display $+                                fromMaybe buildCompilerId+                                (fmap compilerId . useCompiler $ options')+        platformString        = display $+                                fromMaybe buildPlatform (usePlatform options')    -- | Look up the setup executable in the cache; update the cache if the setup   -- executable is not found.-  getCachedSetupExecutable :: SetupScriptOptions -> Version -> FilePath+  getCachedSetupExecutable :: SetupScriptOptions+                           -> Version -> Maybe InstalledPackageId                            -> IO FilePath-  getCachedSetupExecutable options' cabalLibVersion setupHsFile = do-    cabalDir <- defaultCabalDir-    let setupCacheDir = cabalDir </> "setup-exe-cache"-    let setupProgFile = setupCacheDir-                        </> ("setup-" ++ cabalVersionString ++ "-"-                             ++ compilerVersionString)-                        <.> exeExtension-    setupProgFileExists <- doesFileExist setupProgFile-    if setupProgFileExists+  getCachedSetupExecutable options' cabalLibVersion+                           maybeCabalLibInstalledPkgId = do+    (setupCacheDir, cachedSetupProgFile) <-+      cachedSetupDirAndProg options' cabalLibVersion+    cachedSetupExists <- doesFileExist cachedSetupProgFile+    if cachedSetupExists       then debug verbosity $-           "Found cached setup executable: " ++ setupProgFile+           "Found cached setup executable: " ++ cachedSetupProgFile       else criticalSection' $ do         -- The cache may have been populated while we were waiting.-        setupProgFileExists' <- doesFileExist setupProgFile-        if setupProgFileExists'+        cachedSetupExists' <- doesFileExist cachedSetupProgFile+        if cachedSetupExists'           then debug verbosity $-               "Found cached setup executable: " ++ setupProgFile+               "Found cached setup executable: " ++ cachedSetupProgFile           else do           debug verbosity $ "Setup executable not found in the cache."-          src <- compileSetupExecutable options' cabalLibVersion setupHsFile+          src <- compileSetupExecutable options'+                 cabalLibVersion maybeCabalLibInstalledPkgId True           createDirectoryIfMissingVerbose verbosity True setupCacheDir-          installExecutableFile verbosity src setupProgFile-    return setupProgFile+          installExecutableFile verbosity src cachedSetupProgFile+    return cachedSetupProgFile       where-        cabalVersionString    = "Cabal-" ++ (display cabalLibVersion)-        compilerVersionString = fromMaybe "nonexisting-compiler"-                                (showCompilerId `fmap` useCompiler options')         criticalSection'      = fromMaybe id                                 (fmap criticalSection $ setupCacheLock options')    -- | 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+  compileSetupExecutable :: SetupScriptOptions+                         -> Version -> Maybe InstalledPackageId -> Bool                          -> IO FilePath-  compileSetupExecutable options' cabalLibVersion setupHsFile = do-    setupHsNewer      <- setupHsFile      `moreRecentFile` setupProgFile+  compileSetupExecutable options' cabalLibVersion maybeCabalLibInstalledPkgId+                         forceCompile = do+    setupHsNewer      <- setupHs          `moreRecentFile` setupProgFile     cabalVersionNewer <- setupVersionFile `moreRecentFile` setupProgFile     let outOfDate = setupHsNewer || cabalVersionNewer-    when outOfDate $ do-      debug verbosity "Setup script is out of date, compiling..."-      (compiler, conf, _) <- configureCompiler options'-      --TODO: get Cabal's GHC module to export a GhcOptions type and render func-      let ghcCmdLine =-            ghcVerbosityOptions verbosity-            ++ ["--make", setupHsFile, "-o", setupProgFile-               ,"-odir", setupDir, "-hidir", setupDir-               ,"-i", "-i" ++ workingDir ]-            ++ ghcPackageDbOptions compiler (usePackageDB options')-            ++ if packageName pkg == PackageName "Cabal"-               then []-               else ["-package", display cabalPkgid]+    when (outOfDate || forceCompile) $ do+      debug verbosity "Setup executable needs to be updated, compiling..."+      (compiler, conf, options'') <- configureCompiler options'+      let cabalPkgid = PackageIdentifier (PackageName "Cabal") cabalLibVersion+      let ghcOptions = mempty {+              ghcOptVerbosity       = Flag verbosity+            , ghcOptMode            = Flag GhcModeMake+            , ghcOptInputFiles      = [setupHs]+            , ghcOptOutputFile      = Flag setupProgFile+            , ghcOptObjDir          = Flag setupDir+            , ghcOptHiDir           = Flag setupDir+            , ghcOptSourcePathClear = Flag True+            , ghcOptSourcePath      = [workingDir]+            , ghcOptPackageDBs      = usePackageDB options''+            , ghcOptPackages        = maybe []+                                      (\ipkgid -> [(ipkgid, cabalPkgid)])+                                      maybeCabalLibInstalledPkgId+            }+      let ghcCmdLine = renderGhcOptions compiler ghcOptions       case useLoggingHandle options of         Nothing          -> runDbProgram verbosity ghcProgram conf ghcCmdLine @@ -354,36 +473,27 @@                                          conf ghcCmdLine                                hPutStr logHandle output     return setupProgFile-    where-      setupProgFile = setupDir </> "setup" <.> exeExtension-      cabalPkgid    = PackageIdentifier (PackageName "Cabal") cabalLibVersion -      ghcPackageDbOptions :: Compiler -> PackageDBStack -> [String]-      ghcPackageDbOptions compiler dbstack = case dbstack of-        (GlobalPackageDB:UserPackageDB:dbs) -> concatMap specific dbs-        (GlobalPackageDB:dbs)               -> ("-no-user-" ++ packageDbFlag)-                                             : concatMap specific dbs-        _                                   -> ierror-        where-          specific (SpecificPackageDB db) = [ '-':packageDbFlag, db ]-          specific _ = ierror-          ierror     = error "internal error: unexpected package db stack"--          packageDbFlag-            | compilerVersion compiler < Version [7,5] []-            = "package-conf"-            | otherwise-            = "package-db"--  invokeSetupScript :: FilePath -> [String] -> IO ()-  invokeSetupScript path args = do+  invokeSetupScript :: SetupScriptOptions -> FilePath -> [String] -> IO ()+  invokeSetupScript options' path args = do     info verbosity $ unwords (path : args)-    case useLoggingHandle options of+    case useLoggingHandle options' of       Nothing        -> return ()       Just logHandle -> info verbosity $ "Redirecting build log to "                                       ++ show logHandle-    process <- runProcess path args-                 (useWorkingDir options) Nothing-                 Nothing (useLoggingHandle options) (useLoggingHandle options)++    -- Since useWorkingDir can change the relative path, the path argument must+    -- be turned into an absolute path. On some systems, runProcess will take+    -- path as relative to the new working directory instead of the current+    -- working directory.+    path' <- tryCanonicalizePath path++    searchpath <- programSearchPathAsPATHVar+                    (getProgramSearchPath (useProgramConfig options'))+    env        <- getEffectiveEnvironment [("PATH", Just searchpath)]++    process <- runProcess path' args+                 (useWorkingDir options') env+                 Nothing (useLoggingHandle options') (useLoggingHandle options')     exitCode <- waitForProcess process     unless (exitCode == ExitSuccess) $ exitWith exitCode
cabal/cabal-install/Distribution/Client/SrcDist.hs view
@@ -6,42 +6,34 @@   )  where  -import Distribution.Simple.SrcDist-         ( printPackageProblems, prepareTree, snapshotPackage )+import Distribution.Client.SetupWrapper+        ( SetupScriptOptions(..), defaultSetupScriptOptions, setupWrapper ) import Distribution.Client.Tar (createTarGzFile)  import Distribution.Package-         ( Package(..), packageVersion )+         ( Package(..) ) import Distribution.PackageDescription          ( PackageDescription )+import Distribution.PackageDescription.Configuration+         ( flattenPackageDescription ) import Distribution.PackageDescription.Parse          ( readPackageDescription ) import Distribution.Simple.Utils-         ( defaultPackageDesc, die, warn, notice, setupMessage-         , createDirectoryIfMissingVerbose, withTempDirectory-         , withUTF8FileContents, writeUTF8File )+         ( createDirectoryIfMissingVerbose, defaultPackageDesc+         , die, notice, withTempDirectory ) import Distribution.Client.Setup          ( SDistFlags(..), SDistExFlags(..), ArchiveFormat(..) ) import Distribution.Simple.Setup-         ( fromFlag, flagToMaybe )-import Distribution.Verbosity (Verbosity)-import Distribution.Simple.PreProcess (knownSuffixHandlers)+         ( Flag(..), sdistCommand, flagToList, fromFlag, fromFlagOrDefault ) import Distribution.Simple.BuildPaths ( srcPref)-import Distribution.Simple.Configure(maybeGetPersistBuildConfig)-import Distribution.PackageDescription.Configuration ( flattenPackageDescription ) import Distribution.Simple.Program (requireProgram, simpleProgram, programPath) import Distribution.Simple.Program.Db (emptyProgramDb)-import Distribution.Text-         ( display )-import Distribution.Version-         ( Version )+import Distribution.Text ( display )+import Distribution.Verbosity (Verbosity, lessVerbose, normal)+import Distribution.Version   (Version(..), orLaterVersion) -import System.Time (getClockTime, toCalendarTime) import System.FilePath ((</>), (<.>)) import Control.Monad (when, unless)-import Data.Maybe (isNothing)-import Data.Char (toLower)-import Data.List (isPrefixOf) import System.Directory (doesFileExist, removeFile, canonicalizePath) import System.Process (runProcess, waitForProcess) import System.Exit    (ExitCode(..))@@ -50,93 +42,79 @@ sdist :: SDistFlags -> SDistExFlags -> IO () sdist flags exflags = do   pkg <- return . flattenPackageDescription-     =<< readPackageDescription verbosity-     =<< defaultPackageDesc verbosity-  mb_lbi <- maybeGetPersistBuildConfig distPref--  -- do some QA-  printPackageProblems verbosity pkg+         =<< readPackageDescription verbosity+         =<< defaultPackageDesc verbosity+  let withDir = if not needMakeArchive then (\f -> f tmpTargetDir)+                else withTempDirectory verbosity tmpTargetDir "sdist."+  -- 'withTempDir' fails if we don't create 'tmpTargetDir'...+  when needMakeArchive $+    createDirectoryIfMissingVerbose verbosity True tmpTargetDir+  withDir $ \tmpDir -> do+    let outDir = if isOutDirectory then tmpDir else tmpDir </> tarBallName pkg+        flags' = (if not needMakeArchive then flags+                  else flags { sDistDirectory = Flag outDir })+                 { sDistVerbosity = Flag $ if   verbosity == normal+                                           then lessVerbose verbosity+                                           else verbosity }+    unless isListSources $+      createDirectoryIfMissingVerbose verbosity True outDir -  when (isNothing mb_lbi) $-    warn verbosity "Cannot run preprocessors. Run 'configure' command first."+    -- Run 'setup sdist --output-directory=tmpDir' (or+    -- '--list-source'/'--output-directory=someOtherDir') in case we were passed+    -- those options.+    setupWrapper verbosity setupOpts (Just pkg) sdistCommand (const flags') [] -  date <- toCalendarTime =<< getClockTime-  let pkg' | snapshot  = snapshotPackage date pkg-           | otherwise = pkg+    -- Unless we were given --list-sources or --output-directory ourselves,+    -- create an archive.+    when needMakeArchive $+      createArchive verbosity pkg tmpDir distPref -  case flagToMaybe (sDistDirectory flags) of-    Just targetDir -> do-      generateSourceDir targetDir pkg' mb_lbi-      notice verbosity $ "Source directory created: " ++ targetDir+    when isOutDirectory $+      notice verbosity $ "Source directory created: " ++ tmpTargetDir -    Nothing -> do-      createDirectoryIfMissingVerbose verbosity True tmpTargetDir-      withTempDirectory verbosity tmpTargetDir "sdist." $ \tmpDir -> do-        let targetDir = tmpDir </> tarBallName pkg'-        generateSourceDir targetDir pkg' mb_lbi-        targzFile <- createArchive verbosity format pkg' tmpDir targetPref-        notice verbosity $ "Source tarball created: " ++ targzFile+    when isListSources $+      notice verbosity $ "List of package sources written to file '"+                         ++ (fromFlag . sDistListSources $ flags) ++ "'"    where-    generateSourceDir targetDir pkg' mb_lbi = do--      setupMessage verbosity "Building source dist for" (packageId pkg')-      prepareTree verbosity pkg' mb_lbi distPref targetDir pps-      when snapshot $-        overwriteSnapshotPackageDesc verbosity pkg' targetDir+    flagEnabled f  = not . null . flagToList . f $ flags -    verbosity = fromFlag (sDistVerbosity flags)-    snapshot  = fromFlag (sDistSnapshot flags)-    format    = fromFlag (sDistFormat exflags)-    pps       = knownSuffixHandlers-    distPref     = fromFlag $ sDistDistPref flags-    targetPref   = distPref-    tmpTargetDir = srcPref distPref+    isListSources   = flagEnabled sDistListSources+    isOutDirectory  = flagEnabled sDistDirectory+    needMakeArchive = not (isListSources || isOutDirectory)+    verbosity       = fromFlag (sDistVerbosity flags)+    distPref        = fromFlag (sDistDistPref flags)+    tmpTargetDir    = fromFlagOrDefault (srcPref distPref) (sDistDirectory flags)+    setupOpts       = defaultSetupScriptOptions {+      -- The '--output-directory' sdist flag was introduced in Cabal 1.12, and+      -- '--list-sources' in 1.17.+      useCabalVersion = if isListSources+                        then orLaterVersion $ Version [1,17,0] []+                        else orLaterVersion $ Version [1,12,0] []+      }+    format        = fromFlag (sDistFormat exflags)+    createArchive = case format of+      TargzFormat -> createTarGzArchive+      ZipFormat   -> createZipArchive  tarBallName :: PackageDescription -> String tarBallName = display . packageId -overwriteSnapshotPackageDesc :: Verbosity          -- ^verbosity-                             -> PackageDescription -- ^info from the cabal file-                             -> FilePath           -- ^source tree-                             -> IO ()-overwriteSnapshotPackageDesc verbosity pkg targetDir = do-    -- We could just writePackageDescription targetDescFile pkg_descr,-    -- but that would lose comments and formatting.-    descFile <- defaultPackageDesc verbosity-    withUTF8FileContents descFile $-      writeUTF8File (targetDir </> descFile)-        . unlines . map (replaceVersion (packageVersion pkg)) . lines--  where-    replaceVersion :: Version -> String -> String-    replaceVersion version line-      | "version:" `isPrefixOf` map toLower line-                  = "version: " ++ display version-      | otherwise = line---- | Create an archive from a tree of source files.----createArchive :: Verbosity-              -> ArchiveFormat-              -> PackageDescription-              -> FilePath-              -> FilePath-              -> IO FilePath-createArchive _verbosity TargzFormat pkg tmpDir targetPref = do+-- | Create a tar.gz archive from a tree of source files.+createTarGzArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath+                    -> IO ()+createTarGzArchive verbosity pkg tmpDir targetPref = do     createTarGzFile tarBallFilePath tmpDir (tarBallName pkg)-    return tarBallFilePath+    notice verbosity $ "Source tarball created: " ++ tarBallFilePath   where     tarBallFilePath = targetPref </> tarBallName pkg <.> "tar.gz" -createArchive verbosity ZipFormat pkg tmpDir targetPref = do-    createZipFile verbosity zipFilePath tmpDir (tarBallName pkg)-    return zipFilePath-  where-    zipFilePath = targetPref </> tarBallName pkg <.> "zip"--createZipFile :: Verbosity -> FilePath -> FilePath -> FilePath -> IO ()-createZipFile verbosity zipfile base dir = do+-- | Create a zip archive from a tree of source files.+createZipArchive :: Verbosity -> PackageDescription -> FilePath -> FilePath+                    -> IO ()+createZipArchive verbosity pkg tmpDir targetPref = do+    let dir       = tarBallName pkg+        zipfile   = targetPref </> dir <.> "zip"     (zipProg, _) <- requireProgram verbosity zipProgram emptyProgramDb      -- zip has an annoying habbit of updating the target rather than creating@@ -146,15 +124,19 @@     alreadyExists <- doesFileExist zipfile     when alreadyExists $ removeFile zipfile -    -- we call zip with a different CWD, so have to make the path absolute-    zipfileAbs <- canonicalizePath zipfile+    -- We call zip with a different CWD, so have to make the path+    -- absolute. Can't just use 'canonicalizePath zipfile' since this function+    -- requires its argument to refer to an existing file.+    zipfileAbs <- fmap (</> dir <.> "zip") . canonicalizePath $ targetPref      --TODO: use runProgramInvocation, but has to be able to set CWD-    hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir] (Just base)+    hnd <- runProcess (programPath zipProg) ["-q", "-r", zipfileAbs, dir]+                      (Just tmpDir)                       Nothing Nothing Nothing Nothing     exitCode <- waitForProcess hnd     unless (exitCode == ExitSuccess) $       die $ "Generating the zip file failed "          ++ "(zip returned exit code " ++ show exitCode ++ ")"+    notice verbosity $ "Source zip archive created: " ++ zipfile   where     zipProgram = simpleProgram "zip"
cabal/cabal-install/Distribution/Client/Tar.hs view
@@ -40,6 +40,8 @@   TypeCode,   Format(..),   buildTreeRefTypeCode,+  buildTreeSnapshotTypeCode,+  isBuildTreeRefTypeCode,   entrySizeInBlocks,   entrySizeInBytes, @@ -69,7 +71,8 @@ import Data.Bits     (Bits, shiftL, testBit) import Data.List     (foldl') import Numeric       (readOct, showOct)-import Control.Monad (MonadPlus(mplus), when)+import Control.Applicative (Applicative(..))+import Control.Monad (MonadPlus(mplus), when, ap, liftM) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as BS import qualified Data.ByteString.Lazy.Char8 as BS.Char8@@ -83,15 +86,16 @@ import qualified System.FilePath.Windows as FilePath.Windows import qualified System.FilePath.Posix   as FilePath.Posix import System.Directory-         ( getDirectoryContents, doesDirectoryExist, getModificationTime+         ( getDirectoryContents, doesDirectoryExist          , getPermissions, createDirectoryIfMissing, copyFile ) import qualified System.Directory as Permissions          ( Permissions(executable) )-import Distribution.Compat.FilePerms+import Distribution.Client.Compat.FilePerms          ( setFileExecutable ) import System.Posix.Types          ( FileMode )-import Distribution.Compat.Time+import Distribution.Client.Compat.Time+         ( EpochTime, getModTime ) import System.IO          ( IOMode(ReadMode), openBinaryFile, hFileSize ) import System.IO.Unsafe (unsafeInterleaveIO)@@ -114,8 +118,9 @@                  -> FilePath -- ^ Expected subdir (to check for tarbombs)                  -> FilePath -- ^ Tarball                 -> IO ()-extractTarGzFile dir expected tar = do-  unpack dir . checkTarbomb expected . read . GZipUtils.maybeDecompress =<< BS.readFile tar+extractTarGzFile dir expected tar =+  unpack dir . checkTarbomb expected . read+  . GZipUtils.maybeDecompress =<< BS.readFile tar  -- -- * Entry type@@ -158,6 +163,17 @@ buildTreeRefTypeCode :: TypeCode buildTreeRefTypeCode = 'C' +-- | Type code for the local build tree snapshot entry type.+buildTreeSnapshotTypeCode :: TypeCode+buildTreeSnapshotTypeCode = 'S'++-- | Is this a type code for a build tree reference?+isBuildTreeRefTypeCode :: TypeCode -> Bool+isBuildTreeRefTypeCode typeCode+  | (typeCode == buildTreeRefTypeCode+     || typeCode == buildTreeSnapshotTypeCode) = True+  | otherwise                                  = False+ -- | Native 'FilePath' of the file or directory within the archive. -- entryPath :: Entry -> FilePath@@ -363,7 +379,7 @@     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 (_     , _ : _)  -> Left "File name too long (cannot split)"       Right (prefix, [])     -> Right (TarPath name prefix)       where         -- drop the '/' between the name and prefix:@@ -495,7 +511,7 @@       | not (FilePath.Native.isValid name)       = Just $ "Invalid file name in tar archive: " ++ show name -      | any (=="..") (FilePath.Native.splitDirectories name)+      | ".." `elem` FilePath.Native.splitDirectories name       = Just $ "Invalid file name in tar archive: " ++ show name        | otherwise = Nothing@@ -513,8 +529,10 @@ 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+    s -> Just $ "File in tar archive is not in the expected directory. "+             ++ "Expected: " ++ show expectedTopDir+             ++ " but got the following hierarchy: "+             ++ show s   --@@ -651,7 +669,8 @@ 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+getString off len = BS.Char8.unpack . BS.Char8.takeWhile (/='\0')+                    . getBytes off len  data Partial a = Error String | Ok a @@ -659,6 +678,13 @@ partial (Error msg) = Left msg partial (Ok x)      = Right x +instance Functor Partial where+    fmap          = liftM++instance Applicative Partial where+    pure          = return+    (<*>)         = ap+ instance Monad Partial where     return        = Ok     Error m >>= _ = Error m@@ -679,7 +705,7 @@  -- | Same as 'write', but for 'Entries'. writeEntries :: Entries -> ByteString-writeEntries entries = BS.concat $ foldrEntries (\e res -> (putEntry e):res)+writeEntries entries = BS.concat $ foldrEntries (\e res -> putEntry e : res)                        [BS.replicate (512*2) 0] error entries  putEntry :: Entry -> ByteString@@ -694,10 +720,10 @@  putHeader :: Entry -> ByteString putHeader entry =-     BS.concat $ [ BS.take 148 block-                 , BS.Char8.pack $ putOct 7 checksum-                 , BS.Char8.singleton ' '-                 , BS.drop 156 block ]+     BS.concat [ BS.take 148 block+               , BS.Char8.pack $ putOct 7 checksum+               , BS.Char8.singleton ' '+               , BS.drop 156 block ]   where     -- putHeaderNoChkSum returns a String, so we convert it to the final     -- representation before calculating the checksum.
cabal/cabal-install/Distribution/Client/Targets.hs view
@@ -70,7 +70,7 @@          ( Text(..), display ) import Distribution.Verbosity (Verbosity) import Distribution.Simple.Utils-         ( die, warn, intercalate, findPackageDesc, fromUTF8, lowercase )+         ( die, warn, intercalate, tryFindPackageDesc, fromUTF8, lowercase )  import Data.List          ( find, nub )@@ -177,7 +177,6 @@    | SpecificSourcePackage pkg   deriving Show - pkgSpecifierTarget :: Package pkg => PackageSpecifier pkg -> PackageName pkgSpecifierTarget (NamedPackage name _)       = name pkgSpecifierTarget (SpecificSourcePackage pkg) = packageName pkg@@ -423,7 +422,7 @@      UserTargetLocalCabalFile file -> do       let dir = takeDirectory file-      _   <- findPackageDesc dir -- just as a check+      _   <- tryFindPackageDesc dir -- just as a check       return [ PackageTargetLocation (LocalUnpackedPackage dir) ]      UserTargetLocalTarball tarballFile ->@@ -469,12 +468,13 @@     PackageTargetLocation location -> case location of        LocalUnpackedPackage dir -> do-        pkg <- readPackageDescription verbosity =<< findPackageDesc dir+        pkg <- readPackageDescription verbosity =<< tryFindPackageDesc dir         return $ PackageTargetLocation $                    SourcePackage {-                     packageInfoId      = packageId pkg,-                     packageDescription = pkg,-                     packageSource      = fmap Just location+                     packageInfoId        = packageId pkg,+                     packageDescription   = pkg,+                     packageSource        = fmap Just location,+                     packageDescrOverride = Nothing                    }        LocalTarballPackage tarballFile ->@@ -497,9 +497,10 @@         Just pkg ->           return $ PackageTargetLocation $                      SourcePackage {-                       packageInfoId      = packageId pkg,-                       packageDescription = pkg,-                       packageSource      = fmap Just location+                       packageInfoId        = packageId pkg,+                       packageDescription   = pkg,+                       packageSource        = fmap Just location,+                       packageDescrOverride = Nothing                      }      extractTarballPackageCabalFile :: FilePath -> String@@ -706,17 +707,22 @@  --FIXME: use Text instance for FlagName and FlagAssignment instance Text UserConstraint where-  disp (UserConstraintVersion   pkgname verrange) = disp pkgname <+> disp verrange-  disp (UserConstraintInstalled pkgname)          = disp pkgname <+> Disp.text "installed"-  disp (UserConstraintSource    pkgname)          = disp pkgname <+> Disp.text "source"-  disp (UserConstraintFlags     pkgname flags)    = disp pkgname <+> dispFlagAssignment flags+  disp (UserConstraintVersion   pkgname verrange) = disp pkgname+                                                    <+> disp verrange+  disp (UserConstraintInstalled pkgname)          = disp pkgname+                                                    <+> Disp.text "installed"+  disp (UserConstraintSource    pkgname)          = disp pkgname+                                                    <+> Disp.text "source"+  disp (UserConstraintFlags     pkgname flags)    = disp pkgname+                                                    <+> dispFlagAssignment flags     where       dispFlagAssignment = Disp.hsep . map dispFlagValue       dispFlagValue (f, True)   = Disp.char '+' <> dispFlagName f       dispFlagValue (f, False)  = Disp.char '-' <> dispFlagName f       dispFlagName (FlagName f) = Disp.text f -  disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname <+> dispStanzas stanzas+  disp (UserConstraintStanzas   pkgname stanzas)  = disp pkgname+                                                    <+> dispStanzas stanzas     where       dispStanzas = Disp.hsep . map dispStanza       dispStanza TestStanzas  = Disp.text "test"@@ -727,7 +733,7 @@       spaces = Parse.satisfy isSpace >> Parse.skipSpaces        parseConstraint pkgname =-            (parse >>= return . UserConstraintVersion pkgname)+            ((parse >>= return . UserConstraintVersion pkgname)         +++ (do spaces                 _ <- Parse.string "installed"                 return (UserConstraintInstalled pkgname))@@ -739,7 +745,7 @@                 return (UserConstraintStanzas pkgname [TestStanzas]))         +++ (do spaces                 _ <- Parse.string "bench"-                return (UserConstraintStanzas pkgname [BenchStanzas]))+                return (UserConstraintStanzas pkgname [BenchStanzas])))         <++ (parseFlagAssignment >>= (return . UserConstraintFlags pkgname))        parseFlagAssignment = Parse.many1 (spaces >> parseFlagValue)
cabal/cabal-install/Distribution/Client/Types.hs view
@@ -29,7 +29,8 @@  import Data.Map (Map) import Network.URI (URI)-import Distribution.Compat.ExceptionCI+import Data.ByteString.Lazy (ByteString)+import Control.Exception          ( SomeException )  newtype Username = Username { unUsername :: String }@@ -90,16 +91,42 @@ instance PackageFixedDeps ConfiguredPackage where   depends (ConfiguredPackage _ _ _ deps) = deps +-- | Like 'ConfiguredPackage', but with all dependencies guaranteed to be+-- installed already, hence itself ready to be installed.+data ReadyPackage = ReadyPackage+       SourcePackage           -- see 'ConfiguredPackage'.+       FlagAssignment          --+       [OptionalStanza]        --+       [InstalledPackageInfo]  -- Installed dependencies.+  deriving Show +instance Package ReadyPackage where+  packageId (ReadyPackage pkg _ _ _) = packageId pkg++instance PackageFixedDeps ReadyPackage where+  depends (ReadyPackage _ _ _ deps) = map packageId deps++-- | Sometimes we need to convert a 'ReadyPackage' back to a+-- 'ConfiguredPackage'. For example, a failed 'PlanPackage' can be *either*+-- Ready or Configured.+readyPackageToConfiguredPackage :: ReadyPackage -> ConfiguredPackage+readyPackageToConfiguredPackage (ReadyPackage srcpkg flags stanzas deps) =+  ConfiguredPackage srcpkg flags stanzas (map packageId deps)+ -- | A package description along with the location of the package sources. -- data SourcePackage = SourcePackage {-    packageInfoId      :: PackageId,-    packageDescription :: GenericPackageDescription,-    packageSource      :: PackageLocation (Maybe FilePath)+    packageInfoId        :: PackageId,+    packageDescription   :: GenericPackageDescription,+    packageSource        :: PackageLocation (Maybe FilePath),+    packageDescrOverride :: PackageDescriptionOverride   }   deriving Show +-- | We sometimes need to override the .cabal file in the tarball with+-- the newer one from the package index.+type PackageDescriptionOverride = Maybe ByteString+ instance Package SourcePackage where packageId = packageInfoId  data OptionalStanza@@ -182,6 +209,7 @@                   | TestsFailed     SomeException                   | InstallFailed   SomeException data BuildSuccess = BuildOk         DocsResult TestsResult+                                    (Maybe InstalledPackageInfo)  data DocsResult  = DocsNotTried  | DocsFailed  | DocsOk data TestsResult = TestsNotTried | TestsOk
− cabal/cabal-install/Distribution/Client/Unpack.hs 
@@ -1,123 +0,0 @@--------------------------------------------------------------------------------- |--- Module      :  Distribution.Client.Unpack--- Copyright   :  (c) Andrea Vezzosi 2008---                    Duncan Coutts 2011--- License     :  BSD-like------ Maintainer  :  cabal-devel@haskell.org--- Stability   :  provisional--- Portability :  portable-------------------------------------------------------------------------------------module Distribution.Client.Unpack (--    -- * Commands-    unpack,--  ) where--import Distribution.Package-         ( PackageId, packageId )-import Distribution.Simple.Setup-         ( fromFlag, fromFlagOrDefault )-import Distribution.Simple.Utils-         ( notice, die )-import Distribution.Verbosity-         ( Verbosity )-import Distribution.Text(display)--import Distribution.Client.Setup-         ( GlobalFlags(..), UnpackFlags(..) )-import Distribution.Client.Types-import Distribution.Client.Targets-import Distribution.Client.Dependency-import Distribution.Client.FetchUtils-import qualified Distribution.Client.Tar as Tar (extractTarGzFile)-import Distribution.Client.IndexUtils as IndexUtils-        ( getSourcePackages )--import System.Directory-         ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist )-import Control.Monad-         ( unless, when )-import Data.Monoid-         ( mempty )-import System.FilePath-         ( (</>), addTrailingPathSeparator )---unpack :: Verbosity-       -> [Repo]-       -> GlobalFlags-       -> UnpackFlags-       -> [UserTarget] -       -> IO ()-unpack verbosity _ _ _ [] =-    notice verbosity "No packages requested. Nothing to do."--unpack verbosity repos globalFlags unpackFlags userTargets = do-  mapM_ checkTarget userTargets--  sourcePkgDb   <- getSourcePackages verbosity repos--  pkgSpecifiers <- resolveUserTargets verbosity-                     (fromFlag $ globalWorldFile globalFlags)-                     (packageIndex sourcePkgDb)-                     userTargets--  pkgs <- either (die . unlines . map show) return $-            resolveWithoutDependencies-              (resolverParams sourcePkgDb pkgSpecifiers)--  unless (null prefix) $-         createDirectoryIfMissing True prefix--  flip mapM_ pkgs $ \pkg -> do-    location <- fetchPackage verbosity (packageSource pkg)-    let pkgid = packageId pkg-    case location of-      LocalTarballPackage tarballPath ->-        unpackPackage verbosity prefix pkgid tarballPath--      RemoteTarballPackage _tarballURL tarballPath ->-        unpackPackage verbosity prefix pkgid tarballPath--      RepoTarballPackage _repo _pkgid tarballPath ->-        unpackPackage verbosity prefix pkgid tarballPath--      LocalUnpackedPackage _ ->-        error "Distribution.Client.Unpack.unpack: the impossible happened."--  where-    resolverParams sourcePkgDb pkgSpecifiers =-        --TODO: add commandline constraint and preference args for unpack--        standardInstallPolicy mempty sourcePkgDb pkgSpecifiers--    prefix = fromFlagOrDefault "" (unpackDestDir unpackFlags)--checkTarget :: UserTarget -> IO ()-checkTarget target = case target of-    UserTargetLocalDir       dir  -> die (notTarball dir)-    UserTargetLocalCabalFile file -> die (notTarball file)-    _                             -> return ()-  where-    notTarball t =-        "The 'unpack' command is for tarball packages. "-     ++ "The target '" ++ t ++ "' is not a tarball."--unpackPackage :: Verbosity -> FilePath -> PackageId -> FilePath -> IO ()-unpackPackage verbosity prefix pkgid pkgPath = do-    let pkgdirname = display pkgid-        pkgdir     = prefix </> pkgdirname-        pkgdir'    = addTrailingPathSeparator pkgdir-    existsDir  <- doesDirectoryExist pkgdir-    when existsDir $ die $-     "The directory \"" ++ pkgdir' ++ "\" already exists, not unpacking."-    existsFile  <- doesFileExist pkgdir-    when existsFile $ die $-     "A file \"" ++ pkgdir ++ "\" is in the way, not unpacking."-    notice verbosity $ "Unpacking to " ++ pkgdir'-    Tar.extractTarGzFile prefix pkgdirname pkgPath
cabal/cabal-install/Distribution/Client/Update.hs view
@@ -16,6 +16,8 @@  import Distribution.Client.Types          ( Repo(..), RemoteRepo(..), LocalRepo(..), SourcePackageDb(..) )+import Distribution.Client.HttpUtils+         ( DownloadResult(..) ) import Distribution.Client.FetchUtils          ( downloadIndex ) import qualified Distribution.Client.PackageIndex as PackageIndex@@ -38,11 +40,11 @@ import qualified Data.Map as Map import System.FilePath (dropExtension) import Data.Maybe      (fromMaybe)-import Control.Monad   (when)+import Control.Monad   (unless)  -- | 'update' downloads the package list from all known servers update :: Verbosity -> [Repo] -> IO ()-update verbosity [] = do+update verbosity [] =   warn verbosity $ "No remote package servers have been specified. Usually "                 ++ "you would have one specified in the config file." update verbosity repos = do@@ -55,10 +57,13 @@   Left remoteRepo -> do     notice verbosity $ "Downloading the latest package list from "                     ++ remoteRepoName remoteRepo-    indexPath <- downloadIndex verbosity remoteRepo (repoLocalDir repo)-    writeFileAtomic (dropExtension indexPath) . maybeDecompress-                                            =<< BS.readFile indexPath-    updateRepoIndexCache verbosity repo+    downloadResult <- downloadIndex verbosity remoteRepo (repoLocalDir repo)+    case downloadResult of+      FileAlreadyInCache -> return ()+      FileDownloaded indexPath -> do+        writeFileAtomic (dropExtension indexPath) . maybeDecompress+                                                =<< BS.readFile indexPath+        updateRepoIndexCache verbosity repo  checkForSelfUpgrade :: Verbosity -> [Repo] -> IO () checkForSelfUpgrade verbosity repos = do@@ -74,7 +79,7 @@         , version > currentVersion         , version `withinRange` preferredVersionRange ] -  when (not (null laterPreferredVersions)) $+  unless (null laterPreferredVersions) $     notice verbosity $          "Note: there is a new version of cabal-install available.\n"       ++ "To upgrade, run: cabal install cabal-install"
cabal/cabal-install/Distribution/Client/Upload.hs view
@@ -3,6 +3,9 @@  module Distribution.Client.Upload (check, upload, report) where +import qualified Data.ByteString.Lazy.Char8 as B (concat, length, pack, readFile, unpack)+import           Data.ByteString.Lazy.Char8 (ByteString)+ import Distribution.Client.Types (Username(..), Password(..),Repo(..),RemoteRepo(..)) import Distribution.Client.HttpUtils (isOldHackageURI, cabalBrowse) @@ -25,8 +28,7 @@  import Data.Char        (intToDigit) import Numeric          (showHex)-import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho-                        ,openBinaryFile, IOMode(ReadMode), hGetContents)+import System.IO        (hFlush, stdin, stdout, hGetEcho, hSetEcho) import Control.Exception (bracket) import System.Random    (randomRIO) import System.FilePath  ((</>), takeExtension, takeFileName)@@ -120,7 +122,7 @@             notice verbosity $ "Checking " ++ path ++ "... "             handlePackage verbosity checkURI (return ()) path -handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream String) ()+handlePackage :: Verbosity -> URI -> BrowserAction (HandleStream ByteString) ()               -> FilePath -> IO () handlePackage verbosity uri auth path =   do req <- mkRequest uri path@@ -135,31 +137,31 @@                      case findHeader HdrContentType resp of                        Just contenttype                          | takeWhile (/= ';') contenttype == "text/plain"-                         -> notice verbosity $ rspBody resp-                       _ -> debug verbosity $ rspBody resp+                         -> notice verbosity $ B.unpack $ rspBody resp+                       _ -> debug verbosity $ B.unpack $ rspBody resp -mkRequest :: URI -> FilePath -> IO (Request String)+mkRequest :: URI -> FilePath -> IO (Request ByteString) mkRequest uri path =      do pkg <- readBinaryFile path        boundary <- genBoundary-       let body = printMultiPart boundary (mkFormData path pkg)+       let body = printMultiPart (B.pack boundary) (mkFormData path pkg)        return $ Request {                          rqURI = uri,                          rqMethod = POST,                          rqHeaders = [Header HdrContentType ("multipart/form-data; boundary="++boundary),-                                      Header HdrContentLength (show (length body)),+                                      Header HdrContentLength (show (B.length body)),                                       Header HdrAccept ("text/plain")],                          rqBody = body                         } -readBinaryFile :: FilePath -> IO String-readBinaryFile path = openBinaryFile path ReadMode >>= hGetContents+readBinaryFile :: FilePath -> IO ByteString+readBinaryFile = B.readFile  genBoundary :: IO String genBoundary = do i <- randomRIO (0x10000000000000,0xFFFFFFFFFFFFFF) :: IO Integer                  return $ showHex i "" -mkFormData :: FilePath -> String -> [BodyPart]+mkFormData :: FilePath -> ByteString -> [BodyPart] mkFormData path pkg =   -- yes, web browsers are that stupid (re quoting)   [BodyPart [Header hdrContentDisposition $@@ -172,14 +174,17 @@  -- * Multipart, partly stolen from the cgi package. -data BodyPart = BodyPart [Header] String+data BodyPart = BodyPart [Header] ByteString -printMultiPart :: String -> [BodyPart] -> String-printMultiPart boundary xs = -    concatMap (printBodyPart boundary) xs ++ crlf ++ "--" ++ boundary ++ "--" ++ crlf+printMultiPart :: ByteString -> [BodyPart] -> ByteString+printMultiPart boundary xs =+    B.concat $ map (printBodyPart boundary) xs ++ [crlf, dd, boundary, dd, crlf] -printBodyPart :: String -> BodyPart -> String-printBodyPart boundary (BodyPart hs c) = crlf ++ "--" ++ boundary ++ crlf ++ concatMap show hs ++ crlf ++ c+printBodyPart :: ByteString -> BodyPart -> ByteString+printBodyPart boundary (BodyPart hs c) = B.concat $ [crlf, dd, boundary, crlf] ++ map (B.pack . show) hs ++ [crlf, c] -crlf :: String-crlf = "\r\n"+crlf :: ByteString+crlf = B.pack "\r\n"++dd :: ByteString+dd = B.pack "--"
cabal/cabal-install/Distribution/Client/Utils.hs view
@@ -1,13 +1,21 @@-{-# LANGUAGE ForeignFunctionInterface #-}+{-# LANGUAGE ForeignFunctionInterface, CPP #-}  module Distribution.Client.Utils ( MergeResult(..)                                  , mergeBy, duplicates, duplicatesBy-                                 , moreRecentFile, inDir, numberOfProcessors+                                 , inDir, determineNumJobs, numberOfProcessors+                                 , removeExistingFile                                  , makeAbsoluteToCwd, filePathToByteString-                                 , byteStringToFilePath)+                                 , byteStringToFilePath, tryCanonicalizePath+                                 , canonicalizePathNoThrow+                                 , moreRecentFile, existsAndIsMoreRecentThan )        where +import Distribution.Compat.Exception   ( catchIO )+import Distribution.Client.Compat.Time ( getModTime )+import Distribution.Simple.Setup       ( Flag(..) ) import qualified Data.ByteString.Lazy as BS+import Control.Monad+         ( when ) import Data.Bits          ( (.|.), shiftL, shiftR ) import Data.Char@@ -20,12 +28,19 @@ import qualified Control.Exception as Exception          ( finally ) import System.Directory-         ( doesFileExist, getModificationTime-         , getCurrentDirectory, setCurrentDirectory )+         ( canonicalizePath, doesFileExist, getCurrentDirectory+         , removeFile, setCurrentDirectory ) import System.FilePath          ( (</>), isAbsolute ) import System.IO.Unsafe ( unsafePerformIO ) +#if defined(mingw32_HOST_OS)+import Prelude hiding (ioError)+import Control.Monad (liftM2, unless)+import System.Directory (doesDirectoryExist)+import System.IO.Error (ioError, mkIOError, doesNotExistErrorType)+#endif+ -- | Generic merging utility. For sorted input lists this is a full outer join. -- -- * The result list never contains @(Nothing, Nothing)@.@@ -55,22 +70,16 @@     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)+-- | Like 'removeFile', but does not throw an exception when the file does not+-- exist.+removeExistingFile :: FilePath -> IO ()+removeExistingFile path = do+  exists <- doesFileExist path+  when exists $+    removeFile path  -- | Executes the action in the specified directory.-inDir :: Maybe FilePath -> IO () -> IO ()+inDir :: Maybe FilePath -> IO a -> IO a inDir Nothing m = m inDir (Just d) m = do   old <- getCurrentDirectory@@ -84,6 +93,14 @@ numberOfProcessors :: Int numberOfProcessors = fromEnum $ unsafePerformIO c_getNumberOfProcessors +-- | Determine the number of jobs to use given the value of the '-j' flag.+determineNumJobs :: Flag (Maybe Int) -> Int+determineNumJobs numJobsFlag =+  case numJobsFlag of+    NoFlag        -> 1+    Flag Nothing  -> numberOfProcessors+    Flag (Just n) -> n+ -- | Given a relative path, make it absolute relative to the current -- directory. Absolute paths are returned unmodified. makeAbsoluteToCwd :: FilePath -> IO FilePath@@ -125,3 +142,46 @@         b1 = fromIntegral $ BS.index bs (i + 1)         b2 = fromIntegral $ BS.index bs (i + 2)         b3 = fromIntegral $ BS.index bs (i + 3)++-- | Workaround for the inconsistent behaviour of 'canonicalizePath'. It throws+-- an error if the path refers to a non-existent file on *nix, but not on+-- Windows.+tryCanonicalizePath :: FilePath -> IO FilePath+tryCanonicalizePath path = do+  ret <- canonicalizePath path+#if defined(mingw32_HOST_OS)+  exists <- liftM2 (||) (doesFileExist ret) (doesDirectoryExist ret)+  unless exists $+    ioError $ mkIOError doesNotExistErrorType "canonicalizePath"+                        Nothing (Just ret)+#endif+  return ret++-- | A non-throwing wrapper for 'canonicalizePath'. If 'canonicalizePath' throws+-- an exception, returns the path argument unmodified.+canonicalizePathNoThrow :: FilePath -> IO FilePath+canonicalizePathNoThrow path = do+  canonicalizePath path `catchIO` (\_ -> return path)++--------------------+-- Modification time++-- | Like Distribution.Simple.Utils.moreRecentFile, but uses getModTime instead+-- of getModificationTime for higher precision. We can't merge the two because+-- Distribution.Client.Time uses MIN_VERSION macros.+moreRecentFile :: FilePath -> FilePath -> IO Bool+moreRecentFile a b = do+  exists <- doesFileExist b+  if not exists+    then return True+    else do tb <- getModTime b+            ta <- getModTime a+            return (ta > tb)++-- | Like 'moreRecentFile', but also checks that the first file exists.+existsAndIsMoreRecentThan :: FilePath -> FilePath -> IO Bool+existsAndIsMoreRecentThan a b = do+  exists <- doesFileExist a+  if not exists+    then return False+    else a `moreRecentFile` b
cabal/cabal-install/Distribution/Client/Win32SelfUpgrade.hs view
@@ -1,6 +1,4 @@ {-# LANGUAGE CPP, ForeignFunctionInterface #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp -fffi #-} ----------------------------------------------------------------------------- -- | -- Module      :  Distribution.Client.Win32SelfUpgrade@@ -122,7 +120,7 @@    let args = mkArgs (show ourPID) tmpPath   log $ "launching child " ++ unwords (dstPath : map show args)-  runProcess dstPath args Nothing Nothing Nothing Nothing Nothing+  _ <- 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
− cabal/cabal-install/Distribution/Compat/ExceptionCI.hs 
@@ -1,56 +0,0 @@-{-# LANGUAGE CPP #-}-{-# OPTIONS_GHC -cpp #-}-{-# OPTIONS_NHC98 -cpp #-}-{-# OPTIONS_JHC -fcpp #-}--- #hide-module Distribution.Compat.ExceptionCI (-  SomeException,-  onException,-  catchIO,-  handleIO,-  catchExit,-  throwIOIO-  ) where--import System.Exit-import qualified Control.Exception as Exception-#if MIN_VERSION_base(4,0,0)-import Control.Exception (SomeException)-#else-import Control.Exception (Exception)-type SomeException = Exception-#endif--onException :: IO a -> IO b -> IO a-#if MIN_VERSION_base(4,0,0)-onException = Exception.onException-#else-onException io what = io `Exception.catch` \e -> do what-                                                    Exception.throw e-#endif--throwIOIO :: Exception.IOException -> IO a-#if MIN_VERSION_base(4,0,0)-throwIOIO = Exception.throwIO-#else-throwIOIO = Exception.throwIO . Exception.IOException-#endif--catchIO :: IO a -> (Exception.IOException -> IO a) -> IO a-#if MIN_VERSION_base(4,0,0)-catchIO = Exception.catch-#else-catchIO = Exception.catchJust Exception.ioErrors-#endif--handleIO :: (Exception.IOException -> IO a) -> IO a -> IO a-handleIO = flip catchIO--catchExit :: IO a -> (ExitCode -> IO a) -> IO a-#if MIN_VERSION_base(4,0,0)-catchExit = Exception.catch-#else-catchExit = Exception.catchJust exitExceptions-    where exitExceptions (Exception.ExitException ee) = Just ee-          exitExceptions _                            = Nothing-#endif
− cabal/cabal-install/Distribution/Compat/FilePerms.hs 
@@ -1,40 +0,0 @@-{-# LANGUAGE CPP #-}--- #hide-module Distribution.Compat.FilePerms (-  setFileOrdinary,-  setFileExecutable,-  ) where--#ifndef mingw32_HOST_OS-import System.Posix.Types-         ( FileMode )-import System.Posix.Internals-         ( c_chmod )-import Foreign.C-         ( withCString )-#if MIN_VERSION_base(4,0,0)-import Foreign.C-         ( throwErrnoPathIfMinus1_ )-#else-import Foreign.C-         ( throwErrnoIfMinus1_ )-#endif-#endif /* mingw32_HOST_OS */--setFileOrdinary,  setFileExecutable  :: FilePath -> IO ()-#ifndef mingw32_HOST_OS-setFileOrdinary   path = setFileMode path 0o644 -- file perms -rw-r--r---setFileExecutable path = setFileMode path 0o755 -- file perms -rwxr-xr-x--setFileMode :: FilePath -> FileMode -> IO ()-setFileMode name m =-  withCString name $ \s -> do-#if __GLASGOW_HASKELL__ >= 608-    throwErrnoPathIfMinus1_ "setFileMode" name (c_chmod s m)-#else-    throwErrnoIfMinus1_                   name (c_chmod s m)-#endif-#else-setFileOrdinary   _ = return ()-setFileExecutable _ = return ()-#endif
− cabal/cabal-install/Distribution/Compat/Time.hs 
@@ -1,37 +0,0 @@-{-# LANGUAGE CPP #-}-module Distribution.Compat.Time where--import Data.Int (Int64)-import System.Directory (getModificationTime)--#if MIN_VERSION_directory(1,2,0)-import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds, posixDayLength)-import Data.Time (getCurrentTime, diffUTCTime)-#else-import System.Time (ClockTime(..), getClockTime, diffClockTimes, normalizeTimeDiff, tdDay)-#endif---- | The number of seconds since the UNIX epoch-type EpochTime = Int64--getModTime :: FilePath -> IO EpochTime-getModTime path =  do-#if MIN_VERSION_directory(1,2,0)-  (truncate . utcTimeToPOSIXSeconds) `fmap` getModificationTime path-#else-  (TOD s _) <- getModificationTime path-  return $! fromIntegral s-#endif---- | Return age of given file in days.-getFileAge :: FilePath -> IO Int-getFileAge file = do-  t0 <- getModificationTime file-#if MIN_VERSION_directory(1,2,0)-  t1 <- getCurrentTime-  let days = truncate $ (t1 `diffUTCTime` t0) / posixDayLength-#else-  t1 <- getClockTime-  let days = (tdDay . normalizeTimeDiff) (t1 `diffClockTimes` t0)-#endif-  return days
cabal/cabal-install/Main.hs view
@@ -17,34 +17,37 @@          ( GlobalFlags(..), globalCommand, globalRepos          , ConfigFlags(..)          , ConfigExFlags(..), defaultConfigExFlags, configureExCommand-         , BuildFlags(..), buildCommand+         , BuildFlags(..), BuildExFlags(..), SkipAddSourceDepsCheck(..)+         , buildCommand, testCommand, benchmarkCommand          , InstallFlags(..), defaultInstallFlags          , installCommand, upgradeCommand          , FetchFlags(..), fetchCommand+         , FreezeFlags(..), freezeCommand+         , GetFlags(..), getCommand, unpackCommand          , checkCommand          , updateCommand          , ListFlags(..), listCommand          , InfoFlags(..), infoCommand          , UploadFlags(..), uploadCommand          , ReportFlags(..), reportCommand+         , runCommand          , InitFlags(initVerbosity), initCommand          , SDistFlags(..), SDistExFlags(..), sdistCommand          , Win32SelfUpgradeFlags(..), win32SelfUpgradeCommand-         , IndexFlags(..), indexCommand-         , SandboxFlags(..), sandboxAddSourceCommand-         , sandboxConfigureCommand, sandboxBuildCommand, sandboxInstallCommand-         , dumpPkgEnvCommand+         , SandboxFlags(..), sandboxCommand          , reportCommand-         , unpackCommand, UnpackFlags(..) )+         ) import Distribution.Simple.Setup          ( HaddockFlags(..), haddockCommand          , HscolourFlags(..), hscolourCommand+         , ReplFlags(..), replCommand          , CopyFlags(..), copyCommand          , RegisterFlags(..), registerCommand          , CleanFlags(..), cleanCommand-         , TestFlags(..), testCommand-         , BenchmarkFlags(..), benchmarkCommand-         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag )+         , TestFlags(..), BenchmarkFlags(..)+         , Flag(..), fromFlag, fromFlagOrDefault, flagToMaybe, toFlag+         , configAbsolutePaths+         )  import Distribution.Client.SetupWrapper          ( setupWrapper, SetupScriptOptions(..), defaultSetupScriptOptions )@@ -52,54 +55,95 @@          ( SavedConfig(..), loadConfig, defaultConfigFile ) import Distribution.Client.Targets          ( readUserTargets )+import qualified Distribution.Client.List as List+         ( list, info ) -import Distribution.Client.List               (list, info)-import Distribution.Client.Install            (install, upgrade)+import Distribution.Client.Install            (install) import Distribution.Client.Configure          (configure) import Distribution.Client.Update             (update) import Distribution.Client.Fetch              (fetch)+import Distribution.Client.Freeze             (freeze) import Distribution.Client.Check as Check     (check) --import Distribution.Client.Clean            (clean) import Distribution.Client.Upload as Upload   (upload, check, report)+import Distribution.Client.Run                (run, splitRunArgs) import Distribution.Client.SrcDist            (sdist)-import Distribution.Client.Unpack             (unpack)-import Distribution.Client.Index              (index)-import Distribution.Client.Sandbox            (sandboxConfigure-                                              , sandboxAddSource, sandboxBuild-                                              , sandboxInstall-                                              , dumpPackageEnvironment)+import Distribution.Client.Get                (get)+import Distribution.Client.Sandbox            (sandboxInit+                                              ,sandboxAddSource+                                              ,sandboxDelete+                                              ,sandboxDeleteSource+                                              ,sandboxListSources+                                              ,sandboxHcPkg+                                              ,dumpPackageEnvironment++                                              ,getSandboxConfigFilePath+                                              ,loadConfigOrSandboxConfig+                                              ,initPackageDBIfNeeded+                                              ,maybeWithSandboxDirOnSearchPath+                                              ,maybeWithSandboxPackageInfo+                                              ,WereDepsReinstalled(..)+                                              ,maybeReinstallAddSourceDeps+                                              ,tryGetIndexFilePath+                                              ,sandboxBuildDir+                                              ,updateSandboxConfigFileFlag++                                              ,configCompilerAux'+                                              ,configPackageDB')+import Distribution.Client.Sandbox.PackageEnvironment+                                              (setPackageDB+                                              ,userPackageEnvironmentFile)+import Distribution.Client.Sandbox.Timestamp  (maybeAddCompilerTimestampRecord)+import Distribution.Client.Sandbox.Types      (UseSandbox(..), whenUsingSandbox) import Distribution.Client.Init               (initCabal) import qualified Distribution.Client.Win32SelfUpgrade as Win32SelfUpgrade+import Distribution.Client.Utils              (determineNumJobs+                                              ,existsAndIsMoreRecentThan) -import Distribution.Simple.Compiler-         ( Compiler, PackageDBStack )-import Distribution.Simple.Program-         ( ProgramConfiguration )+import Distribution.PackageDescription+         ( Executable(..) )+import Distribution.Simple.Build+         ( startInterpreter ) import Distribution.Simple.Command+         ( CommandParse(..), CommandUI(..), Command+         , commandsRun, commandAddAction, hiddenCommand )+import Distribution.Simple.Compiler+         ( Compiler(..) ) import Distribution.Simple.Configure-         ( checkPersistBuildConfigOutdated, configCompilerAux-         , interpretPackageDbFlags, maybeGetPersistBuildConfig )+         ( checkPersistBuildConfigOutdated, configCompilerAuxEx+         , ConfigStateFileErrorType(..), localBuildInfoFile+         , getPersistBuildConfig, tryGetPersistBuildConfig ) import qualified Distribution.Simple.LocalBuildInfo as LBI+import Distribution.Simple.Program (defaultProgramConfiguration)+import qualified Distribution.Simple.Setup as Cabal import Distribution.Simple.Utils-         ( cabalVersion, die, intercalate, notice, topHandler )+         ( cabalVersion, die, notice, info, topHandler, findPackageDesc ) import Distribution.Text          ( display ) import Distribution.Verbosity as Verbosity-       ( Verbosity, normal, lessVerbose )+         ( Verbosity, normal )+import Distribution.Version+         ( Version(..), orLaterVersion ) import qualified Paths_cabal_install (version)  import System.Environment       (getArgs, getProgName) import System.Exit              (exitFailure) import System.FilePath          (splitExtension, takeExtension)-import System.Directory         (doesFileExist)-import Data.List                (intersperse)+import System.IO                (BufferMode(LineBuffering),+                                 hSetBuffering, stdout)+import System.Directory         (doesFileExist, getCurrentDirectory)+import Data.List                (intercalate) import Data.Monoid              (Monoid(..)) import Control.Monad            (when, unless)  -- | Entry point -- main :: IO ()-main = getArgs >>= mainWorker+main = do+  -- Enable line buffering so that we can get fast feedback even when piped.+  -- This is especially important for CI and build systems.+  hSetBuffering stdout LineBuffering+  getArgs >>= mainWorker  mainWorker :: [String] -> IO () mainWorker args = topHandler $@@ -107,14 +151,18 @@     CommandHelp   help                 -> printGlobalHelp help     CommandList   opts                 -> printOptionsList opts     CommandErrors errs                 -> printErrors errs-    CommandReadyToGo (globalflags, commandParse)  ->+    CommandReadyToGo (globalFlags, commandParse)  ->       case commandParse of-        _ | fromFlag (globalVersion globalflags)        -> printVersion-          | fromFlag (globalNumericVersion globalflags) -> printNumericVersion+        _ | fromFlagOrDefault False (globalVersion globalFlags)+            -> printVersion+          | fromFlagOrDefault False (globalNumericVersion globalFlags)+            -> printNumericVersion         CommandHelp     help           -> printCommandHelp help         CommandList     opts           -> printOptionsList opts         CommandErrors   errs           -> printErrors errs-        CommandReadyToGo action        -> action globalflags+        CommandReadyToGo action        -> do+          globalFlags' <- updateSandboxConfigFileFlag globalFlags+          action globalFlags'    where     printCommandHelp help = do@@ -126,8 +174,12 @@       putStr (help pname)       putStr $ "\nYou can edit the cabal configuration file to set defaults:\n"             ++ "  " ++ configFile ++ "\n"+      exists <- doesFileExist configFile+      when (not exists) $+          putStrLn $ "This file will be generated with sensible "+                  ++ "defaults if you run 'cabal update'."     printOptionsList = putStr . unlines-    printErrors errs = die $ concat (intersperse "\n" errs)+    printErrors errs = die $ intercalate "\n" errs     printNumericVersion = putStrLn $ display Paths_cabal_install.version     printVersion        = putStrLn $ "cabal-install version "                                   ++ display Paths_cabal_install.version@@ -141,14 +193,21 @@       ,listCommand            `commandAddAction` listAction       ,infoCommand            `commandAddAction` infoAction       ,fetchCommand           `commandAddAction` fetchAction-      ,unpackCommand          `commandAddAction` unpackAction+      ,freezeCommand          `commandAddAction` freezeAction+      ,getCommand             `commandAddAction` getAction+      ,hiddenCommand $+       unpackCommand          `commandAddAction` unpackAction       ,checkCommand           `commandAddAction` checkAction       ,sdistCommand           `commandAddAction` sdistAction       ,uploadCommand          `commandAddAction` uploadAction       ,reportCommand          `commandAddAction` reportAction+      ,runCommand             `commandAddAction` runAction       ,initCommand            `commandAddAction` initAction       ,configureExCommand     `commandAddAction` configureAction       ,buildCommand           `commandAddAction` buildAction+      ,replCommand defaultProgramConfiguration+                              `commandAddAction` replAction+      ,sandboxCommand         `commandAddAction` sandboxAction       ,wrapperAction copyCommand                      copyVerbosity     copyDistPref       ,wrapperAction haddockCommand@@ -161,21 +220,10 @@                      regVerbosity      regDistPref       ,testCommand            `commandAddAction` testAction       ,benchmarkCommand       `commandAddAction` benchmarkAction-      ,upgradeCommand         `commandAddAction` upgradeAction       ,hiddenCommand $-       win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction-      ,hiddenCommand $-       indexCommand `commandAddAction` indexAction-      ,hiddenCommand $-       sandboxConfigureCommand `commandAddAction` sandboxConfigureAction-      ,hiddenCommand $-       sandboxAddSourceCommand `commandAddAction` sandboxAddSourceAction-      ,hiddenCommand $-       sandboxBuildCommand `commandAddAction` sandboxBuildAction-      ,hiddenCommand $-       sandboxInstallCommand `commandAddAction` sandboxInstallAction+       upgradeCommand         `commandAddAction` upgradeAction       ,hiddenCommand $-       dumpPkgEnvCommand `commandAddAction` dumpPkgEnvAction+       win32SelfUpgradeCommand`commandAddAction` win32SelfUpgradeAction       ]  wrapperAction :: Monoid flags@@ -199,39 +247,134 @@                 -> [String] -> GlobalFlags -> IO () configureAction (configFlags, configExFlags) extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)++  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                          globalFlags (configUserInstall configFlags)   let configFlags'   = savedConfigureFlags   config `mappend` configFlags       configExFlags' = savedConfigureExFlags config `mappend` configExFlags       globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags'-  configure verbosity-            (configPackageDB' configFlags') (globalRepos globalFlags')-            comp conf configFlags' configExFlags' extraArgs+  (comp, platform, conf) <- configCompilerAuxEx configFlags' -buildAction :: BuildFlags -> [String] -> GlobalFlags -> IO ()-buildAction buildFlags extraArgs globalFlags = do-    let distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                                     (buildDistPref buildFlags)-        verbosity = fromFlagOrDefault normal (buildVerbosity buildFlags)+  -- If we're working inside a sandbox and the user has set the -w option, we+  -- may need to create a sandbox-local package DB for this compiler and add a+  -- timestamp record for this compiler to the timestamp file.+  let configFlags''  = case useSandbox of+        NoSandbox               -> configFlags'+        (UseSandbox sandboxDir) -> setPackageDB sandboxDir+                                   comp platform configFlags' -    reconfigure verbosity distPref mempty [] globalFlags (const Nothing)-    build verbosity distPref buildFlags extraArgs+  whenUsingSandbox useSandbox $ \sandboxDir -> do+    initPackageDBIfNeeded verbosity configFlags'' comp conf +    indexFile     <- tryGetIndexFilePath config+    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+      (compilerId comp) platform++  maybeWithSandboxDirOnSearchPath useSandbox $+    configure verbosity+              (configPackageDB' configFlags'')+              (globalRepos globalFlags')+              comp platform conf configFlags'' configExFlags' extraArgs++buildAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+buildAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                    (buildDistPref buildFlags)+      verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)++  -- Calls 'configureAction' to do the real work, so nothing special has to be+  -- done to support sandboxes.+  (useSandbox, config) <- reconfigure verbosity distPref+                          mempty [] globalFlags noAddSource+                          (buildNumJobs buildFlags) (const Nothing)++  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags extraArgs++ -- | Actually do the work of building the package. This is separate from -- 'buildAction' so that 'testAction' and 'benchmarkAction' do not invoke -- 'reconfigure' twice.-build :: Verbosity -> FilePath -> BuildFlags -> [String] -> IO ()-build verbosity distPref buildFlags extraArgs =-    setupWrapper verbosity setupOptions Nothing-                 buildCommand (const buildFlags') extraArgs-  where +build :: Verbosity -> SavedConfig -> FilePath -> BuildFlags -> [String] -> IO ()+build verbosity config distPref buildFlags extraArgs =+  setupWrapper verbosity setupOptions Nothing+               (Cabal.buildCommand progConf) mkBuildFlags extraArgs+  where+    progConf     = defaultProgramConfiguration     setupOptions = defaultSetupScriptOptions { useDistPref = distPref }++    mkBuildFlags version = filterBuildFlags version config buildFlags'     buildFlags' = buildFlags-        { buildVerbosity = toFlag verbosity-        , buildDistPref = toFlag distPref-        }+      { buildVerbosity = toFlag verbosity+      , buildDistPref  = toFlag distPref+      } +-- | Make sure that we don't pass new flags to setup scripts compiled against+-- old versions of Cabal.+filterBuildFlags :: Version -> SavedConfig -> BuildFlags -> BuildFlags+filterBuildFlags version config buildFlags+  | version >= Version [1,19,1] [] = buildFlags_latest+  -- Cabal < 1.19.1 doesn't support 'build -j'.+  | otherwise                      = buildFlags_pre_1_19_1+  where+    buildFlags_pre_1_19_1 = buildFlags {+      buildNumJobs = NoFlag+      }+    buildFlags_latest     = buildFlags {+      -- Take the 'jobs' setting '~/.cabal/config' into account.+      buildNumJobs = Flag . Just . determineNumJobs $+                     (numJobsConfigFlag `mappend` numJobsCmdLineFlag)+      }+    numJobsConfigFlag  = installNumJobs . savedInstallFlags $ config+    numJobsCmdLineFlag = buildNumJobs buildFlags+++replAction :: ReplFlags -> [String] -> GlobalFlags -> IO ()+replAction replFlags extraArgs globalFlags = do+  cwd     <- getCurrentDirectory+  pkgDesc <- findPackageDesc cwd+  either (const onNoPkgDesc) (const onPkgDesc) pkgDesc+  where+    verbosity = fromFlagOrDefault normal (replVerbosity replFlags)++    -- There is a .cabal file in the current directory: start a REPL and load+    -- the project's modules.+    onPkgDesc = do+      let distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                        (replDistPref replFlags)+          noAddSource = case replReload replFlags of+                          Flag True -> SkipAddSourceDepsCheck+                          _         -> DontSkipAddSourceDepsCheck+          progConf     = defaultProgramConfiguration+          setupOptions = defaultSetupScriptOptions+            { useCabalVersion = orLaterVersion $ Version [1,18,0] []+            , useDistPref     = distPref+            }+          replFlags'   = replFlags+            { replVerbosity = toFlag verbosity+            , replDistPref  = toFlag distPref+            }+      -- Calls 'configureAction' to do the real work, so nothing special has to+      -- be done to support sandboxes.+      (useSandbox, _config) <- reconfigure verbosity distPref+                               mempty [] globalFlags noAddSource NoFlag+                               (const Nothing)++      maybeWithSandboxDirOnSearchPath useSandbox $+        setupWrapper verbosity setupOptions Nothing+        (Cabal.replCommand progConf) (const replFlags') extraArgs++    -- No .cabal file in the current directory: just start the REPL (possibly+    -- using the sandbox package DB).+    onNoPkgDesc = do+      (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags+                               mempty+      let configFlags = savedConfigureFlags config+      (comp, _platform, programDb) <- configCompilerAux' configFlags+      startInterpreter verbosity programDb comp (configPackageDB' configFlags)+ -- | Re-configure the package in the current directory if needed. Deciding -- when to reconfigure and with which options is convoluted: --@@ -275,6 +418,11 @@                             -- set them here.             -> [String]     -- ^ Extra arguments             -> GlobalFlags  -- ^ Global flags+            -> SkipAddSourceDepsCheck+                            -- ^ Should we skip the timestamp check for modified+                            -- add-source dependencies?+            -> Flag (Maybe Int)+                            -- ^ -j flag for reinstalling add-source deps.             -> (ConfigFlags -> Maybe String)                             -- ^ Check that the required flags are set in                             -- the last used 'ConfigFlags'. If the required@@ -284,75 +432,165 @@                             -- prefix setting is always required, it is checked                             -- automatically; this function need not check                             -- for it.-            -> IO ()-reconfigure verbosity distPref    addConfigFlags-            extraArgs globalFlags checkFlags = do-    mLbi <- maybeGetPersistBuildConfig distPref-    case mLbi of+            -> IO (UseSandbox, SavedConfig)+reconfigure verbosity distPref     addConfigFlags extraArgs globalFlags+            skipAddSourceDepsCheck numJobsFlag    checkFlags = do+  eLbi <- tryGetPersistBuildConfig distPref+  case eLbi of+    Left (err, errCode) -> onNoBuildConfig err errCode+    Right lbi           -> onBuildConfig lbi -        -- Package has never been configured.-        Nothing -> do-            notice verbosity-                $ "Configuring with default flags." ++ configureManually-            configureAction (defaultFlags, defaultConfigExFlags)-                            extraArgs globalFlags+  where -        -- Package has been configured, but the configuration may be out of-        -- date or required flags may not be set.-        Just lbi -> do-            let configFlags = LBI.configFlags lbi-                flags = mconcat [configFlags, addConfigFlags, distVerbFlags]-                savedDistPref = fromFlagOrDefault-                    (useDistPref defaultSetupScriptOptions)-                    (configDistPref configFlags)+    -- We couldn't load the saved package config file.+    --+    -- If we're in a sandbox: add-source deps don't have to be reinstalled+    -- (since we don't know the compiler & platform).+    onNoBuildConfig :: String -> ConfigStateFileErrorType+                       -> IO (UseSandbox, SavedConfig)+    onNoBuildConfig err errCode = do+      let msg = case errCode of+            ConfigStateFileMissing    -> "Package has never been configured."+            ConfigStateFileCantParse  -> "Saved package config file seems "+                                         ++ "to be corrupt."+            ConfigStateFileBadVersion -> err+      case errCode of+        ConfigStateFileBadVersion -> info verbosity msg+        _                         -> do+          notice verbosity+            $ msg ++ " Configuring with default flags." ++ configureManually+          configureAction (defaultFlags, defaultConfigExFlags)+            extraArgs globalFlags+      loadConfigOrSandboxConfig verbosity globalFlags mempty -            -- Determine what message, if any, to display to the user if-            -- reconfiguration is required.-            message <- case checkFlags configFlags of+    -- Package has been configured, but the configuration may be out of+    -- date or required flags may not be set.+    --+    -- If we're in a sandbox: reinstall the modified add-source deps and+    -- force reconfigure if we did.+    onBuildConfig :: LBI.LocalBuildInfo -> IO (UseSandbox, SavedConfig)+    onBuildConfig lbi = do+      let configFlags = LBI.configFlags lbi+          flags       = mconcat [configFlags, addConfigFlags, distVerbFlags] -                -- Flag required by the caller is not set.-                Just msg -> return $! Just $! msg ++ configureManually+      -- Was the sandbox created after the package was already configured? We+      -- may need to skip reinstallation of add-source deps and force+      -- reconfigure.+      let buildConfig       = localBuildInfoFile distPref+      sandboxConfig        <- getSandboxConfigFilePath globalFlags+      isSandboxConfigNewer <-+        sandboxConfig `existsAndIsMoreRecentThan` buildConfig -                Nothing-                    -- Required "dist" prefix is not set.-                    | savedDistPref /= distPref ->-                        return $! Just distPrefMessage+      let skipAddSourceDepsCheck'+            | isSandboxConfigNewer = SkipAddSourceDepsCheck+            | otherwise            = skipAddSourceDepsCheck -                    -- All required flags are set, but the configuration-                    -- may be outdated.-                    | otherwise -> case LBI.pkgDescrFile lbi of-                        Nothing -> return Nothing-                        Just pdFile -> do-                            outdated <- checkPersistBuildConfigOutdated distPref pdFile-                            return $! if outdated-                                then Just $! outdatedMessage pdFile-                                else Nothing+      when (skipAddSourceDepsCheck' == SkipAddSourceDepsCheck) $+        info verbosity "Skipping add-source deps check..." -            case message of+      (useSandbox, config, depsReinstalled) <-+        case skipAddSourceDepsCheck' of+        DontSkipAddSourceDepsCheck     ->+          maybeReinstallAddSourceDeps verbosity numJobsFlag flags globalFlags+        SkipAddSourceDepsCheck -> do+          (useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                                  globalFlags (configUserInstall flags)+          return (useSandbox, config, NoDepsReinstalled) -                -- No message for the user indicates that reconfiguration-                -- is not required.-                Nothing -> return ()+      -- Is the @cabal.config@ file newer than @dist/setup.config@? Then we need+      -- to force reconfigure. Note that it's possible to use @cabal.config@+      -- even without sandboxes.+      isUserPackageEnvironmentFileNewer <-+        userPackageEnvironmentFile `existsAndIsMoreRecentThan` buildConfig -                Just msg -> do-                    notice verbosity msg-                    configureAction (flags, defaultConfigExFlags)-                                    extraArgs globalFlags-  where+      -- Determine whether we need to reconfigure and which message to show to+      -- the user if that is the case.+      mMsg <- determineMessageToShow lbi configFlags depsReinstalled+                                     isSandboxConfigNewer+                                     isUserPackageEnvironmentFileNewer+      case mMsg of++        -- No message for the user indicates that reconfiguration+        -- is not required.+        Nothing -> return (useSandbox, config)++        -- Show the message and reconfigure.+        Just msg -> do+          notice verbosity msg+          configureAction (flags, defaultConfigExFlags)+            extraArgs globalFlags+          return (useSandbox, config)++    -- Determine what message, if any, to display to the user if reconfiguration+    -- is required.+    determineMessageToShow :: LBI.LocalBuildInfo -> ConfigFlags+                            -> WereDepsReinstalled -> Bool -> Bool+                            -> IO (Maybe String)+    determineMessageToShow _   _           _               True  _     =+      -- The sandbox was created after the package was already configured.+      return $! Just $! sandboxConfigNewerMessage++    determineMessageToShow _   _           _               False True  =+      -- The user package environment file was modified.+      return $! Just $! userPackageEnvironmentFileModifiedMessage++    determineMessageToShow lbi configFlags depsReinstalled False False = do+      let savedDistPref = fromFlagOrDefault+                          (useDistPref defaultSetupScriptOptions)+                          (configDistPref configFlags)+      case depsReinstalled of+        ReinstalledSomeDeps ->+          -- Some add-source deps were reinstalled.+          return $! Just $! reinstalledDepsMessage+        NoDepsReinstalled ->+          case checkFlags configFlags of+            -- Flag required by the caller is not set.+            Just msg -> return $! Just $! msg ++ configureManually++            Nothing+              -- Required "dist" prefix is not set.+              | savedDistPref /= distPref ->+                return $! Just distPrefMessage++              -- All required flags are set, but the configuration+              -- may be outdated.+              | otherwise -> case LBI.pkgDescrFile lbi of+                Nothing -> return Nothing+                Just pdFile -> do+                  outdated <- checkPersistBuildConfigOutdated+                              distPref pdFile+                  return $! if outdated+                            then Just $! outdatedMessage pdFile+                            else Nothing+     defaultFlags = mappend addConfigFlags distVerbFlags     distVerbFlags = mempty         { configVerbosity = toFlag verbosity-        , configDistPref = toFlag distPref+        , configDistPref  = toFlag distPref         }-    configureManually = " If this fails, please run configure manually.\n"+    reconfiguringMostRecent = " Re-configuring with most recently used options."+    configureManually       = " If this fails, please run configure manually."+    sandboxConfigNewerMessage =+        "The sandbox was created after the package was already configured."+        ++ reconfiguringMostRecent+        ++ configureManually+    userPackageEnvironmentFileModifiedMessage =+        "The user package environment file ('"+        ++ userPackageEnvironmentFile ++ "') was modified."+        ++ reconfiguringMostRecent+        ++ configureManually     distPrefMessage =-        "Package previously configured with different \"dist\" prefix. "-        ++ "Re-configuring based on most recently used options."+        "Package previously configured with different \"dist\" prefix."+        ++ reconfiguringMostRecent         ++ configureManually     outdatedMessage pdFile =-        pdFile ++ " has been changed. "-        ++ "Re-configuring with most recently used options."+        pdFile ++ " has been changed."+        ++ reconfiguringMostRecent         ++ configureManually+    reinstalledDepsMessage =+        "Some add-source dependencies have been reinstalled."+        ++ reconfiguringMostRecent+        ++ configureManually  installAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO ()@@ -365,63 +603,134 @@ installAction (configFlags, configExFlags, installFlags, haddockFlags)               extraArgs globalFlags = do   let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity+                          globalFlags (configUserInstall configFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = defaultConfigExFlags         `mappend`-                       savedConfigureExFlags config `mappend` configExFlags-      installFlags'  = defaultInstallFlags          `mappend`-                       savedInstallFlags     config `mappend` installFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags'-  install verbosity-          (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags-          targets -testAction :: TestFlags -> [String] -> GlobalFlags -> IO ()-testAction testFlags extraArgs globalFlags = do-    let verbosity = fromFlagOrDefault normal (testVerbosity testFlags)-        distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                                     (testDistPref testFlags)-        setupOptions = defaultSetupScriptOptions { useDistPref = distPref }-        addConfigFlags = mempty { configTests = toFlag True }-        checkFlags flags-            | fromFlagOrDefault False (configTests flags) = Nothing-            | otherwise = Just "Re-configuring with test suites enabled."+  -- TODO: It'd be nice if 'cabal install' picked up the '-w' flag passed to+  -- 'configure' when run inside a sandbox.  Right now, running+  --+  -- $ cabal sandbox init && cabal configure -w /path/to/ghc+  --   && cabal build && cabal install+  --+  -- performs the compilation twice unless you also pass -w to 'install'.+  -- However, this is the same behaviour that 'cabal install' has in the normal+  -- mode of operation, so we stick to it for consistency. -    reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags-    build verbosity distPref mempty []+  let sandboxDistPref = case useSandbox of+        NoSandbox             -> NoFlag+        UseSandbox sandboxDir -> Flag $ sandboxBuildDir sandboxDir+      configFlags'    = savedConfigureFlags   config `mappend` configFlags+      configExFlags'  = defaultConfigExFlags         `mappend`+                        savedConfigureExFlags config `mappend` configExFlags+      installFlags'   = defaultInstallFlags          `mappend`+                        savedInstallFlags     config `mappend` installFlags+      globalFlags'    = savedGlobalFlags      config `mappend` globalFlags+  (comp, platform, conf) <- configCompilerAux' configFlags' +  -- If we're working inside a sandbox and the user has set the -w option, we+  -- may need to create a sandbox-local package DB for this compiler and add a+  -- timestamp record for this compiler to the timestamp file.+  configFlags'' <- case useSandbox of+        NoSandbox               -> configAbsolutePaths $ configFlags'+        (UseSandbox sandboxDir) ->+          return $ (setPackageDB sandboxDir comp platform configFlags') {+            configDistPref = sandboxDistPref+            }++  whenUsingSandbox useSandbox $ \sandboxDir -> do+    initPackageDBIfNeeded verbosity configFlags'' comp conf++    indexFile     <- tryGetIndexFilePath config+    maybeAddCompilerTimestampRecord verbosity sandboxDir indexFile+      (compilerId comp) platform++  -- FIXME: Passing 'SandboxPackageInfo' to install unconditionally here means+  -- that 'cabal install some-package' inside a sandbox will sometimes reinstall+  -- modified add-source deps, even if they are not among the dependencies of+  -- 'some-package'. This can also prevent packages that depend on older+  -- versions of add-source'd packages from building (see #1362).+  maybeWithSandboxPackageInfo verbosity configFlags'' globalFlags'+                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              maybeWithSandboxDirOnSearchPath useSandbox $+      install verbosity+              (configPackageDB' configFlags'')+              (globalRepos globalFlags')+              comp platform conf+              useSandbox mSandboxPkgInfo+              globalFlags' configFlags'' configExFlags'+              installFlags' haddockFlags+              targets++testAction :: (TestFlags, BuildFlags, BuildExFlags) -> [String] -> GlobalFlags+              -> IO ()+testAction (testFlags, buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal (testVerbosity testFlags)+      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                       (testDistPref testFlags)+      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      addConfigFlags = mempty { configTests = toFlag True }+      checkFlags flags+        | fromFlagOrDefault False (configTests flags) = Nothing+        | otherwise  = Just "Re-configuring with test suites enabled."+      noAddSource    = fromFlagOrDefault DontSkipAddSourceDepsCheck+                       (buildOnly buildExFlags)++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []+                          globalFlags noAddSource+                          (buildNumJobs buildFlags) checkFlags++  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags extraArgs++  maybeWithSandboxDirOnSearchPath useSandbox $     setupWrapper verbosity setupOptions Nothing-                 testCommand (const testFlags) extraArgs+      Cabal.testCommand (const testFlags) extraArgs -benchmarkAction :: BenchmarkFlags -> [String] -> GlobalFlags -> IO ()-benchmarkAction benchmarkFlags extraArgs globalFlags = do-    let verbosity = fromFlagOrDefault normal (benchmarkVerbosity benchmarkFlags)-        distPref = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)-                                     (benchmarkDistPref benchmarkFlags)-        setupOptions = defaultSetupScriptOptions { useDistPref = distPref }-        addConfigFlags = mempty { configBenchmarks = toFlag True }-        checkFlags flags-            | fromFlagOrDefault False (configTests flags) = Nothing-            | otherwise = Just "Re-configuring with benchmarks enabled."+benchmarkAction :: (BenchmarkFlags, BuildFlags, BuildExFlags)+                   -> [String] -> GlobalFlags+                   -> IO ()+benchmarkAction (benchmarkFlags, buildFlags, buildExFlags)+                extraArgs globalFlags = do+  let verbosity      = fromFlagOrDefault normal+                       (benchmarkVerbosity benchmarkFlags)+      distPref       = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                       (benchmarkDistPref benchmarkFlags)+      setupOptions   = defaultSetupScriptOptions { useDistPref = distPref }+      addConfigFlags = mempty { configBenchmarks = toFlag True }+      checkFlags flags+        | fromFlagOrDefault False (configBenchmarks flags) = Nothing+        | otherwise = Just "Re-configuring with benchmarks enabled."+      noAddSource   = fromFlagOrDefault DontSkipAddSourceDepsCheck+                      (buildOnly buildExFlags) -    reconfigure verbosity distPref addConfigFlags [] globalFlags checkFlags-    build verbosity distPref mempty []+  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  (useSandbox, config) <- reconfigure verbosity distPref addConfigFlags []+                          globalFlags noAddSource (buildNumJobs buildFlags)+                          checkFlags +  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags extraArgs++  maybeWithSandboxDirOnSearchPath useSandbox $     setupWrapper verbosity setupOptions Nothing-                 benchmarkCommand (const benchmarkFlags) extraArgs+      Cabal.benchmarkCommand (const benchmarkFlags) extraArgs  listAction :: ListFlags -> [String] -> GlobalFlags -> IO () listAction listFlags extraArgs globalFlags = do   let verbosity = fromFlag (listVerbosity listFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let configFlags  = savedConfigureFlags config+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` listPackageDBs listFlags+        }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags-  list verbosity+  (comp, _, conf) <- configCompilerAux' configFlags+  List.list verbosity        (configPackageDB' configFlags)        (globalRepos globalFlags')        comp@@ -433,11 +742,15 @@ infoAction infoFlags extraArgs globalFlags = do   let verbosity = fromFlag (infoVerbosity infoFlags)   targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty-  let configFlags  = savedConfigureFlags config+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  let configFlags' = savedConfigureFlags config+      configFlags  = configFlags' {+        configPackageDBs = configPackageDBs configFlags'+                           `mappend` infoPackageDBs infoFlags+        }       globalFlags' = savedGlobalFlags    config `mappend` globalFlags-  (comp, conf) <- configCompilerAux configFlags-  info verbosity+  (comp, _, conf) <- configCompilerAuxEx configFlags+  List.info verbosity        (configPackageDB' configFlags)        (globalRepos globalFlags')        comp@@ -448,7 +761,7 @@  updateAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () updateAction verbosityFlag extraArgs globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'update' doesn't take any extra arguments: " ++ unwords extraArgs   let verbosity = fromFlag verbosityFlag   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty@@ -457,22 +770,18 @@  upgradeAction :: (ConfigFlags, ConfigExFlags, InstallFlags, HaddockFlags)               -> [String] -> GlobalFlags -> IO ()-upgradeAction (configFlags, configExFlags, installFlags, haddockFlags)-              extraArgs globalFlags = do-  let verbosity = fromFlagOrDefault normal (configVerbosity configFlags)-  targets <- readUserTargets verbosity extraArgs-  config <- loadConfig verbosity (globalConfigFile globalFlags)-                                 (configUserInstall configFlags)-  let configFlags'   = savedConfigureFlags   config `mappend` configFlags-      configExFlags' = savedConfigureExFlags config `mappend` configExFlags-      installFlags'  = defaultInstallFlags          `mappend`-                       savedInstallFlags     config `mappend` installFlags-      globalFlags'   = savedGlobalFlags      config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags'-  upgrade verbosity-          (configPackageDB' configFlags') (globalRepos globalFlags')-          comp conf globalFlags' configFlags' configExFlags' installFlags' haddockFlags-          targets+upgradeAction _ _ _ = die $+    "Use the 'cabal install' command instead of 'cabal upgrade'.\n"+ ++ "You can install the latest version of a package using 'cabal install'. "+ ++ "The 'cabal upgrade' command has been removed because people found it "+ ++ "confusing and it often led to broken packages.\n"+ ++ "If you want the old upgrade behaviour then use the install command "+ ++ "with the --upgrade-dependencies flag (but check first with --dry-run "+ ++ "to see what would happen). This will try to pick the latest versions "+ ++ "of all dependencies, rather than the usual behaviour of trying to pick "+ ++ "installed versions of all dependencies. If you do use "+ ++ "--upgrade-dependencies, it is recommended that you do not upgrade core "+ ++ "packages (e.g. by using appropriate --constraint= flags)."  fetchAction :: FetchFlags -> [String] -> GlobalFlags -> IO () fetchAction fetchFlags extraArgs globalFlags = do@@ -481,12 +790,31 @@   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty   let configFlags  = savedConfigureFlags config       globalFlags' = savedGlobalFlags config `mappend` globalFlags-  (comp, conf) <- configCompilerAux' configFlags+  (comp, platform, conf) <- configCompilerAux' configFlags   fetch verbosity-        (configPackageDB' configFlags) (globalRepos globalFlags')-        comp conf globalFlags' fetchFlags+        (configPackageDB' configFlags)+        (globalRepos globalFlags')+        comp platform conf globalFlags' fetchFlags         targets +freezeAction :: FreezeFlags -> [String] -> GlobalFlags -> IO ()+freezeAction freezeFlags _extraArgs globalFlags = do+  let verbosity = fromFlag (freezeVerbosity freezeFlags)+  (useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty+  let configFlags  = savedConfigureFlags config+      globalFlags' = savedGlobalFlags config `mappend` globalFlags+  (comp, platform, conf) <- configCompilerAux' configFlags++  maybeWithSandboxPackageInfo verbosity configFlags globalFlags'+                              comp platform conf useSandbox $ \mSandboxPkgInfo ->+                              maybeWithSandboxDirOnSearchPath useSandbox $+      freeze verbosity+            (configPackageDB' configFlags)+            (globalRepos globalFlags')+            comp platform conf+            mSandboxPkgInfo+            globalFlags' freezeFlags+ uploadAction :: UploadFlags -> [String] -> GlobalFlags -> IO () uploadAction uploadFlags extraArgs globalFlags = do   let verbosity = fromFlag (uploadVerbosity uploadFlags)@@ -521,7 +849,7 @@  checkAction :: Flag Verbosity -> [String] -> GlobalFlags -> IO () checkAction verbosityFlag extraArgs _globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'check' doesn't take any extra arguments: " ++ unwords extraArgs   allOk <- Check.check (fromFlag verbosityFlag)   unless allOk exitFailure@@ -529,13 +857,13 @@  sdistAction :: (SDistFlags, SDistExFlags) -> [String] -> GlobalFlags -> IO () sdistAction (sdistFlags, sdistExFlags) extraArgs _globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'sdist' doesn't take any extra arguments: " ++ unwords extraArgs   sdist sdistFlags sdistExFlags  reportAction :: ReportFlags -> [String] -> GlobalFlags -> IO () reportAction reportFlags extraArgs globalFlags = do-  unless (null extraArgs) $ do+  unless (null extraArgs) $     die $ "'report' doesn't take any extra arguments: " ++ unwords extraArgs    let verbosity = fromFlag (reportVerbosity reportFlags)@@ -547,75 +875,91 @@     (flagToMaybe $ reportUsername reportFlags')     (flagToMaybe $ reportPassword reportFlags') -unpackAction :: UnpackFlags -> [String] -> GlobalFlags -> IO ()-unpackAction unpackFlags extraArgs globalFlags = do-  let verbosity = fromFlag (unpackVerbosity unpackFlags)+runAction :: (BuildFlags, BuildExFlags) -> [String] -> GlobalFlags -> IO ()+runAction (buildFlags, buildExFlags) extraArgs globalFlags = do+  let verbosity   = fromFlagOrDefault normal (buildVerbosity buildFlags)+      distPref    = fromFlagOrDefault (useDistPref defaultSetupScriptOptions)+                    (buildDistPref buildFlags)+      noAddSource = fromFlagOrDefault DontSkipAddSourceDepsCheck+                    (buildOnly buildExFlags)++  -- reconfigure also checks if we're in a sandbox and reinstalls add-source+  -- deps if needed.+  (useSandbox, config) <- reconfigure verbosity distPref mempty []+                          globalFlags noAddSource (buildNumJobs buildFlags)+                          (const Nothing)++  lbi <- getPersistBuildConfig distPref+  (exe, exeArgs) <- splitRunArgs lbi extraArgs++  maybeWithSandboxDirOnSearchPath useSandbox $+    build verbosity config distPref buildFlags ["exe:" ++ exeName exe]++  maybeWithSandboxDirOnSearchPath useSandbox $+    run verbosity lbi exe exeArgs++getAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+getAction getFlags extraArgs globalFlags = do+  let verbosity = fromFlag (getVerbosity getFlags)   targets <- readUserTargets verbosity extraArgs   config <- loadConfig verbosity (globalConfigFile globalFlags) mempty   let globalFlags' = savedGlobalFlags config `mappend` globalFlags-  unpack verbosity-         (globalRepos (savedGlobalFlags config))-         globalFlags'-         unpackFlags-         targets+  get verbosity+    (globalRepos (savedGlobalFlags config))+    globalFlags'+    getFlags+    targets +unpackAction :: GetFlags -> [String] -> GlobalFlags -> IO ()+unpackAction getFlags extraArgs globalFlags = do+  getAction getFlags extraArgs globalFlags+ initAction :: InitFlags -> [String] -> GlobalFlags -> IO () initAction initFlags _extraArgs globalFlags = do   let verbosity = fromFlag (initVerbosity initFlags)-  config <- loadConfig verbosity (globalConfigFile globalFlags) mempty+  (_useSandbox, config) <- loadConfigOrSandboxConfig verbosity globalFlags mempty   let configFlags  = savedConfigureFlags config-  (comp, conf) <- configCompilerAux' configFlags+  (comp, _, conf) <- configCompilerAux' configFlags   initCabal verbosity             (configPackageDB' configFlags)             comp             conf             initFlags -indexAction :: IndexFlags -> [String] -> GlobalFlags -> IO ()-indexAction indexFlags extraArgs _globalFlags = do-  when (null extraArgs) $ do-    die $ "the 'index' command expects a single argument."-  when ((>1). length $ extraArgs) $ do-    die $ "the 'index' command expects a single argument: " ++ unwords extraArgs-  let verbosity = fromFlag (indexVerbosity indexFlags)-  index verbosity indexFlags (head extraArgs)--sandboxConfigureAction :: (SandboxFlags, ConfigFlags, ConfigExFlags)-                          -> [String] -> GlobalFlags -> IO ()-sandboxConfigureAction (sandboxFlags, configFlags, configExFlags)-  extraArgs globalFlags = do+sandboxAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()+sandboxAction sandboxFlags extraArgs globalFlags = do   let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  sandboxConfigure verbosity sandboxFlags configFlags configExFlags-    extraArgs globalFlags+  case extraArgs of+    -- Basic sandbox commands.+    ["init"] -> sandboxInit verbosity sandboxFlags globalFlags+    ["delete"] -> sandboxDelete verbosity sandboxFlags globalFlags+    ("add-source":extra) -> do+        when (noExtraArgs extra) $+          die "The 'sandbox add-source' command expects at least one argument"+        sandboxAddSource verbosity extra sandboxFlags globalFlags -sandboxAddSourceAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()-sandboxAddSourceAction sandboxFlags extraArgs _globalFlags = do-  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  sandboxAddSource verbosity sandboxFlags extraArgs+    -- More advanced commands.+    ("hc-pkg":extra) -> do+        when (noExtraArgs extra) $+            die $ "The 'sandbox hc-pkg' command expects at least one argument"+        sandboxHcPkg verbosity sandboxFlags globalFlags extra+    ["buildopts"] -> die "Not implemented!" -sandboxBuildAction :: (SandboxFlags, BuildFlags) -> [String] -> GlobalFlags-                      -> IO ()-sandboxBuildAction (sandboxFlags, buildFlags) extraArgs _globalFlags = do-  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  sandboxBuild verbosity sandboxFlags buildFlags extraArgs+    -- Hidden commands.+    ("delete-source":extra) -> do+        when (noExtraArgs extra) $+          die "The 'sandbox delete-source' command expects \+              \at least one argument"+        sandboxDeleteSource verbosity extra sandboxFlags globalFlags+    ["list-sources"] -> sandboxListSources verbosity sandboxFlags globalFlags+    ["dump-pkgenv"]  -> dumpPackageEnvironment verbosity sandboxFlags globalFlags -sandboxInstallAction :: (SandboxFlags, ConfigFlags, ConfigExFlags,-                         InstallFlags, HaddockFlags)-                        -> [String] -> GlobalFlags -> IO ()-sandboxInstallAction-  (sandboxFlags, configFlags, configExFlags, installFlags, haddockFlags)-  extraArgs globalFlags = do-  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  sandboxInstall verbosity sandboxFlags configFlags configExFlags-    installFlags haddockFlags extraArgs globalFlags+    -- Error handling.+    [] -> die $ "Please specify a subcommand (see 'help sandbox')"+    _  -> die $ "Unknown 'sandbox' subcommand: " ++ unwords extraArgs -dumpPkgEnvAction :: SandboxFlags -> [String] -> GlobalFlags -> IO ()-dumpPkgEnvAction sandboxFlags extraArgs _globalFlags = do-  when ((>0). length $ extraArgs) $ do-    die $ "the 'dump-pkgenv' command doesn't expect any arguments: "-      ++ unwords extraArgs-  let verbosity = fromFlag (sandboxVerbosity sandboxFlags)-  dumpPackageEnvironment verbosity sandboxFlags+  where+    noExtraArgs = (<1) . length  -- | See 'Distribution.Client.Install.withWin32SelfUpgrade' for details. --@@ -625,20 +969,3 @@   let verbosity = fromFlag (win32SelfUpgradeVerbosity selfUpgradeFlags)   Win32SelfUpgrade.deleteOldExeFile verbosity (read pid) path win32SelfUpgradeAction _ _ _ = return ()------- Utils (transitionary)-----configPackageDB' :: ConfigFlags -> PackageDBStack-configPackageDB' cfg =-    interpretPackageDbFlags userInstall (configPackageDBs cfg)-  where-    userInstall = fromFlagOrDefault True (configUserInstall cfg)--configCompilerAux' :: ConfigFlags-                   -> IO (Compiler, ProgramConfiguration)-configCompilerAux' configFlags =-  configCompilerAux configFlags-    --FIXME: make configCompilerAux use a sensible verbosity-    { configVerbosity = fmap lessVerbose (configVerbosity configFlags) }
cabal/cabal-install/bootstrap.sh view
@@ -9,6 +9,8 @@ # install settings, you can override these by setting environment vars #VERBOSE #EXTRA_CONFIGURE_OPTS+#EXTRA_BUILD_OPTS+#EXTRA_INSTALL_OPTS  # programs, you can override these by setting environment vars GHC=${GHC:-ghc}@@ -47,17 +49,18 @@  # Versions of the packages to install. # The version regex says what existing installed versions are ok.-PARSEC_VER="3.1.3";    PARSEC_VER_REGEXP="[23]\."  # == 2.* || == 3.*-DEEPSEQ_VER="1.3.0.1"; DEEPSEQ_VER_REGEXP="1\.[1-9]\." # >= 1.1 && < 2-TEXT_VER="0.11.2.3";  TEXT_VER_REGEXP="0\.([2-9]|(1[0-1]))\." # >= 0.2 && < 0.12-NETWORK_VER="2.3.1.0"; NETWORK_VER_REGEXP="2\."    # == 2.*-CABAL_VER="1.16.0";    CABAL_VER_REGEXP="1\.(13\.3|1[4-7]\.)"  # >= 1.13.3 && < 1.18-TRANS_VER="0.3.0.0";   TRANS_VER_REGEXP="0\.[23]\."   # >= 0.2.* && < 0.4.*-MTL_VER="2.1.2";     MTL_VER_REGEXP="[12]\."     # == 1.* || == 2.*-HTTP_VER="4000.2.4";   HTTP_VER_REGEXP="4000\.[012]\." # == 4000.0.* || 4000.1.* || 4000.2.*-ZLIB_VER="0.5.3.3";    ZLIB_VER_REGEXP="0\.[45]\." # == 0.4.* || == 0.5.*-TIME_VER="1.4.0.1"     TIME_VER_REGEXP="1\.[1234]\.?" # >= 1.1 && < 1.5-RANDOM_VER="1.0.1.1"   RANDOM_VER_REGEXP="1\.0\." # >= 1 && < 1.1+PARSEC_VER="3.1.4";    PARSEC_VER_REGEXP="[23]\."              # == 2.* || == 3.*+DEEPSEQ_VER="1.3.0.2"; DEEPSEQ_VER_REGEXP="1\.[1-9]\."         # >= 1.1 && < 2+TEXT_VER="1.0.0.0";    TEXT_VER_REGEXP="((1\.0\.)|(0\.([2-9]|(1[0-1]))\.))" # >= 0.2 && < 1.1+NETWORK_VER="2.4.2.1"; NETWORK_VER_REGEXP="2\."                # == 2.*+CABAL_VER="1.19.2";    CABAL_VER_REGEXP="1\.1[9]\."            # >= 1.19 && < 1.20+TRANS_VER="0.3.0.0";   TRANS_VER_REGEXP="0\.[23]\."            # >= 0.2.* && < 0.4.*+MTL_VER="2.1.2";       MTL_VER_REGEXP="[2]\."                  #  == 2.*+HTTP_VER="4000.2.10";  HTTP_VER_REGEXP="4000\.[012]\."         # == 4000.0.* || 4000.1.* || 4000.2.*+ZLIB_VER="0.5.4.1";    ZLIB_VER_REGEXP="0\.[45]\."             # == 0.4.* || == 0.5.*+TIME_VER="1.4.1"       TIME_VER_REGEXP="1\.[1234]\.?"          # >= 1.1 && < 1.5+RANDOM_VER="1.0.1.1"   RANDOM_VER_REGEXP="1\.0\."              # >= 1 && < 1.1+STM_VER="2.4.2";       STM_VER_REGEXP="2\."                    # == 2.*  HACKAGE_URL="http://hackage.haskell.org/packages/archive" @@ -119,13 +122,13 @@   URL=${HACKAGE_URL}/${PKG}/${VER}/${PKG}-${VER}.tar.gz   if which ${CURL} > /dev/null   then-    ${CURL} --fail -C - -O ${URL} || die "Failed to download ${PKG}."+    ${CURL} -L --fail -C - -O ${URL} || die "Failed to download ${PKG}."   elif which ${WGET} > /dev/null   then     ${WGET} -c ${URL} || die "Failed to download ${PKG}."   elif which ${FETCH} > /dev/null- 	then- 	  ${FETCH} ${URL} || die "Failed to download ${PKG}."+    then+      ${FETCH} ${URL} || die "Failed to download ${PKG}."   else     die "Failed to find a downloader. 'curl', 'wget' or 'fetch' is required."   fi@@ -161,10 +164,10 @@     ${EXTRA_CONFIGURE_OPTS} ${VERBOSE} \     || die "Configuring the ${PKG} package failed" -  ./Setup build ${VERBOSE} \+  ./Setup build ${EXTRA_BUILD_OPTS} ${VERBOSE} \     || die "Building the ${PKG} package failed" -  ./Setup install ${VERBOSE} \+  ./Setup install ${SCOPE_OF_INSTALLATION} ${EXTRA_INSTALL_OPTS} ${VERBOSE} \     || die "Installing the ${PKG} package failed" } @@ -187,29 +190,31 @@  # Actually do something! +info_pkg "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP}+info_pkg "time"         ${TIME_VER}    ${TIME_VER_REGEXP} info_pkg "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP} info_pkg "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP} info_pkg "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}-info_pkg "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} info_pkg "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} info_pkg "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} info_pkg "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}-info_pkg "time"         ${TIME_VER}    ${TIME_VER_REGEXP} info_pkg "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} info_pkg "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} info_pkg "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP}+info_pkg "stm"          ${STM_VER}     ${STM_VER_REGEXP} +do_pkg   "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP}+do_pkg   "time"         ${TIME_VER}    ${TIME_VER_REGEXP} do_pkg   "Cabal"        ${CABAL_VER}   ${CABAL_VER_REGEXP} do_pkg   "transformers" ${TRANS_VER}   ${TRANS_VER_REGEXP} do_pkg   "mtl"          ${MTL_VER}     ${MTL_VER_REGEXP}-do_pkg   "deepseq"      ${DEEPSEQ_VER} ${DEEPSEQ_VER_REGEXP} do_pkg   "text"         ${TEXT_VER}    ${TEXT_VER_REGEXP} do_pkg   "parsec"       ${PARSEC_VER}  ${PARSEC_VER_REGEXP} do_pkg   "network"      ${NETWORK_VER} ${NETWORK_VER_REGEXP}-do_pkg   "time"         ${TIME_VER}    ${TIME_VER_REGEXP} do_pkg   "HTTP"         ${HTTP_VER}    ${HTTP_VER_REGEXP} do_pkg   "zlib"         ${ZLIB_VER}    ${ZLIB_VER_REGEXP} do_pkg   "random"       ${RANDOM_VER}  ${RANDOM_VER_REGEXP}+do_pkg   "stm"          ${STM_VER}     ${STM_VER_REGEXP}  install_pkg "cabal-install"
cabal/cabal-install/cabal-install.cabal view
@@ -1,5 +1,5 @@ Name:               cabal-install-Version:            0.17.0+Version:            1.19.2 Synopsis:           The command-line interface for Cabal and Hackage. Description:     The \'cabal\' command-line program simplifies the process of managing@@ -23,25 +23,21 @@ Category:           Distribution Build-type:         Simple Extra-Source-Files: README bash-completion/cabal bootstrap.sh-Cabal-Version:      >= 1.6+Cabal-Version:      >= 1.8  source-repository head   type:     git   location: https://github.com/haskell/cabal/   subdir:   cabal-install -flag old-base-  description: Old, monolithic base-  default: False--flag bytestring-in-base+Flag old-directory+  description:  Use directory < 1.2 and old-time+  default:      False -Executable cabal-    Main-Is:            Main.hs-    ghc-options:        -Wall -threaded-    if impl(ghc >= 6.8)-      ghc-options: -fwarn-tabs-    Other-Modules:+executable cabal+    main-is:        Main.hs+    ghc-options:    -Wall -fwarn-tabs+    other-modules:         Distribution.Client.BuildReports.Anonymous         Distribution.Client.BuildReports.Storage         Distribution.Client.BuildReports.Types@@ -75,10 +71,11 @@         Distribution.Client.Dependency.Modular.Version         Distribution.Client.Fetch         Distribution.Client.FetchUtils+        Distribution.Client.Freeze+        Distribution.Client.Get         Distribution.Client.GZipUtils         Distribution.Client.Haddock         Distribution.Client.HttpUtils-        Distribution.Client.Index         Distribution.Client.IndexUtils         Distribution.Client.Init         Distribution.Client.Init.Heuristics@@ -89,58 +86,117 @@         Distribution.Client.InstallSymlink         Distribution.Client.JobControl         Distribution.Client.List-        Distribution.Client.PackageEnvironment         Distribution.Client.PackageIndex         Distribution.Client.PackageUtils         Distribution.Client.ParseUtils+        Distribution.Client.Run         Distribution.Client.Sandbox+        Distribution.Client.Sandbox.Index+        Distribution.Client.Sandbox.PackageEnvironment+        Distribution.Client.Sandbox.Timestamp+        Distribution.Client.Sandbox.Types         Distribution.Client.Setup         Distribution.Client.SetupWrapper         Distribution.Client.SrcDist         Distribution.Client.Tar         Distribution.Client.Targets         Distribution.Client.Types-        Distribution.Client.Unpack         Distribution.Client.Update         Distribution.Client.Upload         Distribution.Client.Utils         Distribution.Client.World         Distribution.Client.Win32SelfUpgrade-        Distribution.Compat.Exception-        Distribution.Compat.FilePerms-        Distribution.Compat.Time+        Distribution.Client.Compat.Environment+        Distribution.Client.Compat.ExecutablePath+        Distribution.Client.Compat.FilePerms+        Distribution.Client.Compat.Process+        Distribution.Client.Compat.Semaphore+        Distribution.Client.Compat.Time         Paths_cabal_install -    build-depends: base     >= 2        && < 5,-                   Cabal    >= 1.17.0   && < 1.18,-                   filepath >= 1.0      && < 1.4,-                   network  >= 1        && < 3,-                   HTTP     >= 4000.0.2 && < 4001,-                   zlib     >= 0.4      && < 0.6,-                   time     >= 1.1      && < 1.5,-                   mtl      >= 2.0      && < 3--    if flag(old-base)-      build-depends: base < 3-    else-      build-depends: base       >= 3,-                     process    >= 1   && < 1.2,-                     directory  >= 1   && < 1.3,-                     pretty     >= 1   && < 1.2,-                     random     >= 1   && < 1.1,-                     containers >= 0.1 && < 0.6,-                     array      >= 0.1 && < 0.5,-                     old-time   >= 1   && < 1.2+    -- NOTE: when updating build-depends, don't forget to update version regexps+    -- in bootstrap.sh.+    build-depends:+        array      >= 0.1      && < 0.6,+        base       >= 4.3      && < 5,+        bytestring >= 0.9      && < 1,+        Cabal      == 1.19.2,+        containers >= 0.1      && < 0.6,+        filepath   >= 1.0      && < 1.4,+        HTTP       >= 4000.0.8 && < 4001,+        mtl        >= 2.0      && < 3,+        network    >= 1        && < 3,+        pretty     >= 1        && < 1.2,+        random     >= 1        && < 1.1,+        stm        >= 2.0      && < 3,+        time       >= 1.1      && < 1.5,+        zlib       >= 0.5.3    && < 0.6 -    if flag(bytestring-in-base)-      build-depends: base >= 2.0 && < 2.2+    if flag(old-directory)+      build-depends: directory >= 1 && < 1.2, old-time >= 1 && < 1.2,+                     process   >= 1.0.1.1  && < 1.1.0.2     else-      build-depends: base < 2.0 || >= 3.0, bytestring >= 0.9+      build-depends: directory >= 1.2 && < 1.3,+                     process   >= 1.1.0.2  && < 1.3      if os(windows)       build-depends: Win32 >= 2 && < 3       cpp-options: -DWIN32     else-      build-depends: unix >= 1.0 && < 2.7-    extensions: CPP, ForeignFunctionInterface+      build-depends: unix >= 2.0 && < 2.8++    if arch(arm) && impl(ghc < 7.6)+       -- older ghc on arm does not supprt -threaded+       cc-options:  -DCABAL_NO_THREADED+    else+       ghc-options: -threaded+     c-sources: cbits/getnumcores.c+++Test-Suite unit-tests+  type: exitcode-stdio-1.0+  main-is: UnitTests.hs+  hs-source-dirs: tests, .+  ghc-options: -Wall -fwarn-tabs+  other-modules:+    UnitTests.Distribution.Client.Targets+    UnitTests.Distribution.Client.Dependency.Modular.PSQ+    UnitTests.Distribution.Client.Sandbox+  build-depends:+        base,+        array,+        bytestring,+        Cabal,+        containers,+        mtl,+        network,+        pretty,+        process,+        directory,+        filepath,+        stm,+        time,+        network,+        HTTP,+        zlib,++        test-framework,+        test-framework-hunit,+        test-framework-quickcheck2 >= 0.3,+        HUnit,+        QuickCheck >= 2.5++  if flag(old-directory)+    build-depends: old-time++  if os(windows)+    build-depends: Win32+    cpp-options: -DWIN32+  else+    build-depends: unix++  if arch(arm)+    cc-options:  -DCABAL_NO_THREADED+  else+    ghc-options: -threaded
+ cabal/cabal-install/cabal.config view
@@ -0,0 +1,1 @@+ghc-options: -fno-ignore-asserts
cabal/cabal-install/cbits/getnumcores.c view
@@ -1,4 +1,4 @@-#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 612)+#if defined(__GLASGOW_HASKELL__) && (__GLASGOW_HASKELL__ >= 612) && !defined(CABAL_NO_THREADED) /* Since version 6.12, GHC's threaded RTS includes a getNumberOfProcessors    function, so we try to use that if available. cabal-install is always built    with -threaded nowadays.  */
+ cabal/cabal-install/tests/README view
@@ -0,0 +1,1 @@+See Cabal/tests/README.
+ cabal/cabal-install/tests/UnitTests.hs view
@@ -0,0 +1,21 @@+module Main+       where++import Test.Framework++import qualified UnitTests.Distribution.Client.Sandbox+import qualified UnitTests.Distribution.Client.Targets+import qualified UnitTests.Distribution.Client.Dependency.Modular.PSQ++tests :: [Test]+tests = [+   testGroup "Distribution.Client.Sandbox"+       UnitTests.Distribution.Client.Sandbox.tests+  ,testGroup "Distribution.Client.Targets"+       UnitTests.Distribution.Client.Targets.tests+  ,testGroup "UnitTests.Distribution.Client.Dependency.Modular.PSQ"+        UnitTests.Distribution.Client.Dependency.Modular.PSQ.tests+  ]++main :: IO ()+main = defaultMain tests
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Dependency/Modular/PSQ.hs view
@@ -0,0 +1,22 @@+module UnitTests.Distribution.Client.Dependency.Modular.PSQ (+  tests+  ) where++import Distribution.Client.Dependency.Modular.PSQ++import Test.Framework as TF (Test)+import Test.Framework.Providers.QuickCheck2++tests :: [TF.Test]+tests = [ testProperty "splitsAltImplementation" splitsTest+        ]++-- | Original splits implementation+splits' :: PSQ k a -> PSQ k (a, PSQ k a)+splits' xs =+  casePSQ xs+    (PSQ [])+    (\ k v ys -> cons k (v, ys) (fmap (\ (w, zs) -> (w, cons k v zs)) (splits' ys)))++splitsTest :: [(Int, Int)] -> Bool+splitsTest psq = splits' (PSQ psq) == splits (PSQ psq)
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Sandbox.hs view
@@ -0,0 +1,29 @@+module UnitTests.Distribution.Client.Sandbox (+  tests+  ) where++import Distribution.Client.Sandbox    (withSandboxBinDirOnSearchPath)++import Test.Framework                 as TF (Test)+import Test.Framework.Providers.HUnit (testCase)+import Test.HUnit                     (Assertion, assertBool, assertEqual)++import System.FilePath                (getSearchPath, (</>))++tests :: [TF.Test]+tests = [ testCase "sandboxBinDirOnSearchPath" sandboxBinDirOnSearchPathTest+        , testCase "oldSearchPathRestored" oldSearchPathRestoreTest+        ]++sandboxBinDirOnSearchPathTest :: Assertion+sandboxBinDirOnSearchPathTest =+  withSandboxBinDirOnSearchPath "foo" $ do+    r <- getSearchPath+    assertBool "'foo/bin' not on search path" $ ("foo" </> "bin") `elem` r++oldSearchPathRestoreTest :: Assertion+oldSearchPathRestoreTest = do+  r <- getSearchPath+  withSandboxBinDirOnSearchPath "foo" $ return ()+  r' <- getSearchPath+  assertEqual "Old search path wasn't restored" r r'
+ cabal/cabal-install/tests/UnitTests/Distribution/Client/Targets.hs view
@@ -0,0 +1,59 @@+module UnitTests.Distribution.Client.Targets (+  tests+  ) where++import Distribution.Client.Targets     (UserConstraint (..), readUserConstraint)+import Distribution.Compat.ReadP       (ReadP, readP_to_S)+import Distribution.Package            (PackageName (..))+import Distribution.ParseUtils         (parseCommaList)+import Distribution.Text               (parse)++import Test.Framework                  as TF (Test)+import Test.Framework.Providers.HUnit  (testCase)+import Test.HUnit                      (Assertion, assertEqual)++import Data.Char                       (isSpace)++tests :: [TF.Test]+tests = [ testCase "readUserConstraint" readUserConstraintTest+        , testCase "parseUserConstraint" parseUserConstraintTest+        , testCase "readUserConstraints" readUserConstraintsTest+        ]++readUserConstraintTest :: Assertion+readUserConstraintTest =+  assertEqual ("Couldn't read constraint: '" ++ constr ++ "'") expected actual+  where+    pkgName  = "template-haskell"+    constr   = pkgName ++ " installed"++    expected = UserConstraintInstalled (PackageName pkgName)+    actual   = let (Right r) = readUserConstraint constr in r++parseUserConstraintTest :: Assertion+parseUserConstraintTest =+  assertEqual ("Couldn't parse constraint: '" ++ constr ++ "'") expected actual+  where+    pkgName  = "template-haskell"+    constr   = pkgName ++ " installed"++    expected = [UserConstraintInstalled (PackageName pkgName)]+    actual   = [ x | (x, ys) <- readP_to_S parseUserConstraint constr+                   , all isSpace ys]++    parseUserConstraint :: ReadP r UserConstraint+    parseUserConstraint = parse++readUserConstraintsTest :: Assertion+readUserConstraintsTest =+  assertEqual ("Couldn't read constraints: '" ++ constr ++ "'") expected actual+  where+    pkgName  = "template-haskell"+    constr   = pkgName ++ " installed"++    expected = [[UserConstraintInstalled (PackageName pkgName)]]+    actual   = [ x | (x, ys) <- readP_to_S parseUserConstraints constr+                   , all isSpace ys]++    parseUserConstraints :: ReadP r [UserConstraint]+    parseUserConstraints = parseCommaList parse
+ cabal/cabal-install/tests/test-cabal-install view
@@ -0,0 +1,9 @@+#!/bin/sh++darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \+cd Cabal/cabal-install && \+make && \+sudo make install && \+sudo cabal-install update && \+cabal-install install --prefix=/tmp --user hnop && \+ls -l /tmp/bin/hnop
+ cabal/cabal-install/tests/test-cabal-install-user view
@@ -0,0 +1,8 @@+#!/bin/sh++darcs get --partial http://darcs.haskell.org/packages/Cabal/ && \+cd Cabal/cabal-install && \+make install-user && \+cabal-install update && \+cabal-install install --prefix=/tmp --user hnop && \+ls -l /tmp/bin/hnop
hackport.cabal view
@@ -1,5 +1,5 @@ Name:           hackport-Version:        0.3.5+Version:        0.3.6 License:        GPL License-file:   LICENSE Author:         Henning Günther, Duncan Coutts, Lennart Kolmodin@@ -19,6 +19,7 @@  Executable    hackport   ghc-options: -Wall+  ghc-prof-options: -caf-all -auto-all -rtsopts   Main-Is:    Main.hs   Default-Language: Haskell98   Hs-Source-Dirs: ., cabal, cabal/Cabal, cabal/cabal-install@@ -32,6 +33,7 @@     pretty,     regex-compat,     MissingH,+    old-locale,     HTTP >= 4000.0.3,     zlib,     tar,
+ mk_release_tarball.bash view
@@ -0,0 +1,28 @@+#!/usr/bin/env bash++set -e++srcdir=`pwd`+tempdir=`mktemp --directory`+latest_tag=`git tag --list | tail -n 1`+P="hackport-${latest_tag#v}"+tarball_name="${srcdir}/${P}.tar.gz"+(+    cd "${tempdir}"+    echo "building '${tarball_name}' in '${tempdir}'"++    git clone "${srcdir}/" "${P}"+    (+        cd "${P}"+        git reset --hard "${latest_tag}"+        git clean -dfx+        git submodule update --init++        # drop redundant bits+        rm -r -- .git cabal/.git+        # cabal is not able to unpack long tar names+        rm -r -- cabal/Cabal/tests+    )+    tar -czf "${tarball_name}" "${P}"/+)+rm -rf -- "${tempdir}"
tests/normalize_deps.hs view
@@ -116,13 +116,30 @@                     , "!a? ( c/na )"                     ]                   )-                , -- push stricter context into less trict+                , -- push stricter context into less strict                   ( d_all [ d_ge pnm [2,0]                           , d_use "a" $ d_ge pnm [1,0]                           ]                   ,                     [ ">=dev-haskell/mtl-2.0" ]                   )+                {- TODO: this one is hardest to implement,+                         but also most interesting simplification+                         due to our dependency expansion when resolving.+                , -- lift nested use context for complementary depends+                  --   a? b? ( x y ) !a? b? ( x )+                  -- leads to+                  --   a? ( y ) b? ( x )+                  ( d_all [ d_use  "a" $ d_use "b" $ d_all $ map d_p [ "x", "y" ]+                          , d_nuse "a" $ d_use "b" $ d_p "x"+                          ]+                  , [ "c/x"+                    , "c/y"+                    , "a? ( c/y )"+                    , "b? ( c/x )"+                    ]+                  )+                  -}                 ]     forM_ deps $ \(d, expected) ->         let actual = P.dep2str 0 d