diff --git a/CabalMeta.hs b/CabalMeta.hs --- a/CabalMeta.hs +++ b/CabalMeta.hs @@ -1,11 +1,18 @@ {-# LANGUAGE CPP, OverloadedStrings #-} -module CabalMeta where +module CabalMeta ( + Package (..) + , PackageSources (..) + , readPackages + , packageList + , vendor_dir + , gitPackages + ) where import Shelly hiding (tag) import Prelude hiding (FilePath) import Data.Text.Lazy (Text, unpack) import qualified Data.Text.Lazy as T -import Filesystem.Path.CurrentOS (hasExtension, filename) +import Filesystem.Path.CurrentOS (hasExtension, basename) import Data.Maybe (fromMaybe, maybeToList) import Data.List (partition) @@ -37,22 +44,34 @@ gitLocation :: Text , pFlags :: [Text] , gTag :: Maybe Text +} | DarcsPackage { + darcsLocation :: Text + , pFlags :: [Text] + , darcsTag :: Maybe Text } deriving (Show, Eq) asList :: Package -> [Text] asList (Package l flags) = l:flags asList (GitPackage l flags tag) = l : flags ++ maybeToList tag +asList (DarcsPackage l flags tag) = l : flags ++ maybeToList tag asList (Directory d flags) = toTextIgnore d : flags +asInstallList :: Package -> [Text] +asInstallList (Package l flags) = l:flags +asInstallList (GitPackage l flags _tag) = urlToDiskPath l : flags +asInstallList (DarcsPackage l flags _tag) = urlToDiskPath l : flags +asInstallList (Directory d flags) = toTextIgnore d : flags + data PackageSources = PackageSources { dirs :: [Package] , hackages :: [Package] , https :: [Package] -- also git for now , gits :: [Package] + , darcsen :: [Package] } deriving (Show, Eq) packageList :: PackageSources -> [[Text]] -packageList = map asList . packages +packageList = map asInstallList . packages packages :: PackageSources -> [Package] packages psources = @@ -65,17 +84,25 @@ gits psources ++ https psources instance Monoid PackageSources where - mempty = PackageSources [] [] [] [] - mappend (PackageSources d1 ha1 ht1 g1) (PackageSources d2 ha2 ht2 g2) = + mempty = PackageSources [] [] [] [] [] + mappend (PackageSources d1 ha1 ht1 g1 da1) (PackageSources d2 ha2 ht2 g2 da2) = PackageSources (mappend d1 d2) (mappend ha1 ha2) - (mappend ht1 ht2) (mappend g1 g2) + (mappend ht1 ht2) (mappend g1 g2) (mappend da1 da2) vendor_dir :: FilePath vendor_dir = "vendor" +-- | Translate a remote repository location to the on-disk location we +-- fetched it to +urlToDiskPath :: Text -> Text +urlToDiskPath x = toTextIgnore $ vendor_dir basename (fromText x) + git_ :: Text -> [Text] -> ShIO () git_ = command1_ "git" [] +darcs_ :: Text -> [Text] -> ShIO () +darcs_ = command1_ "darcs" [] + readPackages :: Bool -> FilePath -> ShIO PackageSources readPackages allowCabals startDir = do fullDir <- canonic startDir @@ -85,13 +112,14 @@ psources <- getSources when (psources == mempty) $ terror $ "empty " <> toTextIgnore source_file - let git_pkgs = gitPackages psources + let git_pkgs = gitPackages psources + darcs_pkgs = darcsen psources child_vendor_pkgs <- if null git_pkgs then return [] else do mkdir_p vendor_dir - chdir vendor_dir $ - forM git_pkgs $ \pkg -> do + chdir vendor_dir $ do + gkids <- forM git_pkgs $ \pkg -> do let repo = gitLocation pkg - let d = filename $ fromText repo + let d = basename $ fromText repo e <- test_d d if not e then git_ "clone" ["--recursive", repo] @@ -100,7 +128,18 @@ git_ "checkout" [fromMaybe "master" (gTag pkg)] git_ "submodule" ["foreach", "git", "pull", "origin", "master"] readPackages False d - + dkids <- forM darcs_pkgs $ \pkg -> do + let repo = darcsLocation pkg + tflags = case darcsTag pkg of + Nothing -> [] + Just t -> ["--tag", t] + let d = basename $ fromText repo + e <- test_d d + if not e + then darcs_ "get" $ ["--lazy", repo] ++ tflags + else chdir d $ darcs_ "pull" ["--all"] + readPackages False d + return (gkids ++ dkids) child_dir_pkgs <- forM (dirs psources) $ \dir -> do b <- fmap (== fullDir) (canonic $ dLocation dir) if b then return mempty else readPackages False (dLocation dir) @@ -115,7 +154,8 @@ hackages = hackages psources ++ concatMap hackages child_pkgs , dirs = concatMap (\(p, ps) -> if null ps then [p] else ps) $ - zip (dirs psources ++ gits psources ++ https psources) (map dirs child_pkgs) + zip (dirs psources ++ gits psources ++ https psources ++ darcsen psources) + (map dirs child_pkgs) } where headMay [] = Nothing @@ -145,15 +185,24 @@ go sources [] = sources go _ ([]:_) = error "impossible" go sources ((name:flags):more) = let n = T.head name in - if n == '.' || n == '/' then go sources { dirs = mkDir: dirs sources } more - else if "http" `T.isPrefixOf` name then go sources { https = mkGit: https sources } more - else if "https" `T.isPrefixOf` name then go sources { gits = mkGit: https sources } more - else if "git:" `T.isPrefixOf` name then go sources { gits = mkGit: gits sources } more - else go sources { hackages = mkPkg: hackages sources } more + case () of + _ | n `elem` "./" -> next sources { dirs = mkDir: dirs sources } + | prefix "http" -> next sources { https = mkGit: https sources } + | prefix "https" -> next sources { gits = mkGit: https sources } + | prefix "git:" -> next sources { gits = mkGit: gits sources } + | prefix "darcs:" -> next sources { darcsen = mkDarcs: darcsen sources } + | otherwise -> next sources { hackages = mkPkg: hackages sources } where + prefix x = x `T.isPrefixOf` name + next s2 = go s2 more mkDir = Directory (fromText name) flags mkPkg = Package name flags - mkGit = let (realFlags, tags) = partition (T.isPrefixOf "-") flags in + mkGit = GitPackage name realFlags tag + mkDarcs = + case T.stripPrefix "darcs:" name of + Nothing -> error $ unpack $ "did not understand" <> T.intercalate " " (asList (Package name flags)) + Just realName -> DarcsPackage realName realFlags tag + (realFlags, tag) = let (rf, tags) = partition (T.isPrefixOf "-") flags in if length tags > 1 then error $ unpack $ "did not understand" <> T.intercalate " " (asList (Package name flags)) - else GitPackage name realFlags (headMay tags) + else (rf, headMay tags) diff --git a/cabal-meta.cabal b/cabal-meta.cabal --- a/cabal-meta.cabal +++ b/cabal-meta.cabal @@ -1,5 +1,5 @@ name: cabal-meta -version: 0.2.3.2 +version: 0.3 license: BSD3 license-file: LICENSE author: Greg Weber @@ -51,7 +51,7 @@ type: exitcode-stdio-1.0 build-depends: shelly >= 0.9 - , hspec, HUnit, unix, base, text, system-filepath + , hspec >= 1.3, unix, base, text, system-filepath -- , file-location extensions: OverloadedStrings diff --git a/test/main.hs b/test/main.hs --- a/test/main.hs +++ b/test/main.hs @@ -1,9 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} import Shelly import CabalMeta -import Test.Hspec.Monadic -import Test.HUnit ((@?=),(@=?), Assertion, assertFailure, assertBool) -import Test.Hspec.HUnit () +import Test.Hspec import Data.Text.Lazy () import System.IO import Filesystem.Path.CurrentOS hiding (fromText, ()) @@ -17,4 +15,4 @@ return (ps, d) let localize = (\p-> toTextIgnore $ wd fromText p) - concatMap asList (packages psources) @?= [localize "test/child/grandchild", "top-package", "sphinx", "-fone-one-beta", "child-package"] + concatMap asList (packages psources) `shouldBe` [localize "test/child/grandchild", "top-package", "sphinx", "-fone-one-beta", "child-package"]