fully preserve input format of connect and disconnect commands

Just lifted the sim file as a DSL into the type level for that.

Annex/Sim.hs

@@ -153,12 +153,49 @@ newtype RemoteName = RemoteName { fromRemoteName :: String }
 remoteNameToRepoName :: RemoteName -> RepoName
 remoteNameToRepoName (RemoteName n) = RepoName n
 
+repoNameToRemoteName :: RepoName -> RemoteName
+repoNameToRemoteName (RepoName n) = RemoteName n
+
+data Connections
+	= RepoName :-> RemoteName
+	| RemoteName :<- RepoName
+	| RepoName :<-> RepoName
+	| RepoName :=> Connections
+	| RemoteName :<= Connections
+	| RepoName :<=> Connections
+	deriving (Show)
+
+leftSideOfConnection :: Connections -> RepoName
+leftSideOfConnection (reponame :-> _) = reponame
+leftSideOfConnection (remotename :<- _) = remoteNameToRepoName remotename
+leftSideOfConnection (reponame :<-> _) = reponame
+leftSideOfConnection (reponame :=> _) = reponame
+leftSideOfConnection (remotename :<= _) = remoteNameToRepoName remotename
+leftSideOfConnection (reponame :<=> _) = reponame
+
+getConnection :: Connections -> (RepoName, RemoteName, Maybe Connections)
+getConnection (reponame :-> remotename) = (reponame, remotename, Nothing)
+getConnection (remotename :<- reponame) = (reponame, remotename, Nothing)
+getConnection (reponame1 :<-> reponame2) =
+	( reponame1
+	, repoNameToRemoteName reponame2
+	, Just (reponame2 :-> repoNameToRemoteName reponame1)
+	)
+getConnection (reponame :=> c) =
+	(reponame, repoNameToRemoteName (leftSideOfConnection c), Just c)
+getConnection (remotename :<= c) = (leftSideOfConnection c, remotename, Just c)
+getConnection (reponame :<=> c) = 
+	( reponame
+	, repoNameToRemoteName (leftSideOfConnection c)
+	, Just (reponame :=> c)
+	)
+
 data SimCommand
 	= CommandInit RepoName
 	| CommandInitRemote RepoName
 	| CommandUse RepoName String
-	| CommandConnect RepoName RemoteName
+	| CommandConnect Connections
-	| CommandDisconnect RepoName RemoteName
+	| CommandDisconnect Connections
 	| CommandAddTree RepoName PreferredContentExpression
 	| CommandAdd RawFilePath ByteSize [RepoName]
 	| CommandStep Int
@@ -234,22 +271,34 @@ applySimCommand' (CommandUse reponame s) st =
 		Left msg -> Left $ "Unable to use a repository \"" 
 			++ fromRepoName reponame 
 			++ "\" in the simulation because " ++ msg
-applySimCommand' (CommandConnect repo remote) st = 
+applySimCommand' (CommandConnect connections) st =
-	checkKnownRepo repo st $ \u -> Right $ Right $ st
+	let (repo, remote, mconnections) = getConnection connections
-		{ simConnections = 
+	in checkKnownRepo repo st $ \u -> 
-			let s = case M.lookup u (simConnections st) of
+		let st' = st
-				Just cs -> S.insert remote cs
+			{ simConnections = 
-				Nothing -> S.singleton remote
+				let s = case M.lookup u (simConnections st) of
-			in M.insert u s (simConnections st)
+					Just cs -> S.insert remote cs
-		}
+					Nothing -> S.singleton remote
-applySimCommand' (CommandDisconnect repo remote) st = 
+				in M.insert u s (simConnections st)
-	checkKnownRepo repo st $ \u -> Right $ Right $ st
+			}
-		{ simConnections = 
+		in case mconnections of
-			let sc = case M.lookup u (simConnections st) of
+			Nothing -> Right $ Right st'
-				Just s -> S.delete remote s
+			Just connections' ->
-				Nothing -> S.empty
+				applySimCommand' (CommandConnect connections') st'
-			in M.insert u sc (simConnections st)
+applySimCommand' (CommandDisconnect connections) st = 
-		}
+	let (repo, remote, mconnections) = getConnection connections
+	in checkKnownRepo repo st $ \u -> 
+		let st' = st
+			{ simConnections = 
+				let sc = case M.lookup u (simConnections st) of
+					Just s -> S.delete remote s
+					Nothing -> S.empty
+				in M.insert u sc (simConnections st)
+			}
+		in case mconnections of
+			Nothing -> Right $ Right $ st
+			Just connections' ->
+				applySimCommand' (CommandDisconnect connections') st'
 applySimCommand' (CommandAddTree repo expr) st =
 	checkKnownRepo repo st $ const $
 		checkValidPreferredContentExpression expr $ Left $

Annex/Sim/File.hs

@@ -20,15 +20,15 @@ import Text.Read
 parseSimFile :: String -> Either String [SimCommand]
 parseSimFile = go [] . lines
   where
-	go c [] = Right c
+	go cs [] = Right (reverse cs)
-	go c (l:ls) = case parseSimFileLine l of
+	go cs (l:ls) = case parseSimFileLine l of
-		Right cs -> go (c ++ cs) ls
+		Right command -> go (command:cs) ls
 		Left err -> Left err
 
-parseSimFileLine :: String -> Either String [SimCommand]
+parseSimFileLine :: String -> Either String SimCommand
 parseSimFileLine s
-	| "#" `isPrefixOf` s = Right [CommandComment s]
+	| "#" `isPrefixOf` s = Right (CommandComment s)
-	| all isSpace s = Right [CommandBlank]
+	| all isSpace s = Right (CommandBlank)
 	| otherwise = parseSimCommand (words s)
 
 generateSimFile :: [SimCommand] -> String
@@ -41,10 +41,10 @@ generateSimFile = unlines . map unwords . go
 		["initremote", name] : go rest
 	go (CommandUse (RepoName name) what : rest) =
 		["use", name, what] : go rest
-	go (CommandConnect (RepoName name) (RemoteName remote) : rest) =
+	go (CommandConnect c : rest) =
-		handleconnect name remote rest
+		("connect":formatConnections c) : go rest
-	go (CommandDisconnect (RepoName name) (RemoteName remote) : rest) =
+	go (CommandDisconnect c : rest) =
-		["disconnect", name, "->", remote] : go rest
+		("disconnect":formatConnections c) : go rest
 	go (CommandAddTree (RepoName name) expr : rest) =
 		["addtree", name, expr] : go rest
 	go (CommandAdd f sz repos : rest) =
@@ -98,117 +98,123 @@ generateSimFile = unlines . map unwords . go
 	go (CommandBlank : rest) = 
 		[""] : go rest
 
-	handleconnect name remote (CommandConnect (RepoName name2) (RemoteName remote2) : rest)
-		| name == remote2 && name2 == remote =
-			let (chain, rest') = chainconnect remote rest
-			in (["connect", name, "<->", remote] ++ chain) : go rest'
-	handleconnect name remote rest = 
-		["connect", name, "->", remote] : go rest
-	
-	chainconnect name (CommandConnect (RepoName name2) (RemoteName remote2) : rest)
-		| name == name2 = case rest of
-			(CommandConnect (RepoName name3) (RemoteName remote3) : rest')
-				| remote2 == name3 ->
-					let (chain, rest'') = chainconnect remote3 rest'
-					in (["<->", remote2] ++ chain, rest'')
-			_ ->
-				let (chain, rest') = chainconnect remote2 rest
-				in (["->", remote2] ++ chain, rest')
-	chainconnect _ rest = ([], rest)
-
 	showsize = filter (not . isSpace) . preciseSize storageUnits True
 
-parseSimCommand :: [String] -> Either String [SimCommand]
+parseSimCommand :: [String] -> Either String SimCommand
 parseSimCommand ("init":name:[]) = 
-	Right [CommandInit (RepoName name)]
+	Right $ CommandInit (RepoName name)
 parseSimCommand ("initremote":name:[]) =
-	Right [CommandInitRemote (RepoName name)]
+	Right $ CommandInitRemote (RepoName name)
 parseSimCommand ("use":name:rest) =
-	Right [CommandUse (RepoName name) (unwords rest)]
+	Right $ CommandUse (RepoName name) (unwords rest)
-parseSimCommand	("connect":rest) =
+parseSimCommand	("connect":rest) = 
-	parseConnect CommandConnect rest
+	CommandConnect <$> parseConnections rest
 parseSimCommand	("disconnect":rest) =
-	parseConnect CommandDisconnect rest
+	CommandDisconnect <$> parseConnections rest
 parseSimCommand ("addtree":name:rest) =
-	Right [CommandAddTree(RepoName name) (unwords rest)]
+	Right $ CommandAddTree(RepoName name) (unwords rest)
 parseSimCommand ("add":filename:size:repos) =
 	case readSize dataUnits size of
-		Just sz -> Right [CommandAdd (toRawFilePath filename) sz (map RepoName repos)]
+		Just sz -> Right $ CommandAdd
+			(toRawFilePath filename)
+			sz
+			(map RepoName repos)
 		Nothing -> Left $ "Unable to parse file size \"" ++ size ++ "\""
 parseSimCommand ("step":n:[]) =
 	case readMaybe n of
-			Just n' -> Right [CommandStep n']
+			Just n' -> Right $ CommandStep n'
 			Nothing -> Left $ "Unable to parse step value \"" ++ n ++ "\""
 parseSimCommand ("action":repo:"pull":remote:[]) =
-	Right [CommandAction (RepoName repo) (ActionPull (RemoteName remote))]
+	Right $ CommandAction (RepoName repo)
+		(ActionPull (RemoteName remote))
 parseSimCommand ("action":repo:"push":remote:[]) =
-	Right [CommandAction (RepoName repo) (ActionPush (RemoteName remote))]
+	Right $ CommandAction (RepoName repo)
+		(ActionPush (RemoteName remote))
 parseSimCommand ("action":repo:"getwanted":remote:[]) =
-	Right [CommandAction (RepoName repo) (ActionGetWanted (RemoteName remote))]
+	Right $ CommandAction (RepoName repo)
+		(ActionGetWanted (RemoteName remote))
 parseSimCommand	("action":repo:"dropunwanted":[]) =
-	Right [CommandAction (RepoName repo) (ActionDropUnwanted Nothing)]
+	Right $ CommandAction (RepoName repo)
+		(ActionDropUnwanted Nothing)
 parseSimCommand ("action":repo:"dropunwanted":remote:[]) =
-	Right [CommandAction (RepoName repo) (ActionDropUnwanted (Just (RemoteName remote)))]
+	Right $ CommandAction (RepoName repo)
+		(ActionDropUnwanted (Just (RemoteName remote)))
 parseSimCommand ("action":repo:"gitpush":remote:[]) =
-	Right [CommandAction (RepoName repo) (ActionGitPush (RemoteName remote))]
+	Right $ CommandAction (RepoName repo) 
+		(ActionGitPush (RemoteName remote))
 parseSimCommand ("action":repo:"gitpull":remote:[]) =
-	Right [CommandAction (RepoName repo) (ActionGitPull (RemoteName remote))]
+	Right $ CommandAction (RepoName repo)
+		(ActionGitPull (RemoteName remote))
 parseSimCommand	("seed":n:[]) =
 	case readMaybe n of
-		Just n' -> Right [CommandSeed n']
+		Just n' -> Right $ CommandSeed n'
 		Nothing -> Left $ "Unable to parse seed value \"" ++ n ++ "\""
 parseSimCommand ("present":repo:file:[]) =
-	Right [CommandPresent (RepoName repo) (toRawFilePath file)]
+	Right $ CommandPresent (RepoName repo) (toRawFilePath file)
 parseSimCommand ("notpresent":repo:file:[]) =
-	Right [CommandNotPresent (RepoName repo) (toRawFilePath file)]
+	Right $ CommandNotPresent (RepoName repo) (toRawFilePath file)
 parseSimCommand ("numcopies":n:[]) =
 	case readMaybe n of
-		Just n' -> Right [CommandNumCopies n']
+		Just n' -> Right $ CommandNumCopies n'
 		Nothing -> Left $ "Unable to parse numcopies value \"" ++ n ++ "\""
 parseSimCommand ("mincopies":n:[]) =
 	case readMaybe n of
-		Just n' -> Right [CommandMinCopies n']
+		Just n' -> Right $ CommandMinCopies n'
 		Nothing -> Left $ "Unable to parse mincopies value \"" ++ n ++ "\""
 parseSimCommand ("trustlevel":repo:s:[]) =
 	case readTrustLevel s of
-		Just trustlevel -> Right [CommandTrustLevel (RepoName repo) trustlevel]
+		Just trustlevel -> Right $ 
+			CommandTrustLevel (RepoName repo) trustlevel
 		Nothing -> Left $ "Unknown trust level \"" ++ s ++ "\"."
 parseSimCommand ("group":repo:group:[]) =
-	Right [CommandGroup (RepoName repo) (toGroup group)]
+	Right $ CommandGroup (RepoName repo) (toGroup group)
 parseSimCommand ("ungroup":repo:group:[]) =
-	Right [CommandUngroup (RepoName repo) (toGroup group)]
+	Right $ CommandUngroup (RepoName repo) (toGroup group)
 parseSimCommand ("wanted":repo:expr) =
-	Right [CommandWanted (RepoName repo) (unwords expr)]
+	Right $ CommandWanted (RepoName repo) (unwords expr)
 parseSimCommand ("required":repo:expr) =
-	Right [CommandRequired (RepoName repo) (unwords expr)]
+	Right $ CommandRequired (RepoName repo) (unwords expr)
 parseSimCommand ("groupwanted":group:expr) =
-	Right [CommandGroupWanted (toGroup group) (unwords expr)]
+	Right $ CommandGroupWanted (toGroup group) (unwords expr)
 parseSimCommand ("maxsize":repo:size:[]) =
 	case readSize dataUnits size of
-		Just sz -> Right [CommandMaxSize (RepoName repo) (MaxSize sz)]
+		Just sz -> Right $ CommandMaxSize (RepoName repo) (MaxSize sz)
 		Nothing -> Left $ "Unable to parse maxsize \"" ++ size ++ "\""
 parseSimCommand ("rebalance":onoff:[]) = case isTrueFalse onoff of
-	Just b -> Right [CommandRebalance b]
+	Just b -> Right $ CommandRebalance b
 	Nothing -> Left $ "Unable to parse rebalance value \"" ++ onoff ++ "\""
 parseSimCommand ws = Left $ "Unable to parse sim command: \"" ++ unwords ws ++ "\""
 
-parseConnect :: (RepoName -> RemoteName -> SimCommand) -> [String] -> Either String [SimCommand]
+parseConnections :: [String] -> Either String Connections
-parseConnect mk = go []
+parseConnections = go . reverse
   where
-	go c [] = Right (reverse c)
+	go (r2:"->":r1:rest) = 
-	go c (r1:"->":r2:rest) = 
+		chain (RepoName r1 :-> RemoteName r2) rest
-		go (mk (RepoName r1) (RemoteName r2):c)
+	go (r2:"<-":r1:rest) = 
-			(chain r2 rest)
+		chain (RemoteName r1 :<- RepoName r2) rest
-	go c (r1:"<-":r2:rest) = 
+	go (r2:"<->":r1:rest) = 
-		go (mk (RepoName r2) (RemoteName r1):c)
+		chain (RepoName r1 :<-> RepoName r2) rest
-			(chain r2 rest)
+	go rest = bad rest
-	go c (r1:"<->":r2:rest) = 
-		go (mk (RepoName r2) (RemoteName r1)
-			: mk (RepoName r1) (RemoteName r2)
-			: c
-			)
-			(chain r2 rest)
-	go _ rest = Left $ "Bad connect syntax near \"" ++ unwords rest ++ "\""
 
-	chain v rest = if null rest then rest else v:rest
+	chain c [] = Right c
+	chain c ("->":r:rest) = chain (RepoName r :=> c) rest
+	chain c ("<-":r:rest) = chain (RemoteName r :<= c) rest
+	chain c ("<->":r:rest) = chain (RepoName r :<=> c) rest
+	chain _ rest = bad rest
+
+	bad rest = Left $ "Bad connect syntax near \"" ++ unwords rest ++ "\""
+
+formatConnections :: Connections -> [String]
+formatConnections (RepoName repo :-> RemoteName remote) =
+	[repo, "->", remote]
+formatConnections (RemoteName remote :<- RepoName repo) =
+	[remote, "<-", repo]
+formatConnections (RepoName repo1 :<-> RepoName repo2) =
+	[repo1, "<->", repo2]
+formatConnections (RepoName repo :=> c) =
+	repo : "->" : formatConnections c
+formatConnections (RemoteName remote :<= c) =
+	remote : "<-" : formatConnections c
+formatConnections (RepoName repo :<=> c) =
+	repo : "<->" : formatConnections c
 

Command/Sim.hs

@@ -30,8 +30,6 @@ seek _ = do
 		let st = emptySimState rng repobyname getpath
 		st' <- runSimCommand (CommandInit (RepoName "foo")) st
 			>>= runSimCommand (CommandUse (RepoName "bar") "here")
-			>>= runSimCommand (CommandConnect (RepoName "foo") (RemoteName "bar"))
-			>>= runSimCommand (CommandConnect (RepoName "bar") (RemoteName "foo"))
 			>>= runSimCommand (CommandAdd "bigfile" 1000000 [RepoName "foo"])
 			>>= runSimCommand (CommandAction (RepoName "bar") (ActionGitPull (RemoteName "foo")))
 			>>= runSimCommand (CommandAction (RepoName "bar") (ActionGetWanted (RemoteName "foo")))