fully preserve input format of connect and disconnect commands

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

diff --git a/Annex/Sim.hs b/Annex/Sim.hs
index 05596b6363bb6b20c867597056812374028e3aab..17d98f7f24afce7f0e160c3092e65c041f43f9c8 100644 (file)
--- a/Annex/Sim.hs
+++ b/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
-       | CommandDisconnect RepoName RemoteName
+       | CommandConnect Connections
+       | 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 = 
-       checkKnownRepo repo st $ \u -> Right $ Right $ st
-               { simConnections = 
-                       let s = case M.lookup u (simConnections st) of
-                               Just cs -> S.insert remote cs
-                               Nothing -> S.singleton remote
-                       in M.insert u s (simConnections st)
-               }
-applySimCommand' (CommandDisconnect repo remote) st = 
-       checkKnownRepo repo st $ \u -> Right $ Right $ 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)
-               }
+applySimCommand' (CommandConnect connections) st =
+       let (repo, remote, mconnections) = getConnection connections
+       in checkKnownRepo repo st $ \u -> 
+               let st' = st
+                       { simConnections = 
+                               let s = case M.lookup u (simConnections st) of
+                                       Just cs -> S.insert remote cs
+                                       Nothing -> S.singleton remote
+                               in M.insert u s (simConnections st)
+                       }
+               in case mconnections of
+                       Nothing -> Right $ Right st'
+                       Just connections' ->
+                               applySimCommand' (CommandConnect connections') 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 $

diff --git a/Annex/Sim/File.hs b/Annex/Sim/File.hs
index 068a346a96c90a272957b3840781e6b13fbe28b8..47776bf4fb801abb56fb5e3e0eceba8987c393d4 100644 (file)
--- a/Annex/Sim/File.hs
+++ b/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 c (l:ls) = case parseSimFileLine l of
-               Right cs -> go (c ++ cs) ls
+       go cs [] = Right (reverse cs)
+       go cs (l:ls) = case parseSimFileLine l of
+               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]
-       | all isSpace s = Right [CommandBlank]
+       | "#" `isPrefixOf` s = Right (CommandComment s)
+       | 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) =
-               handleconnect name remote rest
-       go (CommandDisconnect (RepoName name) (RemoteName remote) : rest) =
-               ["disconnect", name, "->", remote] : go rest
+       go (CommandConnect c : rest) =
+               ("connect":formatConnections c) : go rest
+       go (CommandDisconnect c : 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)]
-parseSimCommand        ("connect":rest) =
-       parseConnect CommandConnect rest
+       Right $ CommandUse (RepoName name) (unwords rest)
+parseSimCommand        ("connect":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]
-parseConnect mk = go []
+parseConnections :: [String] -> Either String Connections
+parseConnections = go . reverse
   where
-       go c [] = Right (reverse c)
-       go c (r1:"->":r2:rest) = 
-               go (mk (RepoName r1) (RemoteName r2):c)
-                       (chain r2 rest)
-       go c (r1:"<-":r2:rest) = 
-               go (mk (RepoName r2) (RemoteName r1):c)
-                       (chain r2 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 ++ "\""
+       go (r2:"->":r1:rest) = 
+               chain (RepoName r1 :-> RemoteName r2) rest
+       go (r2:"<-":r1:rest) = 
+               chain (RemoteName r1 :<- RepoName r2) rest
+       go (r2:"<->":r1:rest) = 
+               chain (RepoName r1 :<-> RepoName r2) rest
+       go rest = bad 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 ++ "\""
 
-       chain v rest = if null rest then rest else v: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
 

diff --git a/Command/Sim.hs b/Command/Sim.hs
index 3b629bc64dd4703458273440f69b983ecd78721e..9b812ed1d68d759f06eb32adc8d604972619aa94 100644 (file)
--- a/Command/Sim.hs
+++ b/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")))