diff options
Diffstat (limited to 'Git.hs')
| -rw-r--r-- | Git.hs | 100 |
1 files changed, 51 insertions, 49 deletions
@@ -188,13 +188,13 @@ repoRemoteName Repo { remoteName = Just name } = Just name repoRemoteName _ = Nothing {- Sets the name of a remote. -} -repoRemoteNameSet :: Repo -> String -> Repo -repoRemoteNameSet r n = r { remoteName = Just n } +repoRemoteNameSet :: String -> Repo -> Repo +repoRemoteNameSet n r = r { remoteName = Just n } {- Sets the name of a remote based on the git config key, such as "remote.foo.url". -} -repoRemoteNameFromKey :: Repo -> String -> Repo -repoRemoteNameFromKey r k = repoRemoteNameSet r basename +repoRemoteNameFromKey :: String -> Repo -> Repo +repoRemoteNameFromKey k = repoRemoteNameSet basename where basename = join "." $ reverse $ drop 1 $ reverse $ drop 1 $ split "." k @@ -280,8 +280,8 @@ workTree Repo { location = Unknown } = undefined - is itself a symlink). But, if the cwd is "/tmp/repo/subdir", - it's best to refer to "../foo". -} -workTreeFile :: Repo -> FilePath -> IO FilePath -workTreeFile repo@(Repo { location = Dir d }) file = do +workTreeFile :: FilePath -> Repo -> IO FilePath +workTreeFile file repo@(Repo { location = Dir d }) = do cwd <- getCurrentDirectory let file' = absfile cwd unless (inrepo file') $ @@ -296,7 +296,7 @@ workTreeFile repo@(Repo { location = Dir d }) file = do absfile c = fromMaybe file $ secureAbsNormPath c file inrepo f = absrepo `isPrefixOf` f bad = error $ "bad repo" ++ repoDescribe repo -workTreeFile repo _ = assertLocal repo $ error "internal" +workTreeFile _ repo = assertLocal repo $ error "internal" {- Path of an URL repo. -} urlPath :: Repo -> String @@ -350,23 +350,23 @@ urlAuthPart a Repo { location = Url u } = a auth urlAuthPart _ repo = assertUrl repo $ error "internal" {- Constructs a git command line operating on the specified repo. -} -gitCommandLine :: Repo -> [CommandParam] -> [CommandParam] -gitCommandLine repo@(Repo { location = Dir _ } ) params = +gitCommandLine :: [CommandParam] -> Repo -> [CommandParam] +gitCommandLine params repo@(Repo { location = Dir _ } ) = -- force use of specified repo via --git-dir and --work-tree [ Param ("--git-dir=" ++ gitDir repo) , Param ("--work-tree=" ++ workTree repo) ] ++ params -gitCommandLine repo _ = assertLocal repo $ error "internal" +gitCommandLine _ repo = assertLocal repo $ error "internal" {- Runs git in the specified repo. -} -runBool :: Repo -> String -> [CommandParam] -> IO Bool -runBool repo subcommand params = assertLocal repo $ - boolSystem "git" $ gitCommandLine repo $ Param subcommand : params +runBool :: String -> [CommandParam] -> Repo -> IO Bool +runBool subcommand params repo = assertLocal repo $ + boolSystem "git" $ gitCommandLine (Param subcommand : params) repo {- Runs git in the specified repo, throwing an error if it fails. -} -run :: Repo -> String -> [CommandParam] -> IO () -run repo subcommand params = assertLocal repo $ - runBool repo subcommand params +run :: String -> [CommandParam] -> Repo -> IO () +run subcommand params repo = assertLocal repo $ + runBool subcommand params repo >>! error $ "git " ++ show params ++ " failed" {- Runs a git subcommand and returns its output, lazily. @@ -374,26 +374,26 @@ run repo subcommand params = assertLocal repo $ - Note that this leaves the git process running, and so zombies will - result unless reap is called. -} -pipeRead :: Repo -> [CommandParam] -> IO L.ByteString -pipeRead repo params = assertLocal repo $ do - (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine repo params +pipeRead :: [CommandParam] -> Repo -> IO L.ByteString +pipeRead params repo = assertLocal repo $ do + (_, h) <- hPipeFrom "git" $ toCommand $ gitCommandLine params repo hSetBinaryMode h True L.hGetContents h {- Runs a git subcommand, feeding it input. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWrite :: Repo -> [CommandParam] -> L.ByteString -> IO PipeHandle -pipeWrite repo params s = assertLocal repo $ do - (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine repo params) +pipeWrite :: [CommandParam] -> L.ByteString -> Repo -> IO PipeHandle +pipeWrite params s repo = assertLocal repo $ do + (p, h) <- hPipeTo "git" (toCommand $ gitCommandLine params repo) L.hPut h s hClose h return p {- Runs a git subcommand, feeding it input, and returning its output. - You should call either getProcessStatus or forceSuccess on the PipeHandle. -} -pipeWriteRead :: Repo -> [CommandParam] -> L.ByteString -> IO (PipeHandle, L.ByteString) -pipeWriteRead repo params s = assertLocal repo $ do - (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine repo params) +pipeWriteRead :: [CommandParam] -> L.ByteString -> Repo -> IO (PipeHandle, L.ByteString) +pipeWriteRead params s repo = assertLocal repo $ do + (p, from, to) <- hPipeBoth "git" (toCommand $ gitCommandLine params repo) hSetBinaryMode from True L.hPut to s hClose to @@ -402,13 +402,13 @@ pipeWriteRead repo params s = assertLocal repo $ do {- Reads null terminated output of a git command (as enabled by the -z - parameter), and splits it. -} -pipeNullSplit :: Repo -> [CommandParam] -> IO [String] -pipeNullSplit repo params = map L.unpack <$> pipeNullSplitB repo params +pipeNullSplit :: [CommandParam] -> Repo -> IO [String] +pipeNullSplit params repo = map L.unpack <$> pipeNullSplitB params repo {- For when Strings are not needed. -} -pipeNullSplitB :: Repo -> [CommandParam] -> IO [L.ByteString] -pipeNullSplitB repo params = filter (not . L.null) . L.split '\0' <$> - pipeRead repo params +pipeNullSplitB ::[CommandParam] -> Repo -> IO [L.ByteString] +pipeNullSplitB params repo = filter (not . L.null) . L.split '\0' <$> + pipeRead params repo {- Reaps any zombie git processes. -} reap :: IO () @@ -448,15 +448,15 @@ shaSize = 40 {- Commits the index into the specified branch, - with the specified parent refs. -} -commit :: Repo -> String -> String -> [String] -> IO () -commit g message newref parentrefs = do +commit :: String -> String -> [String] -> Repo -> IO () +commit message newref parentrefs repo = do tree <- getSha "write-tree" $ asString $ - pipeRead g [Param "write-tree"] + pipeRead [Param "write-tree"] repo sha <- getSha "commit-tree" $ asString $ - ignorehandle $ pipeWriteRead g + ignorehandle $ pipeWriteRead (map Param $ ["commit-tree", tree] ++ ps) - (L.pack message) - run g "update-ref" [Param newref, Param sha] + (L.pack message) repo + run "update-ref" [Param newref, Param sha] repo where ignorehandle a = snd <$> a asString a = L.unpack <$> a @@ -478,13 +478,13 @@ configRead r = assertLocal r $ error "internal" hConfigRead :: Repo -> Handle -> IO Repo hConfigRead repo h = do val <- hGetContentsStrict h - configStore repo val + configStore val repo {- Stores a git config into a repo, returning the new version of the repo. - The git config may be multiple lines, or a single line. Config settings - can be updated inrementally. -} -configStore :: Repo -> String -> IO Repo -configStore repo s = do +configStore :: String -> Repo -> IO Repo +configStore s repo = do let repo' = repo { config = configParse s `M.union` config repo } rs <- configRemotes repo' return $ repo' { remotes = rs } @@ -507,13 +507,11 @@ configRemotes repo = mapM construct remotepairs filterkeys f = filterconfig (\(k,_) -> f k) remotepairs = filterkeys isremote isremote k = startswith "remote." k && endswith ".url" k - construct (k,v) = do - r <- genRemote repo v - return $ repoRemoteNameFromKey r k + construct (k,v) = repoRemoteNameFromKey k <$> genRemote v repo {- Generates one of a repo's remotes using a given location (ie, an url). -} -genRemote :: Repo -> String -> IO Repo -genRemote repo = gen . calcloc +genRemote :: String -> Repo -> IO Repo +genRemote s repo = gen $ calcloc s where filterconfig f = filter f $ M.toList $ config repo gen v @@ -549,8 +547,8 @@ configTrue :: String -> Bool configTrue s = map toLower s == "true" {- Returns a single git config setting, or a default value if not set. -} -configGet :: Repo -> String -> String -> String -configGet repo key defaultValue = +configGet :: String -> String -> Repo -> String +configGet key defaultValue repo = M.findWithDefault defaultValue key (config repo) {- Access to raw config Map -} @@ -558,8 +556,8 @@ configMap :: Repo -> M.Map String String configMap = config {- Efficiently looks up a gitattributes value for each file in a list. -} -checkAttr :: Repo -> String -> [FilePath] -> IO [(FilePath, String)] -checkAttr repo attr files = do +checkAttr :: String -> [FilePath] -> Repo -> IO [(FilePath, String)] +checkAttr attr files repo = do -- git check-attr needs relative filenames input; it will choke -- on some absolute filenames. This also means it will output -- all relative filenames. @@ -574,7 +572,11 @@ checkAttr repo attr files = do hClose toh (map topair . lines) <$> hGetContents fromh where - params = gitCommandLine repo [Param "check-attr", Param attr, Params "-z --stdin"] + params = gitCommandLine + [ Param "check-attr" + , Param attr + , Params "-z --stdin" + ] repo topair l = (file, value) where file = decodeGitFile $ join sep $ take end bits |