took Josh's asvice and unified the Repo data types & used pattern matching more

GitRepo.hs

@@ -54,47 +54,37 @@ import Utility
 
 {- There are two types of repositories; those on local disk and those
  - accessed via an URL. -}
-data Repo = 
+data RepoLocation = Dir FilePath | Url URI
+	deriving (Show, Eq)
+
+data Repo = Repo {
+	location :: RepoLocation,
+	config :: Map String String,
+	remotes :: [Repo],
+	-- remoteName holds the name used for this repo in remotes
+	remoteName :: Maybe String 
+} deriving (Show, Eq)
+
+newFrom l = 
 	Repo {
-		top :: FilePath,
+		location = l,
-		config :: Map String String,
+		config = Map.empty,
-		remotes :: [Repo],
+		remotes = [],
-		-- remoteName holds the name used for this repo in remotes
+		remoteName = Nothing
-		remoteName :: Maybe String 
+	}
-	} | UrlRepo {
-		url :: URI,
-		config :: Map String String,
-		remotes :: [Repo],
-		remoteName :: Maybe String
-	} deriving (Show, Eq)
 
 {- Local Repo constructor. -}
 repoFromPath :: FilePath -> Repo
-repoFromPath dir =
+repoFromPath dir = newFrom $ Dir dir
-	Repo {
-		top = dir,
-		config = Map.empty,
-		remotes = [],
-		remoteName = Nothing
-	}
 
 {- Remote Repo constructor. Throws exception on invalid url. -}
 repoFromUrl :: String -> Repo
-repoFromUrl url =
+repoFromUrl url = newFrom $ Url $ fromJust $ parseURI url
-	UrlRepo {
-		url = fromJust $ parseURI url,
-		config = Map.empty,
-		remotes = [],
-		remoteName = Nothing
-	}
 
 {- User-visible description of a git repo. -}
-repoDescribe repo = 
+repoDescribe Repo { remoteName = Just name } = name
-	if (isJust $ remoteName repo)
+repoDescribe Repo { location = Url url } = show url
-		then fromJust $ remoteName repo
+repoDescribe Repo { location = Dir dir } = dir
-		else if (not $ repoIsUrl repo)
-			then top repo
-			else show (url repo)
 
 {- Constructs and returns an updated version of a repo with
  - different remotes list. -}
@@ -103,17 +93,19 @@ remotesAdd repo rs = repo { remotes = rs }
 
 {- Returns the name of the remote that corresponds to the repo, if 
  - it is a remote. Otherwise, "" -}
-repoRemoteName r = 
+repoRemoteName Repo { remoteName = Just name } = name
-	if (isJust $ remoteName r)
+repoRemoteName _ = ""
-		then fromJust $ remoteName r
-		else ""
 
 {- Some code needs to vary between URL and normal repos,
  - or bare and non-bare, these functions help with that. -}
-repoIsUrl repo = case (repo) of
+repoIsUrl Repo { location = Url _ } = True
-	UrlRepo {} -> True
+repoIsUrl _ = False
-	Repo {} -> False
+
-repoIsSsh repo = repoIsUrl repo && (uriScheme $ url repo) == "ssh:"
+repoIsSsh Repo { location = Url url } 
+	| uriScheme url == "ssh:" = True
+	| otherwise = False
+repoIsSsh _ = False
+
 assertLocal repo action = 
 	if (not $ repoIsUrl repo)
 		then action
@@ -124,10 +116,10 @@ assertUrl repo action =
 		then action
 		else error $ "acting on local git repo " ++  (repoDescribe repo) ++ 
 				" not supported"
-assertssh repo action =
+assertSsh repo action =
 	if (repoIsSsh repo)
 		then action
-		else error $ "unsupported url " ++ (show $ url repo)
+		else error $ "unsupported url in repo " ++ (repoDescribe repo)
 bare :: Repo -> Bool
 bare repo = case Map.lookup "core.bare" $ config repo of
 	Just v -> configTrue v
@@ -137,55 +129,56 @@ bare repo = case Map.lookup "core.bare" $ config repo of
 
 {- Path to a repository's gitattributes file. -}
 attributes :: Repo -> String
-attributes repo = assertLocal repo $ do
+attributes repo
-	if (bare repo)
+	| bare repo = (workTree repo) ++ "/info/.gitattributes"
-		then (top repo) ++ "/info/.gitattributes"
+	| otherwise = (workTree repo) ++ "/.gitattributes"
-		else (top repo) ++ "/.gitattributes"
 
 {- Path to a repository's .git directory, relative to its workTree. -}
 dir :: Repo -> String
-dir repo = if (bare repo) then "" else ".git"
+dir repo
+	| bare repo = ""
+	| otherwise = ".git"
 
 {- Path to a repository's --work-tree, that is, its top.
  -
- - Note that for URL repositories, this is relative to the urlHost -}
+ - Note that for URL repositories, this is the path on the remote host. -}
 workTree :: Repo -> FilePath
-workTree r@(UrlRepo { }) = urlPath r
+workTree r@(Repo { location = Url _ }) = urlPath r
-workTree (Repo { top = p }) = p
+workTree (Repo { location = Dir d }) = d
 
 {- Given a relative or absolute filename in a repository, calculates the
  - name to use to refer to the file relative to a git repository's top.
  - This is the same form displayed and used by git. -}
 relative :: Repo -> String -> String
-relative repo file = assertLocal repo $ drop (length absrepo) absfile
+relative repo@(Repo { location = Dir d }) file = drop (length absrepo) absfile
 	where
 		-- normalize both repo and file, so that repo
 		-- will be substring of file
-		absrepo = case (absNormPath "/" (top repo)) of
+		absrepo = case (absNormPath "/" d) of
 			Just f -> f ++ "/"
-			Nothing -> error $ "bad repo" ++ (top repo)
+			Nothing -> error $ "bad repo" ++ (repoDescribe repo)
 		absfile = case (secureAbsNormPath absrepo file) of
 			Just f -> f
 			Nothing -> error $ file ++ " is not located inside git repository " ++ absrepo
+relative repo file = assertLocal repo $ error "internal"
 
 {- Hostname of an URL repo. (May include a username and/or port too.) -}
 urlHost :: Repo -> String
-urlHost repo = assertUrl repo $ 
+urlHost Repo { location = Url u } = uriUserInfo a ++ uriRegName a ++ uriPort a
-	uriUserInfo a ++ uriRegName a ++ uriPort a
+	where a = fromJust $ uriAuthority $ u
-	where 
+urlHost repo = assertUrl repo $ error "internal"
-		a = fromJust $ uriAuthority $ url repo
 
 {- Path of an URL repo. -}
 urlPath :: Repo -> String
-urlPath repo = assertUrl repo $
+urlPath Repo { location = Url u } = uriPath u
-	uriPath $ url repo
+urlPath repo = assertUrl repo $ error "internal"
 
 {- Constructs a git command line operating on the specified repo. -}
 gitCommandLine :: Repo -> [String] -> [String]
-gitCommandLine repo params = assertLocal repo $
+gitCommandLine repo@(Repo { location = Dir d} ) params =
 	-- force use of specified repo via --git-dir and --work-tree
-	["--git-dir="++(top repo)++"/"++(dir repo),
+	["--git-dir="++d++"/"++(dir repo), "--work-tree="++d] ++ params
-		"--work-tree="++(top repo)] ++ params
+gitCommandLine repo _ = assertLocal repo $ error "internal"
 
 {- Runs git in the specified repo. -}
 run :: Repo -> [String] -> IO ()
@@ -215,23 +208,23 @@ notInRepo repo location = do
 
 {- Runs git config and populates a repo with its config. -}
 configRead :: Repo -> IO Repo
-configRead repo = 
+configRead repo@(Repo { location = Dir d }) = do
-	if (not $ repoIsUrl repo)
+	{- Cannot use pipeRead because it relies on the config having
-	then do 
+	   been already read. Instead, chdir to the repo. -}
-		{- Cannot use pipeRead because it relies on the config having
+	cwd <- getCurrentDirectory
-	           been already read. Instead, chdir to the repo. -}
+	bracket_ (changeWorkingDirectory d)
-		cwd <- getCurrentDirectory
+		(\_ -> changeWorkingDirectory cwd) $
-		bracket_ (changeWorkingDirectory (top repo))
+			pOpen ReadFromPipe "git" ["config", "--list"] $
-			(\_ -> changeWorkingDirectory cwd) $
+				hConfigRead repo
-				pOpen ReadFromPipe "git" ["config", "--list"] proc
+configRead repo = assertSsh repo $ do
-	else assertssh repo $ do
+	pOpen ReadFromPipe "ssh" [urlHost repo, sshcommand] $ hConfigRead repo
-		pOpen ReadFromPipe "ssh" [urlHost repo, sshcommand] proc
 	where
-		sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++ " && git config --list"
+		sshcommand = "cd " ++ (shellEscape $ urlPath repo) ++
-		proc h = do
+				" && git config --list"
-			val <- hGetContentsStrict h
+hConfigRead repo h = do
-			let r = repo { config = configParse val }
+	val <- hGetContentsStrict h
-			return r { remotes = configRemotes r }	
+	let r = repo { config = configParse val }
+	return r { remotes = configRemotes r }	
 
 {- Checks if a string fron git config is a true value. -}
 configTrue :: String -> Bool
@@ -246,9 +239,8 @@ configRemotes repo = map construct remotes
 		isremote k = (startswith "remote." k) && (endswith ".url" k)
 		remotename k = (split "." k) !! 1
 		construct (k,v) = (gen v) { remoteName = Just $ remotename k }
-		gen v = if (isURI v)
+		gen v	| isURI v = repoFromUrl v
-			then repoFromUrl v
+			| otherwise = repoFromPath v
-			else repoFromPath v
 
 {- Parses git config --list output into a config map. -}
 configParse :: String -> Map.Map String String