Created
September 24, 2025 11:33
-
-
Save justjoheinz/b764c28ad4be3aa317a0780a178cf18f to your computer and use it in GitHub Desktop.
MultiChor - choreographic programming cond problem
This file contains hidden or bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
| module Main (main) where | |
| import Choreography | |
| import Choreography.Network.Http | |
| import System.Environment (getArgs) | |
| $(mkLoc "alice") | |
| $(mkLoc "bob") | |
| $(mkLoc "carol") | |
| type Participants = '["alice", "bob", "carol", "jimmy"] | |
| type Worker = '["bob", "carol"] | |
| worker :: Subset Worker Participants | |
| worker = explicitSubset | |
| subChoreography :: Bool -> Choreo Worker IO () | |
| subChoreography b = do | |
| if b then do | |
| bob `_locally_` putStrLn "Bob says: I still need to work." | |
| instruction_carol <- ( | |
| bob, | |
| pure "Alice decided you can go home now.") | |
| -~> carol @@ nobody | |
| carol `locally_` \un -> putStrLn $ "Carol received: " ++ un singleton instruction_carol | |
| else do | |
| carol `_locally_` putStrLn "Carol says: I still need to work." | |
| instruction_bob <- ( | |
| carol, | |
| pure "Alice decided you can go home now.") | |
| -~> bob @@ nobody | |
| bob `locally_` \un -> putStrLn $ "Bob received: " ++ un singleton instruction_bob | |
| return () | |
| choreography :: Choreo Participants IO () | |
| choreography = do | |
| let allParticipants = allOf @Participants | |
| alice `_locally_` putStrLn "Alice: Please enter who needs to work (bob | alice):" | |
| decision :: Located '["alice"] Bool <- alice `_locally` fmap (== "bob") getLine | |
| sharedDecision :: Located Participants Bool <- (alice, decision) ~> allParticipants | |
| _ <- (worker, (worker, sharedDecision)) `cond` subChoreography | |
| pure () | |
| {- | |
| main :: IO () | |
| main = do | |
| runChoreo choreography | |
| -} | |
| main :: IO () | |
| main = do | |
| [loc] <- getArgs | |
| _ <- case loc of | |
| "alice" -> runChoreography cfg choreography "alice" | |
| "bob" -> runChoreography cfg choreography "bob" | |
| "carol" -> runChoreography cfg choreography "carol" | |
| _ -> error "Unknown location" | |
| return () | |
| where | |
| cfg = | |
| mkHttpConfig | |
| [ ("alice", ("localhost", 4242)), | |
| ("bob", ("localhost", 4343)), | |
| ("carol", ("localhost", 4444)) | |
| ] | |
Sign up for free
to join this conversation on GitHub.
Already have an account?
Sign in to comment