operational 0.1.0.0 → 0.2.0.0
raw patch · 24 files changed
+1736/−722 lines, 24 filesPVP ok
version bump matches the API change (PVP)
API changes (from Hackage documentation)
- Control.Monad.Operational: data PromptT instr m a
- Control.Monad.Operational: type Prompt instr a = PromptT instr Identity a
+ Control.Monad.Operational: data ProgramViewT instr m a
+ Control.Monad.Operational: instance (MonadIO m) => MonadIO (ProgramT instr m)
+ Control.Monad.Operational: instance (MonadState s m) => MonadState s (ProgramT instr m)
+ Control.Monad.Operational: liftProgram :: (Monad m) => Program instr a -> ProgramT instr m a
+ Control.Monad.Operational: type ProgramView instr a = ProgramViewT instr Identity a
- Control.Monad.Operational: (:>>=) :: instr b -> (b -> ProgramT instr m a) -> PromptT instr m a
+ Control.Monad.Operational: (:>>=) :: instr b -> (b -> ProgramT instr m a) -> ProgramViewT instr m a
- Control.Monad.Operational: Return :: a -> PromptT instr m a
+ Control.Monad.Operational: Return :: a -> ProgramViewT instr m a
- Control.Monad.Operational: view :: Program instr a -> Prompt instr a
+ Control.Monad.Operational: view :: Program instr a -> ProgramView instr a
- Control.Monad.Operational: viewT :: (Monad m) => ProgramT instr m a -> m (PromptT instr m a)
+ Control.Monad.Operational: viewT :: (Monad m) => ProgramT instr m a -> m (ProgramViewT instr m a)
Files
- CHANGELOG +15/−0
- docs/Documentation.html +0/−588
- docs/Documentation.md +33/−33
- docs/Makefile +30/−4
- docs/docbook.css +0/−35
- docs/examples/ListT.hs +6/−6
- docs/examples/LogicT.hs +7/−7
- docs/examples/PoorMansConcurrency.hs +7/−7
- docs/examples/State.hs +6/−6
- docs/examples/TicTacToe.hs +176/−0
- docs/examples/WebSessionState.lhs +5/−5
- docs/web/Documentation.html +635/−0
- docs/web/examples.html +26/−0
- docs/web/examples/ListT.hs.html +66/−0
- docs/web/examples/LogicT.hs.html +96/−0
- docs/web/examples/PoorMansConcurrency.hs.html +73/−0
- docs/web/examples/State.hs.html +70/−0
- docs/web/examples/TicTacToe.hs.html +186/−0
- docs/web/examples/WebSessionState.lhs.html +112/−0
- docs/web/examples/hscolour.css +5/−0
- docs/web/fptools.css +48/−0
- docs/web/index.html +24/−0
- operational.cabal +13/−8
- src/Control/Monad/Operational.hs +97/−23
+ CHANGELOG view
@@ -0,0 +1,15 @@+Changelog+---------++operational - 0.2.0.0++* changed name of view type to `ProgramView`+* added instances for mtl classes+* new function `liftProgram` to embed `Program` in `ProgramT`++* new example TicTacToe.hs+* various documentation updates++operational - 0.1.0.0++* initial release
− docs/Documentation.html
@@ -1,588 +0,0 @@-<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">-<html xmlns="http://www.w3.org/1999/xhtml">-<head>- <title>Documentation for the "operational" package</title>- <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />- <meta name="generator" content="pandoc" />- <meta name="author" content="Heinrich Apfelmus" />- <meta name="date" content="Sun, 24 Jan 2010 11:57:24 +0100" />- <link rel="stylesheet" href="docbook.css" type="text/css" />-</head>-<body>-<h1 class="title">Documentation for the "operational" package</h1>-<div id="TOC"-><ul- ><li- ><a href="#introduction"- >Introduction</a- ></li- ><li- ><a href="#using-this-library"- >Using this Library</a- ><ul- ><li- ><a href="#changes-to-the-Program-type"- >Changes to the <code- >Program</code- > type</a- ></li- ><li- ><a href="#efficiency"- >Efficiency</a- ></li- ><li- ><a href="#monad-transformers"- >Monad Transformers</a- ></li- ><li- ><a href="#alternatives-to-monad-transformers"- >Alternatives to Monad Transformers</a- ></li- ></ul- ></li- ><li- ><a href="#design-and-implementation"- >Design and Implementation</a- ><ul- ><li- ><a href="#proof-of-the-monad-laws-sketch"- >Proof of the monad laws (Sketch)</a- ></li- ><li- ><a href="#monad-transformers-1"- >Monad Transformers</a- ></li- ></ul- ></li- ><li- ><a href="#other-design-choices"- >Other Design Choices</a- ><ul- ><li- ><a href="#recursive-type-definitions-with-Program"- >Recursive type definitions with <code- >Program</code- ></a- ></li- ></ul- ></li- ></ul- ></div->-<p-><em- >The HTML version of this document is generated automatically from the corresponding markdown file, don't change it!</em- ></p-><div id="introduction"-><h1- ><a href="#TOC"- >Introduction</a- ></h1- ><p- >This package is based on <a href="http://themonadreader.wordpress.com/2010/01/26/issue-15/"- >"The Operational Monad Tutorial"</a- > and this documentation describes its extension to a production-quality library. In other words, the "magic" gap between relevant paper and library implementation is documented here.</p- ><p- >Take not that this this library is only ~50 lines of code, yet the documentation even includes a proof! :-)</p- ><p- >Sources and inspiration for this library include <a href="http://web.cecs.pdx.edu/~cklin/papers/unimo-143.pdf" title="Chuan-kai Lin. Programming Monads Operationally with Unimo."- >Chuan-kai Lin's unimo paper</a- >, <a href="http://citeseer.ist.psu.edu/hughes95design.html" title="John Hughes. The Design of a Pretty-printing Library."- >John Hughes 95</a- >, and <a href="http://hackage.haskell.org/package/MonadPrompt" title="Ryan Ingram's Monad Prompt Package."- >Ryan Ingram's <code- >MonadPrompt</code- > package</a- >.</p- ></div-><div id="using-this-library"-><h1- ><a href="#TOC"- >Using this Library</a- ></h1- ><p- >To understand what's going on, you'll have to read "The Operational Monad Tutorial". Here, I will first and foremost note the changes with respect to the tutorial.</p- ><p- >Several advanced example monads demonstrate how to put this library to good use. They are located in the <a href="./examples"- ><code- >./docs/examples</code- ></a- > folder.</p- ><div id="changes-to-the-Program-type"- ><h2- ><a href="#TOC"- >Changes to the <code- >Program</code- > type</a- ></h2- ><p- >For efficiency reasons, the type <code- >Program</code- > representing a list of instructions is now <em- >abstract</em- >. A function <code- >view</code- > is used to inspect the first instruction; returning a type</p- ><pre- ><code- >data Prompt instr a where- Return :: a -> Prompt instr a- (:>>=) :: instr a -> (a -> Program instr b) -> Prompt instr b-</code- ></pre- ><p- >which is much like the old <code- >Program</code- > type, except that <code- >Then</code- > was renamed to <code- >(:>>=)</code- >. The name <code- >Prompt</code- > was chosen in homage to the <a href="http://hackage.haskell.org/package/MonadPrompt" title="Ryan Ingram's Monad Prompt Package."- ><code- >MonadPrompt</code- > package</a- >.</p- ><p- >To see an example of the new style, here the interpreter for the stack machine from the tutorial:</p- ><pre- ><code- >interpret :: StackProgram a -> (Stack Int -> a)-interpret = eval . view- where- eval :: Prompt StackInstruction a -> (Stack Int -> a)- eval (Push a :>>= is) stack = interpret (is ()) (a:stack)- eval (Pop :>>= is) (a:stack) = interpret (is a ) stack- eval (Return a) stack = a-</code- ></pre- ><p- >So-called "view functions" like <code- >view</code- > are a common way of inspecting data structures that have been made abstract for reasons of efficiency; see for example <code- >viewL</code- > and <code- >viewR</code- > in <a href="http://hackage.haskell.org/package/containers-0.3.0.0"- ><code- >Data.Sequence</code- ></a- >.</p- ></div- ><div id="efficiency"- ><h2- ><a href="#TOC"- >Efficiency</a- ></h2- ><p- >The <code- >Program</code- > type supports <code- >(>>=)</code- > in constant time, albeit with the big caveat that this is only the case when not used in a persistent fashion. However, this is much less a restriction with monads than it would be with lists and <code- >(++)</code- >.</p- ><p- >More precisely, consider</p- ><pre- ><code- >leftAssociative :: Int -> StackProgram Int-leftAssociative 0 = return 1-leftAssociative n = leftAssociative (n-1) >>= push-</code- ></pre- ><p- >and the expression</p- ><pre- ><code- >interpret (leftAssociative n) []-</code- ></pre- ><p- >Evaluating this will now take O(n) instead of O(n^2) time for the old <code- >Program</code- > type from the tutorial. However, persistent use like</p- ><pre- ><code- >let p = leftAssociative n- v1 = view p- v2 = view p- v3 = view p-in v1 `seq` v2 `seq` v3-</code- ></pre- ><p- >will now take O(n) time for each call of <code- >view</code- > instead of O(n) the first time and O(1) for the other calls.</p- ></div- ><div id="monad-transformers"- ><h2- ><a href="#TOC"- >Monad Transformers</a- ></h2- ><p- >Furthermore, <code- >Program</code- > is actually a type synonym and expressed in terms of a monad transformer <code- >ProgramT</code- ></p- ><pre- ><code- >type Program instr a = ProgramT instr Identity a-</code- ></pre- ><p- >Likewise, <code- >view</code- > is a specialization of <code- >viewT</code- > to the identity monad. This change is transparent (except for error messages on type errors) for users who are happy with just <code- >Program</code- > but very convenient for those users who want to use it as a monad transformer.</p- ><p- >The key point about the transformer version <code- >ProgramT</code- > is that in addition to the monad laws, it automatically satisfies the lifting laws for monad transformers as well</p- ><pre- ><code- >lift . return = return-lift m >>= lift . g = lift (m >>= g)-</code- ></pre- ><p- >The corresponding view function <code- >viewT</code- > now returns the type <code- >m (ViewT instr m a)</code- >. It's not entirely clear why this return type will do, but it's straightforward to work with, like in the following implementation of the list monad transformer:</p- ><pre- ><code- >data PlusI m a where- Zero :: PlusI m a- Plus :: ListT m a -> ListT m a -> PlusI m a--type ListT m a = ProgramT (PlusI m) m a--runList :: Monad m => ListT m a -> m [a]-runList = eval <=< viewT- where- eval :: Monad m => PromptT (PlusI m) m a -> m [a]- eval (Return x) = return [x]- eval (Zero :>>= g) = return []- eval (Plus m n :>>= g) =- liftM2 (++) (runList (m >>= g)) (runList (n >>= g))-</code- ></pre- ></div- ><div id="alternatives-to-monad-transformers"- ><h2- ><a href="#TOC"- >Alternatives to Monad Transformers</a- ></h2- ><p- >By the way, note that monad transformers are not the only way to build larger monads from smaller ones; a similar effect can be achieved with the direct sum of instructions sets. For instance, the monad</p- ><pre- ><code- >Program (StateI s :+: ExceptionI e) a--data (f :+: g) a = Inl (f a) | Inr (g a) -- a fancy Either-</code- ></pre- ><p- >is a combination of the state monad</p- ><pre- ><code- >type State a = Program (StateI s) a--data StateI s a where- Put :: s -> StateI s ()- Get :: StateI s s-</code- ></pre- ><p- >and the error monad</p- ><pre- ><code- >type Error e a = Program (ErrorI e) a--data ErrorI e a where- Throw :: e -> ErrorI e ()- Catch :: ErrorI e a -> (e -> ErrorI e a) -> ErrorI e a-</code- ></pre- ><p- >The "sum of signatures" approach and the <code- >(:+:)</code- > type constructor are advocated in <a href="http://www.cse.chalmers.se/~wouter/Publications/DataTypesALaCarte.pdf" title="Wouter Swierstra. Data types � la carte."- >Wouter Swierstra's "Data Types a la carte"</a- >. Time will tell which has more merit; for now I have opted for a seamless interaction with monad transformers.</p- ></div- ></div-><div id="design-and-implementation"-><h1- ><a href="#TOC"- >Design and Implementation</a- ></h1- ><div id="proof-of-the-monad-laws-sketch"- ><h2- ><a href="#TOC"- >Proof of the monad laws (Sketch)</a- ></h2- ><p- >The key point of this library is of course that the <code- >view</code- > and <code- >viewT</code- > functions respect the monad laws. While this seems obvious from the definition, the proof is actually not straightforward.</p- ><p- >First, we restrict ourselves to <code- >view</code- >, i.e. the version without monad transformers. In fact, I don't have a full proof for the version with monad transformers, more about that in the next section.</p- ><p- >Second, we use a sloppy, but much more suitable notation, namely we write</p- ><table- ><tr class="header"- ><th align="left"- ></th- ><th align="center"- ></th- ></tr- ><tr class="odd"- ><td align="left"- ><code- >>>=</code- ></td- ><td align="center"- >instead of <code- >Bind</code- ></td- ></tr- ><tr class="even"- ><td align="left"- ><code- >return</code- ></td- ><td align="center"- >instead of <code- >Lift</code- > for the identity monad</td- ></tr- ><tr class="odd"- ><td align="left"- ><code- >i,j,k,</code- >...</td- ><td align="center"- >for primitive instructions</td- ></tr- ></table- ><p- >Then, the <code- >view</code- > function becomes</p- ><pre- ><code- >view (return a) = Return a-view (return a >>= g) = g a -- left unit-view ((m >>= f) >>= g) = view (m >>= (\x -> f x >>= g) -- associativity-view (i >>= g) = i :>>= g-view i = i :>>= return -- right unit-</code- ></pre- ><p- >Clearly, <code- >view</code- > uses the monad laws to rewrite it's argument. But we want to show that whenever two expressions</p- ><pre- ><code- >e1,e2 :: Program instr a-</code- ></pre- ><p- >can be transformed into each other by rewriting them with the monad laws in <em- >any</em- > fashion (remember that <code- >>>=</code- > and <code- >return</code- > are constructors), then <code- >view</code- > will map them to the same result. More formally, we have an equivalence relation</p- ><pre- ><code- >e1 ~ e2 iff e1 and e2 are the same modulo monad laws-</code- ></pre- ><p- >and want to show</p- ><pre- ><code- >e1 ~ e2 => view e1 = view e2 (some notion of equality)-</code- ></pre- ><p- >Now, this needs proof because <code- >view</code- > is like a term rewriting system and there is no guarantee that two equivalent terms will be rewritten to the same normal form.</p- ><p- >Trying to attack this problem with term rewriting and critical pairs is probably hopeless and not very enlightening. After all, the theorem should be obvious because two equivalent expressions should have the same <em- >first instruction</em- > <code- >i</code- >. Well, we can formalize this with the help of a <em- >normal form</em- ></p- ><pre- ><code- >data NF instr a where- Return' :: a -> NF instr a- (:>>=') :: instr a -> (a -> NF instr b) -> NF instr b-</code- ></pre- ><p- >This is the old program type and the key observation is that <code- >NF instr</code- > is already a monad.</p- ><pre- ><code- >instance Monad (NF inst) where- (Return' a) >>= g = g a- (m :>>=' f) >>= g = m :>>= (\x -> f x >>= g)-</code- ></pre- ><p- >(I'll skip the short calculation and coinduction argument that this really fulfills the monad laws.) We can define a normalization function</p- ><pre- ><code- >normalize :: Program instr a -> NF instr a-normalize (m >>= g) = normalize m >>=' normalize g-normalize (return a) = Return' a-normalize i = i :>>=' Return'-</code- ></pre- ><p- >which has the now obvious property that</p- ><pre- ><code- >e1 ~ e2 => normalize e1 = normalize e2-</code- ></pre- ><p- >Now, the return type of <code- >view</code- > is akin to a <em- >head normal form</em- >, hence</p- ><pre- ><code- > normalize (view e1) = normalize (view e2) -=> view e1 = view e2-</code- ></pre- ><p- >(for some suitable extension of <code- >normalize</code- > to the <code- >Prompt</code- > type.) But since <code- >view</code- > only uses monad laws to rewrite its argument, we also have</p- ><pre- ><code- >e1 ~ view e1 => normalize e1 = normalize (view e1)-</code- ></pre- ><p- >and this concludes the proof, which pretty much only showed that two equivalent expressions have the same instruction list and hence <code- >view</code- > gives equal results.</p- ></div- ><div id="monad-transformers-1"- ><h2- ><a href="#TOC"- >Monad Transformers</a- ></h2- ><p- >The monad transformer case is more hairy, I have no proof here. (If you read this by accident: don't worry, it's still correct. This is for proof nerds only.)</p- ><p- >The main difficulty is that the equation</p- ><pre- ><code- >return = lift . return-</code- ></pre- ><p- >is an equation for the already existing <code- >return</code- > constructor and the notion of "first instruction" no longer applies. Namely, we have</p- ><pre- ><code- >m = return m >>= id = lift (return m) >>= id-</code- ></pre- ><p- >and it's not longer clear what a suitable normal form might be. It appears that <code- >viewT</code- > rewrites the term as follows</p- ><pre- ><code- > lift m >>= g-= lift m >>= (\x -> lift (return (g x)) >>= id)-= (lift m >>= lift . return . g) >>= id-= lift (m >>= return . g) >>= id-</code- ></pre- ><p- >(To be continued.)</p- ></div- ></div-><div id="other-design-choices"-><h1- ><a href="#TOC"- >Other Design Choices</a- ></h1- ><div id="recursive-type-definitions-with-Program"- ><h2- ><a href="#TOC"- >Recursive type definitions with <code- >Program</code- ></a- ></h2- ><p- >In the <a href="http://web.cecs.pdx.edu/~cklin/papers/unimo-143.pdf" title="Chuan-kai Lin. Programming Monads Operationally with Unimo."- >unimo paper</a- >, the instructions carry an additional parameter that "unties" recursive type definition. For example, the instructions for <code- >MonadPlus</code- > are written</p- ><pre- ><code- >data PlusI unimo a where- Zero :: PlusI unimo a- Plus :: unimo a -> unimo a -> PlusI unimo a-</code- ></pre- ><p- >The type constructor variable <code- >unimo</code- > will be tied to <code- >Unimo PlusI</code- >.</p- ><p- >In this library, I have opted for the conceptually simpler approach that requires the user to tie the recursion himself</p- ><pre- ><code- >data PlusI a where- Zero :: PlusI a- Plus :: Program PlusI a -> Program PlusI a -> Plus I a-</code- ></pre- ><p- >I am not sure whether this has major consequences for composeablity; at the moment I believe that the former style can always be recovered from an implementation in the latter style.</p- ></div- ></div->-</body>-</html>-
docs/Documentation.md view
@@ -1,44 +1,44 @@ % Documentation for the "operational" package % Heinrich Apfelmus-% Sun, 24 Jan 2010 11:57:24 +0100+% Sun, 18 Apr 2010 13:06:16 +0200 [tutorial]: http://themonadreader.wordpress.com/2010/01/26/issue-15/ [unimo]: http://web.cecs.pdx.edu/~cklin/papers/unimo-143.pdf "Chuan-kai Lin. Programming Monads Operationally with Unimo." [hughes]: http://citeseer.ist.psu.edu/hughes95design.html "John Hughes. The Design of a Pretty-printing Library." [prompt]: http://hackage.haskell.org/package/MonadPrompt "Ryan Ingram's Monad Prompt Package." -*The HTML version of this document is generated automatically from the corresponding markdown file, don't change it!*+<!-- *The HTML version of this document is generated automatically from the corresponding markdown file, don't change it!* --> Introduction ============ This package is based on ["The Operational Monad Tutorial"][tutorial] and this documentation describes its extension to a production-quality library. In other words, the "magic" gap between relevant paper and library implementation is documented here. -Take not that this this library is only ~50 lines of code, yet the documentation even includes a proof! :-)+Take note that this this library is only ~50 lines of code, yet the documentation even includes a proof! :-) Sources and inspiration for this library include [Chuan-kai Lin's unimo paper][unimo], [John Hughes 95][hughes], and [Ryan Ingram's `MonadPrompt` package][prompt]. Using this Library =================-To understand what's going on, you'll have to read "The Operational Monad Tutorial". Here, I will first and foremost note the changes with respect to the tutorial.+To understand what's going on, you'll have to read ["The Operational Monad Tutorial"][tutorial]. Here, I will first and foremost note the changes with respect to the tutorial. -Several advanced example monads demonstrate how to put this library to good use. They are located in the [`./docs/examples`](./examples) folder.+Several advanced [example monads](./examples.html) demonstrate how to put this library to good use. In the source distribution, the corresponding source files can also be found in the `.docs/examples` folder. Changes to the `Program` type ------------------------------For efficiency reasons, the type `Program` representing a list of instructions is now *abstract*. A function `view` is used to inspect the first instruction; returning a type+For efficiency reasons, the type `Program` representing a list of instructions is now *abstract*. A function `view` is used to inspect the first instruction, it returns a type - data Prompt instr a where- Return :: a -> Prompt instr a- (:>>=) :: instr a -> (a -> Program instr b) -> Prompt instr b+ data ProgramView instr a where+ Return :: a -> ProgramView instr a+ (:>>=) :: instr a -> (a -> Program instr b) -> ProgramView instr b -which is much like the old `Program` type, except that `Then` was renamed to `(:>>=)`. The name `Prompt` was chosen in homage to the [`MonadPrompt` package][prompt].+which is much like the old `Program` type, except that `Then` was renamed to `:>>=` and that the subsequent instructions stored in the second argument of `:>>=` are stored in the type `Program`, not `ProgramView`. To see an example of the new style, here the interpreter for the stack machine from the tutorial: interpret :: StackProgram a -> (Stack Int -> a) interpret = eval . view where- eval :: Prompt StackInstruction a -> (Stack Int -> a)+ eval :: ProgramView StackInstruction a -> (Stack Int -> a) eval (Push a :>>= is) stack = interpret (is ()) (a:stack) eval (Pop :>>= is) (a:stack) = interpret (is a ) stack eval (Return a) stack = a@@ -49,28 +49,28 @@ Efficiency -----------The `Program` type supports `(>>=)` in constant time, albeit with the big caveat that this is only the case when not used in a persistent fashion. However, this is much less a restriction with monads than it would be with lists and `(++)`.--More precisely, consider-- leftAssociative :: Int -> StackProgram Int- leftAssociative 0 = return 1- leftAssociative n = leftAssociative (n-1) >>= push--and the expression+Compared to the original type from the tutorial, `Program` now supports `>>=` in O(1) time in most use cases. This means that left-biased nesting like - interpret (leftAssociative n) []+ let+ nestLeft :: Int -> StackProgram Int+ nestLeft 0 = return 0+ nestLeft n = nestLeft (n-1) >>= push+ in+ interpret (nestLeft n) []+ +will now take O(n) time. In contrast, the old `Program` type from the tutorial would have taken O(n^2) time, similar to `++` for lists taking quadratic time in when nested to the left. -Evaluating this will now take O(n) instead of O(n^2) time for the old `Program` type from the tutorial. However, persistent use like+However, this does *not* hold in a *persistent* setting. In particular, the example - let p = leftAssociative n+ let+ p = nestLeft n v1 = view p v2 = view p v3 = view p- in v1 `seq` v2 `seq` v3--will now take O(n) time for each call of `view` instead of O(n) the first time and O(1) for the other calls.+ in+ v1 `seq` v2 `seq` v3 +will take O(n) time for each call of `view` instead of O(n) the first time and O(1) for the other calls. But since monads are usually used ephemerally, this is much less a restriction than it would be for lists and `++`. Monad Transformers ------------------@@ -80,12 +80,12 @@ Likewise, `view` is a specialization of `viewT` to the identity monad. This change is transparent (except for error messages on type errors) for users who are happy with just `Program` but very convenient for those users who want to use it as a monad transformer. -The key point about the transformer version `ProgramT` is that in addition to the monad laws, it automatically satisfies the lifting laws for monad transformers as well+The key point about the transformer version `ProgramT` is that in addition to the monad laws, it automatically satisfies the lifting laws for monad transformers as well lift . return = return lift m >>= lift . g = lift (m >>= g) -The corresponding view function `viewT` now returns the type `m (ViewT instr m a)`. It's not entirely clear why this return type will do, but it's straightforward to work with, like in the following implementation of the list monad transformer:+The corresponding view function `viewT` now returns the type `m (ViewT instr m a)`. It's not immediately apparent why this return type will do, but it's straightforward to work with, like in the following implementation of the list monad transformer: data PlusI m a where Zero :: PlusI m a@@ -96,11 +96,11 @@ runList :: Monad m => ListT m a -> m [a] runList = eval <=< viewT where- eval :: Monad m => PromptT (PlusI m) m a -> m [a]+ eval :: Monad m => ProgramViewT (PlusI m) m a -> m [a] eval (Return x) = return [x]- eval (Zero :>>= g) = return []- eval (Plus m n :>>= g) =- liftM2 (++) (runList (m >>= g)) (runList (n >>= g))+ eval (Zero :>>= k) = return []+ eval (Plus m n :>>= k) =+ liftM2 (++) (runList (m >>= k)) (runList (n >>= k)) Alternatives to Monad Transformers@@ -198,7 +198,7 @@ normalize (view e1) = normalize (view e2) => view e1 = view e2 -(for some suitable extension of `normalize` to the `Prompt` type.) But since `view` only uses monad laws to rewrite its argument, we also have+(for some suitable extension of `normalize` to the `ProgramView` type.) But since `view` only uses monad laws to rewrite its argument, we also have e1 ~ view e1 => normalize e1 = normalize (view e1)
docs/Makefile view
@@ -1,12 +1,38 @@ ###################################################################### ### Documentation and examples+.PHONY: website doc -.PHONY: doc+examples_hs=ListT LogicT PoorMansConcurrency TicTacToe State+examples_lhs=WebSessionState+examples=$(examples_hs:%=%.hs) $(examples_lhs:%=%.lhs) -doc: Documentation.html-Documentation.html : Documentation.md docbook.css - pandoc --standalone --toc --css=docbook.css "$<" > "$@"+documentation=Documentation.html $(examples:%=examples/%.html) examples/operational-examples.tar.gz +static=index.html examples.html fptools.css++doc: $(documentation:%=web/%)++HOST=apfelmus@code.haskell.org:/srv/projects/operational+website: $(documentation:%=web/%) $(static:%=web/%)+ rsync $(static:%=web/%) web/Documentation.html $(HOST)+ rsync $(examples:%=web/examples/%.html) web/examples/hscolour.css \+ $(HOST)/examples++######################################################################+### Generating documentation++web/Documentation.html : Documentation.md + pandoc --standalone --toc --css=fptools.css \+ --number-sections "$<" > "$@"+ clean: rm Documentation.html++web/%.hs.html: %.hs+ HsColour "$<" -css -o"$@"+web/%.lhs.html: %.lhs+ HsColour "$<" -css -o"$@"++web/examples/operational-examples.tar.gz: $(examples:%=examples/%)+ tar czvf "$@" $^
− docs/docbook.css
@@ -1,35 +0,0 @@-body {- font-family: Verdana, sans-serif;- width: 43em;- margin: 1ex auto 1ex;-}--pre {- font-family: monospace;- font-size: 1em;- display: block;- padding: 10px;- border: 1px solid #bbb;- background-color: #eee;- color: #000; - overflow: auto;- border-radius: 2.5px;- -moz-border-radius: 2.5px;- margin: 0.5em 2em;-}--h1 { font-size:150%; }-h2 { font-size:120%; }--a {- text-decoration: none;- border-bottom: 1px dotted #000;- color: #333;-}--a:hover {- background-color: #777;- color: #fff;-}--
docs/examples/ListT.hs view
@@ -32,16 +32,16 @@ runListT :: Monad m => ListT m a -> m [a] runListT = eval <=< viewT where- eval :: Monad m => PromptT (MPlus m) m a -> m [a]+ eval :: Monad m => ProgramViewT (MPlus m) m a -> m [a] eval (Return x) = return [x]- eval (MZero :>>= g) = return []- eval (MPlus m n :>>= g) =- liftM2 (++) (runListT (m >>= g)) (runListT (n >>= g))+ eval (MZero :>>= k) = return []+ eval (MPlus m n :>>= k) =+ liftM2 (++) (runListT (m >>= k)) (runListT (n >>= k)) testListT :: IO [()] testListT = runListT $ do- k <- choice [1..5]- lift . print $ "You've chosen the number: " ++ show k+ n <- choice [1..5]+ lift . print $ "You've chosen the number: " ++ show n where choice = foldr1 mplus . map return
docs/examples/LogicT.hs view
@@ -8,7 +8,7 @@ http://okmij.org/ftp/papers/LogicT.pdf ------------------------------------------------------------------------------}-{-# LANGUAGE GADTs, Rank2Types, FlexibleInstances #-}+{-# LANGUAGE GADTs, Rank2Types #-} module LogicT (LogicT, msplit, observe, bagOfN, interleave) where import Control.Monad@@ -46,13 +46,13 @@ split = eval <=< viewT where -- apply the laws for msplit- eval :: Monad m => PromptT (MPlus m) m a -> m (Maybe (a, LogicT m a))- eval (MZero :>>= g) = return Nothing- eval (MPlus m n :>>= g) = do- ma <- split (m >>= g)+ eval :: Monad m => ProgramViewT (MPlus m) m a -> m (Maybe (a, LogicT m a))+ eval (MZero :>>= k) = return Nothing+ eval (MPlus m n :>>= k) = do+ ma <- split (m >>= k) case ma of- Nothing -> split (n >>= g)- Just (a,m') -> return $ Just (a, m' `mplus` (n >>= g))+ Nothing -> split (n >>= k)+ Just (a,m') -> return $ Just (a, m' `mplus` (n >>= k)) -- inefficient! -- `mplus` will add another (>>= return) -- to n each time it's called.
docs/examples/PoorMansConcurrency.hs view
@@ -6,7 +6,7 @@ http://www.cs.chalmers.se/~koen/pubs/entry-jfp99-monad.html ------------------------------------------------------------------------------}-{-# LANGUAGE GADTs, Rank2Types, FlexibleInstances #-}+{-# LANGUAGE GADTs, Rank2Types #-} module PoorMansConcurrency where import Control.Monad@@ -43,13 +43,13 @@ where schedule (x:xs) = run (view x) xs - run :: Monad m => Prompt (ProcessI m) a -> [Process m a] -> m ()+ run :: Monad m => ProgramView (ProcessI m) a -> [Process m a] -> m () run (Return _) xs = return () -- process finished- run (Lift m :>>= g) xs = m >>= \a -> -- switch process- schedule (xs ++ [g a])- run (Stop :>>= g) xs = schedule xs -- process halts- run (Fork p :>>= g) xs = schedule (xs ++ [x2,x1]) -- fork new process- where x1 = g (); x2 = p >>= g+ run (Lift m :>>= k) xs = m >>= \a -> -- switch process+ schedule (xs ++ [k a])+ run (Stop :>>= k) xs = schedule xs -- process halts+ run (Fork p :>>= k) xs = schedule (xs ++ [x2,x1]) -- fork new process+ where x1 = k (); x2 = p >>= k -- example -- > runProcess example -- warning: runs indefinitely
docs/examples/State.hs view
@@ -24,10 +24,10 @@ evalState :: State s a -> s -> a evalState = eval . view where- eval :: Prompt (StateI s) a -> (s -> a)+ eval :: ProgramView (StateI s) a -> (s -> a) eval (Return x) = const x- eval (Get :>>= g) = \s -> evalState (g s ) s- eval (Put s :>>= g) = \_ -> evalState (g ()) s+ eval (Get :>>= k) = \s -> evalState (k s ) s+ eval (Put s :>>= k) = \_ -> evalState (k ()) s put :: s -> StateT s m () put = singleton . Put@@ -49,10 +49,10 @@ evalStateT :: Monad m => StateT s m a -> s -> m a evalStateT m = \s -> viewT m >>= \p -> eval p s where- eval :: Monad m => PromptT (StateI s) m a -> (s -> m a)+ eval :: Monad m => ProgramViewT (StateI s) m a -> (s -> m a) eval (Return x) = \_ -> return x- eval (Get :>>= g) = \s -> evalStateT (g s ) s- eval (Put s :>>= g) = \_ -> evalStateT (g ()) s+ eval (Get :>>= k) = \s -> evalStateT (k s ) s+ eval (Put s :>>= k) = \_ -> evalStateT (k ()) s testStateT = evalStateT $ do x <- get
+ docs/examples/TicTacToe.hs view
@@ -0,0 +1,176 @@+{------------------------------------------------------------------------------+ Control.Monad.Operational+ + Example:+ An implementation of the game TicTacToe.+ + Each player (human, AI, ...) is implemented in a separate monad+ which are then intermingled to run the game. This resembles the+ PoorMansConcurrency.hs example.+ + + Many thanks to Yves Pars and Bertram Felgenhauer+ http://www.haskell.org/pipermail/haskell-cafe/2010-April/076216.html++------------------------------------------------------------------------------}+{-# LANGUAGE GADTs, Rank2Types #-}+module TicTacToe where++import Control.Monad+import Control.Monad.Operational+import Control.Monad.State++import Data.Either+import Data.List++ -- external libraries needed+import System.Random++{------------------------------------------------------------------------------+ The Player monad for implementing players (human, AI, ...)+ provides two operations+ + readBoard -- read the current board position+ playMove -- play a move++ to query the current board position and perform a move, respectively.+ + Moreover, it's actually a monad transformer intended to be used over IO.+ This way, the players can perform IO computations.+------------------------------------------------------------------------------}+data PlayerI a where+ ReadBoard :: PlayerI Board+ PlayMove :: Int -> PlayerI Bool+ +type Player m a = ProgramT PlayerI m a++readBoard = singleton ReadBoard+playMove = singleton . PlayMove++ -- interpreter+runGame :: Player IO () -> Player IO () -> IO ()+runGame player1 player2 = eval' initialGameState player1 player2+ where+ eval' game p1 p2 = viewT p1 >>= \p1view -> eval game p1view p2+ + eval :: GameState+ -> ProgramViewT PlayerI IO () -> Player IO ()+ -> IO ()+ eval game (Return _) _ = return ()+ eval game (ReadBoard :>>= p1) p2 = eval' game (p1 (board game)) p2+ eval game (PlayMove mv :>>= p1) p2 =+ case makeMove mv game of+ Nothing -> eval' game (p1 False) p2+ Just game'+ | won game' -> let p = activePlayer game in+ putStrLn $ "Player " ++ show p ++ " has won!"+ | draw game'-> putStrLn $ "It's a draw."+ | otherwise -> eval' game' p2 (p1 True)+ + -- example: human vs AI+main = do+ g <- getStdGen+ runGame playerHuman (playerAI g)++{------------------------------------------------------------------------------+ TicTacToe Board type and logic+ + The board looks like this:+ + +---+---+---+ some squares already played on+ | 1 | 2 | 3 | the empty squares are numbered+ +---+---+---++ | 4 | 5 |OOO|+ +---+---+---++ | 7 |XXX| 9 |+ +---+---+---++------------------------------------------------------------------------------}+data Symbol = X | O deriving (Eq,Show)+type Square = Either Int Symbol+type Board = [[Square]]+data GameState = Game { board :: Board, activePlayer :: Symbol }++initialGameState :: GameState+initialGameState = Game (map (map Left) [[1,2,3],[4,5,6],[7,8,9]]) X++ -- list the possible moves to play+possibleMoves :: Board -> [Int]+possibleMoves board = [k | Left k <- concat board]++ -- play a stone at a square+makeMove :: Int -> GameState -> Maybe GameState+makeMove k (Game board player)+ | not (k `elem` possibleMoves board) = Nothing -- illegal move+ | otherwise = Just $ Game (map (map replace) board) (switch player)+ where+ replace (Left k') | k' == k = Right player+ replace x = x++ switch X = O+ switch O = X++ -- has somebody won the game?+won :: GameState -> Bool+won (Game board _) = any full $ diagonals board ++ rows board ++ cols board+ where+ full [a,b,c] = a == b && b == c+ diagonals [[a1,_,b1],+ [_ ,c,_ ],+ [b2,_,a2]] = [[a1,c,a2],[b1,c,b2]]+ rows = id+ cols = transpose++ -- is the game a draw?+draw :: GameState -> Bool+draw (Game board _) = null (possibleMoves board)++ -- print the board+showSquare = either (\n -> " " ++ show n ++ " ") (concat . replicate 3 . show)++showBoard :: Board -> String+showBoard board =+ unlines . surround "+---+---+---+"+ . map (concat . surround "|". map showSquare)+ $ board+ where+ surround x xs = [x] ++ intersperse x xs ++ [x]++printBoard = putStr . showBoard++{------------------------------------------------------------------------------+ Player examples+------------------------------------------------------------------------------}+ -- a human player on the command line+playerHuman :: Player IO ()+playerHuman = forever $ readBoard >>= liftIO . printBoard >> doMove+ where+ -- ask the player where to move+ doMove :: Player IO ()+ doMove = do+ liftIO . putStrLn $ "At which number would you like to play?"+ n <- liftIO getLine+ b <- playMove (read n)+ unless b $ do+ liftIO . putStrLn $ "Position " ++ show n ++ " is already full."+ doMove++ -- a random AI,+ -- also demonstrates how to use a custom StateT on top+ -- of the Player monad+playerAI :: Monad m => StdGen -> Player m ()+playerAI = evalStateT ai+ where+ ai :: Monad m => StateT StdGen (ProgramT PlayerI m) ()+ ai = forever $ do+ board <- lift $ readBoard+ n <- uniform (possibleMoves board) -- select a random move+ lift $ playMove n+ where+ -- select one element at random+ uniform :: Monad m => [a] -> StateT StdGen m a+ uniform xs = do+ gen <- get+ let (n,gen') = randomR (1,length xs) gen+ put gen'+ return (xs !! (n-1))+
docs/examples/WebSessionState.lhs view
@@ -8,7 +8,7 @@ http://www.informatik.uni-freiburg.de/~thiemann/WASH/draft.pdf ------------------------------------------------------------------------------}-{-# LANGUAGE GADTs, Rank2Types, FlexibleInstances #-}+{-# LANGUAGE GADTs, Rank2Types #-} module WebSessionState where import Control.Monad@@ -61,11 +61,11 @@ where replay = eval . view - eval :: Prompt WebI H.Html -> [String] -> [String] -> CGI H.Html+ eval :: ProgramView WebI H.Html -> [String] -> [String] -> CGI H.Html eval (Return html) log _ = return html- eval (Ask question :>>= g) log (l:ls) = -- replay answer from log- replay (g l) log ls- eval (Ask question :>>= g) log [] = -- present HTML page to user+ eval (Ask question :>>= k) log (l:ls) = -- replay answer from log+ replay (k l) log ls+ eval (Ask question :>>= k) log [] = -- present HTML page to user return $ htmlQuestion log question
+ docs/web/Documentation.html view
@@ -0,0 +1,635 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Transitional//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">+<html xmlns="http://www.w3.org/1999/xhtml">+<head>+ <title>Documentation for the "operational" package</title>+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />+ <meta name="generator" content="pandoc" />+ <meta name="author" content="Heinrich Apfelmus" />+ <meta name="date" content="Sun, 18 Apr 2010 13:06:16 +0200" />+ <link rel="stylesheet" href="fptools.css" type="text/css" />+</head>+<body>+<h1 class="title">Documentation for the "operational" package</h1>+<div id="TOC"+><ul+ ><li+ ><a href="#introduction"+ ><span class="toc-section-number"+ >1</span+ > Introduction</a+ ></li+ ><li+ ><a href="#using-this-library"+ ><span class="toc-section-number"+ >2</span+ > Using this Library</a+ ><ul+ ><li+ ><a href="#changes-to-the-Program-type"+ ><span class="toc-section-number"+ >2.1</span+ > Changes to the <code+ >Program</code+ > type</a+ ></li+ ><li+ ><a href="#efficiency"+ ><span class="toc-section-number"+ >2.2</span+ > Efficiency</a+ ></li+ ><li+ ><a href="#monad-transformers"+ ><span class="toc-section-number"+ >2.3</span+ > Monad Transformers</a+ ></li+ ><li+ ><a href="#alternatives-to-monad-transformers"+ ><span class="toc-section-number"+ >2.4</span+ > Alternatives to Monad Transformers</a+ ></li+ ></ul+ ></li+ ><li+ ><a href="#design-and-implementation"+ ><span class="toc-section-number"+ >3</span+ > Design and Implementation</a+ ><ul+ ><li+ ><a href="#proof-of-the-monad-laws-sketch"+ ><span class="toc-section-number"+ >3.1</span+ > Proof of the monad laws (Sketch)</a+ ></li+ ><li+ ><a href="#monad-transformers-1"+ ><span class="toc-section-number"+ >3.2</span+ > Monad Transformers</a+ ></li+ ></ul+ ></li+ ><li+ ><a href="#other-design-choices"+ ><span class="toc-section-number"+ >4</span+ > Other Design Choices</a+ ><ul+ ><li+ ><a href="#recursive-type-definitions-with-Program"+ ><span class="toc-section-number"+ >4.1</span+ > Recursive type definitions with <code+ >Program</code+ ></a+ ></li+ ></ul+ ></li+ ></ul+ ></div+>+<!-- *The HTML version of this document is generated automatically from the corresponding markdown file, don't change it!* -->+<div id="introduction"+><h1+ ><a href="#TOC"+ ><span class="header-section-number"+ >1</span+ > Introduction</a+ ></h1+ ><p+ >This package is based on <a href="http://themonadreader.wordpress.com/2010/01/26/issue-15/"+ >"The Operational Monad Tutorial"</a+ > and this documentation describes its extension to a production-quality library. In other words, the "magic" gap between relevant paper and library implementation is documented here.</p+ ><p+ >Take note that this this library is only ~50 lines of code, yet the documentation even includes a proof! :-)</p+ ><p+ >Sources and inspiration for this library include <a href="http://web.cecs.pdx.edu/~cklin/papers/unimo-143.pdf" title="Chuan-kai Lin. Programming Monads Operationally with Unimo."+ >Chuan-kai Lin's unimo paper</a+ >, <a href="http://citeseer.ist.psu.edu/hughes95design.html" title="John Hughes. The Design of a Pretty-printing Library."+ >John Hughes 95</a+ >, and <a href="http://hackage.haskell.org/package/MonadPrompt" title="Ryan Ingram's Monad Prompt Package."+ >Ryan Ingram's <code+ >MonadPrompt</code+ > package</a+ >.</p+ ></div+><div id="using-this-library"+><h1+ ><a href="#TOC"+ ><span class="header-section-number"+ >2</span+ > Using this Library</a+ ></h1+ ><p+ >To understand what's going on, you'll have to read <a href="http://themonadreader.wordpress.com/2010/01/26/issue-15/"+ >"The Operational Monad Tutorial"</a+ >. Here, I will first and foremost note the changes with respect to the tutorial.</p+ ><p+ >Several advanced <a href="./examples.html"+ >example monads</a+ > demonstrate how to put this library to good use. In the source distribution, the corresponding source files can also be found in the <code+ >.docs/examples</code+ > folder.</p+ ><div id="changes-to-the-Program-type"+ ><h2+ ><a href="#TOC"+ ><span class="header-section-number"+ >2.1</span+ > Changes to the <code+ >Program</code+ > type</a+ ></h2+ ><p+ >For efficiency reasons, the type <code+ >Program</code+ > representing a list of instructions is now <em+ >abstract</em+ >. A function <code+ >view</code+ > is used to inspect the first instruction, it returns a type</p+ ><pre+ ><code+ >data ProgramView instr a where+ Return :: a -> ProgramView instr a+ (:>>=) :: instr a -> (a -> Program instr b) -> ProgramView instr b+</code+ ></pre+ ><p+ >which is much like the old <code+ >Program</code+ > type, except that <code+ >Then</code+ > was renamed to <code+ >:>>=</code+ > and that the subsequent instructions stored in the second argument of <code+ >:>>=</code+ > are stored in the type <code+ >Program</code+ >, not <code+ >ProgramView</code+ >.</p+ ><p+ >To see an example of the new style, here the interpreter for the stack machine from the tutorial:</p+ ><pre+ ><code+ >interpret :: StackProgram a -> (Stack Int -> a)+interpret = eval . view+ where+ eval :: ProgramView StackInstruction a -> (Stack Int -> a)+ eval (Push a :>>= is) stack = interpret (is ()) (a:stack)+ eval (Pop :>>= is) (a:stack) = interpret (is a ) stack+ eval (Return a) stack = a+</code+ ></pre+ ><p+ >So-called "view functions" like <code+ >view</code+ > are a common way of inspecting data structures that have been made abstract for reasons of efficiency; see for example <code+ >viewL</code+ > and <code+ >viewR</code+ > in <a href="http://hackage.haskell.org/package/containers-0.3.0.0"+ ><code+ >Data.Sequence</code+ ></a+ >.</p+ ></div+ ><div id="efficiency"+ ><h2+ ><a href="#TOC"+ ><span class="header-section-number"+ >2.2</span+ > Efficiency</a+ ></h2+ ><p+ >Compared to the original type from the tutorial, <code+ >Program</code+ > now supports <code+ >>>=</code+ > in O(1) time in most use cases. This means that left-biased nesting like</p+ ><pre+ ><code+ >let+ nestLeft :: Int -> StackProgram Int+ nestLeft 0 = return 0+ nestLeft n = nestLeft (n-1) >>= push+in+ interpret (nestLeft n) []+</code+ ></pre+ ><p+ >will now take O(n) time. In contrast, the old <code+ >Program</code+ > type from the tutorial would have taken O(n^2) time, similar to <code+ >++</code+ > for lists taking quadratic time in when nested to the left.</p+ ><p+ >However, this does <em+ >not</em+ > hold in a <em+ >persistent</em+ > setting. In particular, the example</p+ ><pre+ ><code+ >let+ p = nestLeft n+ v1 = view p+ v2 = view p+ v3 = view p+in+ v1 `seq` v2 `seq` v3+</code+ ></pre+ ><p+ >will take O(n) time for each call of <code+ >view</code+ > instead of O(n) the first time and O(1) for the other calls. But since monads are usually used ephemerally, this is much less a restriction than it would be for lists and <code+ >++</code+ >.</p+ ></div+ ><div id="monad-transformers"+ ><h2+ ><a href="#TOC"+ ><span class="header-section-number"+ >2.3</span+ > Monad Transformers</a+ ></h2+ ><p+ >Furthermore, <code+ >Program</code+ > is actually a type synonym and expressed in terms of a monad transformer <code+ >ProgramT</code+ ></p+ ><pre+ ><code+ >type Program instr a = ProgramT instr Identity a+</code+ ></pre+ ><p+ >Likewise, <code+ >view</code+ > is a specialization of <code+ >viewT</code+ > to the identity monad. This change is transparent (except for error messages on type errors) for users who are happy with just <code+ >Program</code+ > but very convenient for those users who want to use it as a monad transformer.</p+ ><p+ >The key point about the transformer version <code+ >ProgramT</code+ > is that in addition to the monad laws, it automatically satisfies the lifting laws for monad transformers as well</p+ ><pre+ ><code+ >lift . return = return+lift m >>= lift . g = lift (m >>= g)+</code+ ></pre+ ><p+ >The corresponding view function <code+ >viewT</code+ > now returns the type <code+ >m (ViewT instr m a)</code+ >. It's not immediately apparent why this return type will do, but it's straightforward to work with, like in the following implementation of the list monad transformer:</p+ ><pre+ ><code+ >data PlusI m a where+ Zero :: PlusI m a+ Plus :: ListT m a -> ListT m a -> PlusI m a++type ListT m a = ProgramT (PlusI m) m a++runList :: Monad m => ListT m a -> m [a]+runList = eval <=< viewT+ where+ eval :: Monad m => ProgramViewT (PlusI m) m a -> m [a]+ eval (Return x) = return [x]+ eval (Zero :>>= k) = return []+ eval (Plus m n :>>= k) =+ liftM2 (++) (runList (m >>= k)) (runList (n >>= k))+</code+ ></pre+ ></div+ ><div id="alternatives-to-monad-transformers"+ ><h2+ ><a href="#TOC"+ ><span class="header-section-number"+ >2.4</span+ > Alternatives to Monad Transformers</a+ ></h2+ ><p+ >By the way, note that monad transformers are not the only way to build larger monads from smaller ones; a similar effect can be achieved with the direct sum of instructions sets. For instance, the monad</p+ ><pre+ ><code+ >Program (StateI s :+: ExceptionI e) a++data (f :+: g) a = Inl (f a) | Inr (g a) -- a fancy Either+</code+ ></pre+ ><p+ >is a combination of the state monad</p+ ><pre+ ><code+ >type State a = Program (StateI s) a++data StateI s a where+ Put :: s -> StateI s ()+ Get :: StateI s s+</code+ ></pre+ ><p+ >and the error monad</p+ ><pre+ ><code+ >type Error e a = Program (ErrorI e) a++data ErrorI e a where+ Throw :: e -> ErrorI e ()+ Catch :: ErrorI e a -> (e -> ErrorI e a) -> ErrorI e a+</code+ ></pre+ ><p+ >The "sum of signatures" approach and the <code+ >(:+:)</code+ > type constructor are advocated in <a href="http://www.cse.chalmers.se/~wouter/Publications/DataTypesALaCarte.pdf" title="Wouter Swierstra. Data types � la carte."+ >Wouter Swierstra's "Data Types a la carte"</a+ >. Time will tell which has more merit; for now I have opted for a seamless interaction with monad transformers.</p+ ></div+ ></div+><div id="design-and-implementation"+><h1+ ><a href="#TOC"+ ><span class="header-section-number"+ >3</span+ > Design and Implementation</a+ ></h1+ ><div id="proof-of-the-monad-laws-sketch"+ ><h2+ ><a href="#TOC"+ ><span class="header-section-number"+ >3.1</span+ > Proof of the monad laws (Sketch)</a+ ></h2+ ><p+ >The key point of this library is of course that the <code+ >view</code+ > and <code+ >viewT</code+ > functions respect the monad laws. While this seems obvious from the definition, the proof is actually not straightforward.</p+ ><p+ >First, we restrict ourselves to <code+ >view</code+ >, i.e. the version without monad transformers. In fact, I don't have a full proof for the version with monad transformers, more about that in the next section.</p+ ><p+ >Second, we use a sloppy, but much more suitable notation, namely we write</p+ ><table+ ><tr class="header"+ ><th align="left"+ ></th+ ><th align="center"+ ></th+ ></tr+ ><tr class="odd"+ ><td align="left"+ ><code+ >>>=</code+ ></td+ ><td align="center"+ >instead of <code+ >Bind</code+ ></td+ ></tr+ ><tr class="even"+ ><td align="left"+ ><code+ >return</code+ ></td+ ><td align="center"+ >instead of <code+ >Lift</code+ > for the identity monad</td+ ></tr+ ><tr class="odd"+ ><td align="left"+ ><code+ >i,j,k,</code+ >...</td+ ><td align="center"+ >for primitive instructions</td+ ></tr+ ></table+ ><p+ >Then, the <code+ >view</code+ > function becomes</p+ ><pre+ ><code+ >view (return a) = Return a+view (return a >>= g) = g a -- left unit+view ((m >>= f) >>= g) = view (m >>= (\x -> f x >>= g) -- associativity+view (i >>= g) = i :>>= g+view i = i :>>= return -- right unit+</code+ ></pre+ ><p+ >Clearly, <code+ >view</code+ > uses the monad laws to rewrite it's argument. But we want to show that whenever two expressions</p+ ><pre+ ><code+ >e1,e2 :: Program instr a+</code+ ></pre+ ><p+ >can be transformed into each other by rewriting them with the monad laws in <em+ >any</em+ > fashion (remember that <code+ >>>=</code+ > and <code+ >return</code+ > are constructors), then <code+ >view</code+ > will map them to the same result. More formally, we have an equivalence relation</p+ ><pre+ ><code+ >e1 ~ e2 iff e1 and e2 are the same modulo monad laws+</code+ ></pre+ ><p+ >and want to show</p+ ><pre+ ><code+ >e1 ~ e2 => view e1 = view e2 (some notion of equality)+</code+ ></pre+ ><p+ >Now, this needs proof because <code+ >view</code+ > is like a term rewriting system and there is no guarantee that two equivalent terms will be rewritten to the same normal form.</p+ ><p+ >Trying to attack this problem with term rewriting and critical pairs is probably hopeless and not very enlightening. After all, the theorem should be obvious because two equivalent expressions should have the same <em+ >first instruction</em+ > <code+ >i</code+ >. Well, we can formalize this with the help of a <em+ >normal form</em+ ></p+ ><pre+ ><code+ >data NF instr a where+ Return' :: a -> NF instr a+ (:>>=') :: instr a -> (a -> NF instr b) -> NF instr b+</code+ ></pre+ ><p+ >This is the old program type and the key observation is that <code+ >NF instr</code+ > is already a monad.</p+ ><pre+ ><code+ >instance Monad (NF inst) where+ (Return' a) >>= g = g a+ (m :>>=' f) >>= g = m :>>= (\x -> f x >>= g)+</code+ ></pre+ ><p+ >(I'll skip the short calculation and coinduction argument that this really fulfills the monad laws.) We can define a normalization function</p+ ><pre+ ><code+ >normalize :: Program instr a -> NF instr a+normalize (m >>= g) = normalize m >>=' normalize g+normalize (return a) = Return' a+normalize i = i :>>=' Return'+</code+ ></pre+ ><p+ >which has the now obvious property that</p+ ><pre+ ><code+ >e1 ~ e2 => normalize e1 = normalize e2+</code+ ></pre+ ><p+ >Now, the return type of <code+ >view</code+ > is akin to a <em+ >head normal form</em+ >, hence</p+ ><pre+ ><code+ > normalize (view e1) = normalize (view e2) +=> view e1 = view e2+</code+ ></pre+ ><p+ >(for some suitable extension of <code+ >normalize</code+ > to the <code+ >ProgramView</code+ > type.) But since <code+ >view</code+ > only uses monad laws to rewrite its argument, we also have</p+ ><pre+ ><code+ >e1 ~ view e1 => normalize e1 = normalize (view e1)+</code+ ></pre+ ><p+ >and this concludes the proof, which pretty much only showed that two equivalent expressions have the same instruction list and hence <code+ >view</code+ > gives equal results.</p+ ></div+ ><div id="monad-transformers-1"+ ><h2+ ><a href="#TOC"+ ><span class="header-section-number"+ >3.2</span+ > Monad Transformers</a+ ></h2+ ><p+ >The monad transformer case is more hairy, I have no proof here. (If you read this by accident: don't worry, it's still correct. This is for proof nerds only.)</p+ ><p+ >The main difficulty is that the equation</p+ ><pre+ ><code+ >return = lift . return+</code+ ></pre+ ><p+ >is an equation for the already existing <code+ >return</code+ > constructor and the notion of "first instruction" no longer applies. Namely, we have</p+ ><pre+ ><code+ >m = return m >>= id = lift (return m) >>= id+</code+ ></pre+ ><p+ >and it's not longer clear what a suitable normal form might be. It appears that <code+ >viewT</code+ > rewrites the term as follows</p+ ><pre+ ><code+ > lift m >>= g+= lift m >>= (\x -> lift (return (g x)) >>= id)+= (lift m >>= lift . return . g) >>= id+= lift (m >>= return . g) >>= id+</code+ ></pre+ ><p+ >(To be continued.)</p+ ></div+ ></div+><div id="other-design-choices"+><h1+ ><a href="#TOC"+ ><span class="header-section-number"+ >4</span+ > Other Design Choices</a+ ></h1+ ><div id="recursive-type-definitions-with-Program"+ ><h2+ ><a href="#TOC"+ ><span class="header-section-number"+ >4.1</span+ > Recursive type definitions with <code+ >Program</code+ ></a+ ></h2+ ><p+ >In the <a href="http://web.cecs.pdx.edu/~cklin/papers/unimo-143.pdf" title="Chuan-kai Lin. Programming Monads Operationally with Unimo."+ >unimo paper</a+ >, the instructions carry an additional parameter that "unties" recursive type definition. For example, the instructions for <code+ >MonadPlus</code+ > are written</p+ ><pre+ ><code+ >data PlusI unimo a where+ Zero :: PlusI unimo a+ Plus :: unimo a -> unimo a -> PlusI unimo a+</code+ ></pre+ ><p+ >The type constructor variable <code+ >unimo</code+ > will be tied to <code+ >Unimo PlusI</code+ >.</p+ ><p+ >In this library, I have opted for the conceptually simpler approach that requires the user to tie the recursion himself</p+ ><pre+ ><code+ >data PlusI a where+ Zero :: PlusI a+ Plus :: Program PlusI a -> Program PlusI a -> Plus I a+</code+ ></pre+ ><p+ >I am not sure whether this has major consequences for composeablity; at the moment I believe that the former style can always be recovered from an implementation in the latter style.</p+ ></div+ ></div+>+</body>+</html>+
+ docs/web/examples.html view
@@ -0,0 +1,26 @@+<html><head><title>The 'operational' package - Example Code</title></head>+<body>+<h1>Example Code</h1>+for the <a href="http://projects.haskell.org/operational/">operational</a> package.++<h2>List of examples</h2>++<dl>+<dt><a href="examples/LogicT.hs.html">LogicT.hs</a>+ <dd>Oleg Kiselyov's <code>LogicT</code> monad transformer.+<dt><a href="examples/ListT.hs.html">ListT.hs</a>+ <dd>Correct implementation of the list monad transformer.+<dt><a href="examples/PoorMansConcurrency.hs.html">PoorMansConcurrency.hs</a>+ <dd>Koen Claessen's poor man's concurrency monad, implements cooperative multitasking.+<dt><a href="examples/State.hs.html">State.hs</a>+ <dd>Very simple example showing how to implement the state monad.+<dt><a href="examples/TicTacToe.hs.html">TicTacToe.hs</a>+ <dd>The game of TicTacToe. Mix and mash humans and AI as you like; players are implemented in a special monad that looks like there is only one player playing.+<dt><a href="examples/WebSessionState.lhs.html">WebSessionState.lhs</a>+ <dd>CGI Script that is written in a style seems to require exeution in a persistent process, but actually stores a log of the session in the client.+</dl>++<h2>Download</h2>+Download a <a href="examples/operational-examples.tar.gz">tar.gz archive</a> of all the current examples.++</body></html>
+ docs/web/examples/ListT.hs.html view
@@ -0,0 +1,66 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html>+<head>+<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->+<title>examples/ListT.hs</title>+<link type='text/css' rel='stylesheet' href='hscolour.css' />+</head>+<body>+<pre><span class='hs-comment'>{------------------------------------------------------------------------------+ Control.Monad.Operational+ + Example:+ List Monad Transformer++------------------------------------------------------------------------------}</span>+<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types, FlexibleInstances #-}</span>+<span class='hs-keyword'>module</span> <span class='hs-conid'>ListT</span> <span class='hs-keyword'>where</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ A direct implementation+ type ListT m a = m [a]+ would violate the monad laws, but we don't have that problem.+------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>data</span> <span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>+ <span class='hs-conid'>MZero</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>+ <span class='hs-conid'>MPlus</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ListT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ListT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>++<span class='hs-keyword'>type</span> <span class='hs-conid'>ListT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ProgramT</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>++ <span class='hs-comment'>-- *sigh* I want to use type synonyms for type constructors, too;</span>+ <span class='hs-comment'>-- GHC doesn't accept MonadMPlus (ListT m)</span>+<span class='hs-keyword'>instance</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>MonadPlus</span> <span class='hs-layout'>(</span><span class='hs-conid'>ProgramT</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>+ <span class='hs-varid'>mzero</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-conid'>MZero</span>+ <span class='hs-varid'>mplus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>n</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span>++<span class='hs-definition'>runListT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ListT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>+<span class='hs-definition'>runListT</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval</span> <span class='hs-varop'><=<</span> <span class='hs-varid'>viewT</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ProgramViewT</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>MZero</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>[]</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>n</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span>+ <span class='hs-varid'>liftM2</span> <span class='hs-layout'>(</span><span class='hs-varop'>++</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>runListT</span> <span class='hs-layout'>(</span><span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>runListT</span> <span class='hs-layout'>(</span><span class='hs-varid'>n</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>++<span class='hs-definition'>testListT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>IO</span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>()</span><span class='hs-keyglyph'>]</span>+<span class='hs-definition'>testListT</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runListT</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>n</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>choice</span> <span class='hs-keyglyph'>[</span><span class='hs-num'>1</span><span class='hs-keyglyph'>..</span><span class='hs-num'>5</span><span class='hs-keyglyph'>]</span>+ <span class='hs-varid'>lift</span> <span class='hs-varop'>.</span> <span class='hs-varid'>print</span> <span class='hs-varop'>$</span> <span class='hs-str'>"You've chosen the number: "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-varid'>n</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>choice</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>foldr1</span> <span class='hs-varid'>mplus</span> <span class='hs-varop'>.</span> <span class='hs-varid'>map</span> <span class='hs-varid'>return</span>+++ <span class='hs-comment'>-- testing the monad laws, from the Haskellwiki</span>+ <span class='hs-comment'>-- <a href="http://www.haskell.org/haskellwiki/ListT_done_right#Order_of_printing">http://www.haskell.org/haskellwiki/ListT_done_right#Order_of_printing</a></span>+<span class='hs-definition'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>b</span><span class='hs-layout'>,</span><span class='hs-varid'>c</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ListT</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>+<span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>b</span><span class='hs-layout'>,</span><span class='hs-varid'>c</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>lift</span> <span class='hs-varop'>.</span> <span class='hs-varid'>putChar</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-chr'>'a'</span><span class='hs-layout'>,</span><span class='hs-chr'>'b'</span><span class='hs-layout'>,</span><span class='hs-chr'>'c'</span><span class='hs-keyglyph'>]</span>++ <span class='hs-comment'>-- t1 and t2 have to print the same sequence of letters</span>+<span class='hs-definition'>t1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runListT</span> <span class='hs-varop'>$</span> <span class='hs-layout'>(</span><span class='hs-layout'>(</span><span class='hs-varid'>a</span> <span class='hs-varop'>`mplus`</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varop'>>></span> <span class='hs-varid'>b</span><span class='hs-layout'>)</span> <span class='hs-varop'>>></span> <span class='hs-varid'>c</span>+<span class='hs-definition'>t2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runListT</span> <span class='hs-varop'>$</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span> <span class='hs-varop'>`mplus`</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span> <span class='hs-varop'>>></span> <span class='hs-layout'>(</span><span class='hs-varid'>b</span> <span class='hs-varop'>>></span> <span class='hs-varid'>c</span><span class='hs-layout'>)</span>+</pre></body>+</html>
+ docs/web/examples/LogicT.hs.html view
@@ -0,0 +1,96 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html>+<head>+<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->+<title>examples/LogicT.hs</title>+<link type='text/css' rel='stylesheet' href='hscolour.css' />+</head>+<body>+<pre><span class='hs-comment'>{------------------------------------------------------------------------------+ Control.Monad.Operational+ + Example:+ Oleg's LogicT monad transformer+ + Functions to implement are taken from the corresponding paper+ <a href="http://okmij.org/ftp/papers/LogicT.pdf">http://okmij.org/ftp/papers/LogicT.pdf</a>+ +------------------------------------------------------------------------------}</span>+<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types #-}</span>+<span class='hs-keyword'>module</span> <span class='hs-conid'>LogicT</span> <span class='hs-layout'>(</span><span class='hs-conid'>LogicT</span><span class='hs-layout'>,</span> <span class='hs-varid'>msplit</span><span class='hs-layout'>,</span> <span class='hs-varid'>observe</span><span class='hs-layout'>,</span> <span class='hs-varid'>bagOfN</span><span class='hs-layout'>,</span> <span class='hs-varid'>interleave</span><span class='hs-layout'>)</span> <span class='hs-keyword'>where</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Maybe</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ LogicT+ = A MonadPlus with an additional operation+ msplit+ which returns the first result and a computation to + produce the remaining results.+++ For example, the function msplit satisfies the laws+ + msplit mzero ~> return Nothing+ msplit (return a `mplus` m) ~> return (Just (a,m))+ + It turns out that we don't have to make msplit a primitive,+ we can implement it by inspection on the argument. In other+ words, LogicT will be the same as the ListT monad transformer+------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>ListT</span>+<span class='hs-keyword'>type</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ListT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>++ <span class='hs-comment'>-- msplit is the lift of a function split in the base monad</span>+<span class='hs-definition'>msplit</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>+<span class='hs-definition'>msplit</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lift</span> <span class='hs-varop'>.</span> <span class='hs-varid'>split</span>++ <span class='hs-comment'>-- split in the base monad</span>+<span class='hs-definition'>split</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>+<span class='hs-definition'>split</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval</span> <span class='hs-varop'><=<</span> <span class='hs-varid'>viewT</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-comment'>-- apply the laws for msplit</span>+ <span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ProgramViewT</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-layout'>(</span><span class='hs-conid'>Maybe</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>MZero</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>Nothing</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>MPlus</span> <span class='hs-varid'>m</span> <span class='hs-varid'>n</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>ma</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>split</span> <span class='hs-layout'>(</span><span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span>+ <span class='hs-keyword'>case</span> <span class='hs-varid'>ma</span> <span class='hs-keyword'>of</span>+ <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>split</span> <span class='hs-layout'>(</span><span class='hs-varid'>n</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span>+ <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>m'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span> <span class='hs-varid'>m'</span> <span class='hs-varop'>`mplus`</span> <span class='hs-layout'>(</span><span class='hs-varid'>n</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>+ <span class='hs-comment'>-- inefficient!</span>+ <span class='hs-comment'>-- `mplus` will add another (>>= return)</span>+ <span class='hs-comment'>-- to n each time it's called.</span>+ <span class='hs-comment'>-- Curing this is not easy.</span>++ <span class='hs-comment'>-- main interpreter, section 6 in the paper</span>+ <span class='hs-comment'>-- returns the first result, if any; may fail</span>+<span class='hs-definition'>observe</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>+<span class='hs-definition'>observe</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>fst</span> <span class='hs-varop'>.</span> <span class='hs-varid'>fromJust</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>split</span> <span class='hs-varid'>m</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ Derived functions from the paper+------------------------------------------------------------------------------}</span>+ <span class='hs-comment'>-- return the first n results, section 6</span>+<span class='hs-definition'>bagOfN</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span>+<span class='hs-definition'>bagOfN</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>n</span> <span class='hs-varop'><=</span> <span class='hs-num'>0</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>[]</span>+<span class='hs-definition'>bagOfN</span> <span class='hs-varid'>n</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>msplit</span> <span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>bagofN'</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>bagofN'</span> <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>[]</span>+ <span class='hs-varid'>bagofN'</span> <span class='hs-layout'>(</span><span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-layout'>,</span><span class='hs-varid'>m'</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-conop'>:</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>bagOfN</span> <span class='hs-layout'>(</span><span class='hs-varid'>fmap</span> <span class='hs-varid'>pred</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span> <span class='hs-varid'>m'</span>+ <span class='hs-keyword'>where</span> <span class='hs-varid'>pred</span> <span class='hs-varid'>n</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>n</span><span class='hs-comment'>-</span><span class='hs-num'>1</span>++ <span class='hs-comment'>-- interleave</span>+<span class='hs-definition'>interleave</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>LogicT</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>+<span class='hs-definition'>interleave</span> <span class='hs-varid'>m1</span> <span class='hs-varid'>m2</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>r</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>msplit</span> <span class='hs-varid'>m1</span>+ <span class='hs-keyword'>case</span> <span class='hs-varid'>r</span> <span class='hs-keyword'>of</span>+ <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m2</span>+ <span class='hs-conid'>Just</span> <span class='hs-layout'>(</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>m1'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>a</span> <span class='hs-varop'>`mplus`</span> <span class='hs-varid'>interleave</span> <span class='hs-varid'>m2</span> <span class='hs-varid'>m1'</span>+++</pre></body>+</html>
+ docs/web/examples/PoorMansConcurrency.hs.html view
@@ -0,0 +1,73 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html>+<head>+<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->+<title>examples/PoorMansConcurrency.hs</title>+<link type='text/css' rel='stylesheet' href='hscolour.css' />+</head>+<body>+<pre><span class='hs-comment'>{------------------------------------------------------------------------------+ Control.Monad.Operational+ + Example:+ Koen Claessen's Poor Man's Concurrency Monad+ <a href="http://www.cs.chalmers.se/~koen/pubs/entry-jfp99-monad.html">http://www.cs.chalmers.se/~koen/pubs/entry-jfp99-monad.html</a>++------------------------------------------------------------------------------}</span>+<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types #-}</span>+<span class='hs-keyword'>module</span> <span class='hs-conid'>PoorMansConcurrency</span> <span class='hs-keyword'>where</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span><span class='hs-varid'>lift</span><span class='hs-layout'>)</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ A concurrency monad runs several processes in parallel+ and supports two operations++ fork -- fork a new process+ stop -- halt the current one+ + We want this to be a monad transformer, so we also need a function lift+ This time, however, we cannot use the monad transformer version ProgramT+ because this will leave no room for interleaving different computations+ of the base monad.+------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>data</span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>+ <span class='hs-conid'>Lift</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>+ <span class='hs-conid'>Stop</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>+ <span class='hs-conid'>Fork</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>+++<span class='hs-keyword'>type</span> <span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Program</span> <span class='hs-layout'>(</span><span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span>++<span class='hs-definition'>stop</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-conid'>Stop</span>+<span class='hs-definition'>fork</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Fork</span>+<span class='hs-definition'>lift</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Lift</span>++ <span class='hs-comment'>-- interpreter</span>+<span class='hs-definition'>runProcess</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>+<span class='hs-definition'>runProcess</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>schedule</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>m</span><span class='hs-keyglyph'>]</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>schedule</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-conop'>:</span><span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-varid'>view</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span>++ <span class='hs-varid'>run</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ProgramView</span> <span class='hs-layout'>(</span><span class='hs-conid'>ProcessI</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Process</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>+ <span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span> <span class='hs-comment'>-- process finished</span>+ <span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Lift</span> <span class='hs-varid'>m</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-comment'>-- switch process</span>+ <span class='hs-varid'>schedule</span> <span class='hs-layout'>(</span><span class='hs-varid'>xs</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>k</span> <span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span>+ <span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Stop</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>schedule</span> <span class='hs-varid'>xs</span> <span class='hs-comment'>-- process halts</span>+ <span class='hs-varid'>run</span> <span class='hs-layout'>(</span><span class='hs-conid'>Fork</span> <span class='hs-varid'>p</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>schedule</span> <span class='hs-layout'>(</span><span class='hs-varid'>xs</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x2</span><span class='hs-layout'>,</span><span class='hs-varid'>x1</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- fork new process</span>+ <span class='hs-keyword'>where</span> <span class='hs-varid'>x1</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>k</span> <span class='hs-conid'>()</span><span class='hs-layout'>;</span> <span class='hs-varid'>x2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>p</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>k</span>++ <span class='hs-comment'>-- example</span>+ <span class='hs-comment'>-- > runProcess example -- warning: runs indefinitely</span>+<span class='hs-definition'>example</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Process</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>+<span class='hs-definition'>example</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>write</span> <span class='hs-str'>"Start!"</span>+ <span class='hs-varid'>fork</span> <span class='hs-layout'>(</span><span class='hs-varid'>loop</span> <span class='hs-str'>"fish"</span><span class='hs-layout'>)</span>+ <span class='hs-varid'>loop</span> <span class='hs-str'>"cat"</span>++<span class='hs-definition'>write</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>lift</span> <span class='hs-varop'>.</span> <span class='hs-varid'>putStr</span>+<span class='hs-definition'>loop</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>write</span> <span class='hs-varid'>s</span> <span class='hs-varop'>>></span> <span class='hs-varid'>loop</span> <span class='hs-varid'>s</span>+</pre></body>+</html>
+ docs/web/examples/State.hs.html view
@@ -0,0 +1,70 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html>+<head>+<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->+<title>examples/State.hs</title>+<link type='text/css' rel='stylesheet' href='hscolour.css' />+</head>+<body>+<pre><span class='hs-comment'>{------------------------------------------------------------------------------+ Control.Monad.Operational+ + Example:+ State monad and monad transformer+ +------------------------------------------------------------------------------}</span>+<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types, FlexibleInstances #-}</span>+<span class='hs-keyword'>module</span> <span class='hs-conid'>State</span> <span class='hs-keyword'>where</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ State Monad+------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>data</span> <span class='hs-conid'>StateI</span> <span class='hs-varid'>s</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>+ <span class='hs-conid'>Get</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>StateI</span> <span class='hs-varid'>s</span> <span class='hs-varid'>s</span>+ <span class='hs-conid'>Put</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>StateI</span> <span class='hs-varid'>s</span> <span class='hs-conid'>()</span>++<span class='hs-keyword'>type</span> <span class='hs-conid'>State</span> <span class='hs-varid'>s</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Program</span> <span class='hs-layout'>(</span><span class='hs-conid'>StateI</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span>++<span class='hs-definition'>evalState</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>State</span> <span class='hs-varid'>s</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span>+<span class='hs-definition'>evalState</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval</span> <span class='hs-varop'>.</span> <span class='hs-varid'>view</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ProgramView</span> <span class='hs-layout'>(</span><span class='hs-conid'>StateI</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>const</span> <span class='hs-varid'>x</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Get</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>evalState</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varid'>s</span> <span class='hs-layout'>)</span> <span class='hs-varid'>s</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Put</span> <span class='hs-varid'>s</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>evalState</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>++<span class='hs-definition'>put</span> <span class='hs-keyglyph'>::</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>StateT</span> <span class='hs-varid'>s</span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>+<span class='hs-definition'>put</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Put</span>++<span class='hs-definition'>get</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>StateT</span> <span class='hs-varid'>s</span> <span class='hs-varid'>m</span> <span class='hs-varid'>s</span>+<span class='hs-definition'>get</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-conid'>Get</span>++<span class='hs-definition'>testState</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Int</span>+<span class='hs-definition'>testState</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>evalState</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>x</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get</span>+ <span class='hs-varid'>put</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-varop'>+</span><span class='hs-num'>2</span><span class='hs-layout'>)</span>+ <span class='hs-varid'>get</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ State Monad Transformer+------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>type</span> <span class='hs-conid'>StateT</span> <span class='hs-varid'>s</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ProgramT</span> <span class='hs-layout'>(</span><span class='hs-conid'>StateI</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>++<span class='hs-definition'>evalStateT</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>StateT</span> <span class='hs-varid'>s</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>+<span class='hs-definition'>evalStateT</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>viewT</span> <span class='hs-varid'>m</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>p</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>eval</span> <span class='hs-varid'>p</span> <span class='hs-varid'>s</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>ProgramViewT</span> <span class='hs-layout'>(</span><span class='hs-conid'>StateI</span> <span class='hs-varid'>s</span><span class='hs-layout'>)</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span><span class='hs-layout'>)</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-varid'>x</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>return</span> <span class='hs-varid'>x</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Get</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>s</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>evalStateT</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varid'>s</span> <span class='hs-layout'>)</span> <span class='hs-varid'>s</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Put</span> <span class='hs-varid'>s</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>\</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>evalStateT</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-conid'>()</span><span class='hs-layout'>)</span> <span class='hs-varid'>s</span>++<span class='hs-definition'>testStateT</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>evalStateT</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>x</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get</span>+ <span class='hs-varid'>lift</span> <span class='hs-varop'>$</span> <span class='hs-varid'>putStrLn</span> <span class='hs-str'>"Hello StateT"</span>+ <span class='hs-varid'>put</span> <span class='hs-layout'>(</span><span class='hs-varid'>x</span><span class='hs-varop'>+</span><span class='hs-num'>1</span><span class='hs-layout'>)</span>+</pre></body>+</html>
+ docs/web/examples/TicTacToe.hs.html view
@@ -0,0 +1,186 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html>+<head>+<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->+<title>examples/TicTacToe.hs</title>+<link type='text/css' rel='stylesheet' href='hscolour.css' />+</head>+<body>+<pre><span class='hs-comment'>{------------------------------------------------------------------------------+ Control.Monad.Operational+ + Example:+ An implementation of the game TicTacToe.+ + Each player (human, AI, ...) is implemented in a separate monad+ which are then intermingled to run the game. This resembles the+ PoorMansConcurrency.hs example.+ + + Many thanks to Yves Pars and Bertram Felgenhauer+ <a href="http://www.haskell.org/pipermail/haskell-cafe/2010-April/076216.html">http://www.haskell.org/pipermail/haskell-cafe/2010-April/076216.html</a>++------------------------------------------------------------------------------}</span>+<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types #-}</span>+<span class='hs-keyword'>module</span> <span class='hs-conid'>TicTacToe</span> <span class='hs-keyword'>where</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>State</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Either</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>List</span>++ <span class='hs-comment'>-- external libraries needed</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>System</span><span class='hs-varop'>.</span><span class='hs-conid'>Random</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ The Player monad for implementing players (human, AI, ...)+ provides two operations+ + readBoard -- read the current board position+ playMove -- play a move++ to query the current board position and perform a move, respectively.+ + Moreover, it's actually a monad transformer intended to be used over IO.+ This way, the players can perform IO computations.+------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>data</span> <span class='hs-conid'>PlayerI</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>+ <span class='hs-conid'>ReadBoard</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>PlayerI</span> <span class='hs-conid'>Board</span>+ <span class='hs-conid'>PlayMove</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>PlayerI</span> <span class='hs-conid'>Bool</span>+ +<span class='hs-keyword'>type</span> <span class='hs-conid'>Player</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>ProgramT</span> <span class='hs-conid'>PlayerI</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>++<span class='hs-definition'>readBoard</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-conid'>ReadBoard</span>+<span class='hs-definition'>playMove</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>PlayMove</span>++ <span class='hs-comment'>-- interpreter</span>+<span class='hs-definition'>runGame</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Player</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Player</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>+<span class='hs-definition'>runGame</span> <span class='hs-varid'>player1</span> <span class='hs-varid'>player2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval'</span> <span class='hs-varid'>initialGameState</span> <span class='hs-varid'>player1</span> <span class='hs-varid'>player2</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>eval'</span> <span class='hs-varid'>game</span> <span class='hs-varid'>p1</span> <span class='hs-varid'>p2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>viewT</span> <span class='hs-varid'>p1</span> <span class='hs-varop'>>>=</span> <span class='hs-keyglyph'>\</span><span class='hs-varid'>p1view</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>eval</span> <span class='hs-varid'>game</span> <span class='hs-varid'>p1view</span> <span class='hs-varid'>p2</span>+ + <span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>GameState</span>+ <span class='hs-keyglyph'>-></span> <span class='hs-conid'>ProgramViewT</span> <span class='hs-conid'>PlayerI</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Player</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>+ <span class='hs-keyglyph'>-></span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>+ <span class='hs-varid'>eval</span> <span class='hs-varid'>game</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-conid'>()</span>+ <span class='hs-varid'>eval</span> <span class='hs-varid'>game</span> <span class='hs-layout'>(</span><span class='hs-conid'>ReadBoard</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>p1</span><span class='hs-layout'>)</span> <span class='hs-varid'>p2</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval'</span> <span class='hs-varid'>game</span> <span class='hs-layout'>(</span><span class='hs-varid'>p1</span> <span class='hs-layout'>(</span><span class='hs-varid'>board</span> <span class='hs-varid'>game</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varid'>p2</span>+ <span class='hs-varid'>eval</span> <span class='hs-varid'>game</span> <span class='hs-layout'>(</span><span class='hs-conid'>PlayMove</span> <span class='hs-varid'>mv</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>p1</span><span class='hs-layout'>)</span> <span class='hs-varid'>p2</span> <span class='hs-keyglyph'>=</span>+ <span class='hs-keyword'>case</span> <span class='hs-varid'>makeMove</span> <span class='hs-varid'>mv</span> <span class='hs-varid'>game</span> <span class='hs-keyword'>of</span>+ <span class='hs-conid'>Nothing</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>eval'</span> <span class='hs-varid'>game</span> <span class='hs-layout'>(</span><span class='hs-varid'>p1</span> <span class='hs-conid'>False</span><span class='hs-layout'>)</span> <span class='hs-varid'>p2</span>+ <span class='hs-conid'>Just</span> <span class='hs-varid'>game'</span>+ <span class='hs-keyglyph'>|</span> <span class='hs-varid'>won</span> <span class='hs-varid'>game'</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyword'>let</span> <span class='hs-varid'>p</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>activePlayer</span> <span class='hs-varid'>game</span> <span class='hs-keyword'>in</span>+ <span class='hs-varid'>putStrLn</span> <span class='hs-varop'>$</span> <span class='hs-str'>"Player "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-varid'>p</span> <span class='hs-varop'>++</span> <span class='hs-str'>" has won!"</span>+ <span class='hs-keyglyph'>|</span> <span class='hs-varid'>draw</span> <span class='hs-varid'>game'</span><span class='hs-keyglyph'>-></span> <span class='hs-varid'>putStrLn</span> <span class='hs-varop'>$</span> <span class='hs-str'>"It's a draw."</span>+ <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>-></span> <span class='hs-varid'>eval'</span> <span class='hs-varid'>game'</span> <span class='hs-varid'>p2</span> <span class='hs-layout'>(</span><span class='hs-varid'>p1</span> <span class='hs-conid'>True</span><span class='hs-layout'>)</span>+ + <span class='hs-comment'>-- example: human vs AI</span>+<span class='hs-definition'>main</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>g</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>getStdGen</span>+ <span class='hs-varid'>runGame</span> <span class='hs-varid'>playerHuman</span> <span class='hs-layout'>(</span><span class='hs-varid'>playerAI</span> <span class='hs-varid'>g</span><span class='hs-layout'>)</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ TicTacToe Board type and logic+ + The board looks like this:+ + +---+---+---+ some squares already played on+ | 1 | 2 | 3 | the empty squares are numbered+ +---+---+---++ | 4 | 5 |OOO|+ +---+---+---++ | 7 |XXX| 9 |+ +---+---+---++------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>data</span> <span class='hs-conid'>Symbol</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>X</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>O</span> <span class='hs-keyword'>deriving</span> <span class='hs-layout'>(</span><span class='hs-conid'>Eq</span><span class='hs-layout'>,</span><span class='hs-conid'>Show</span><span class='hs-layout'>)</span>+<span class='hs-keyword'>type</span> <span class='hs-conid'>Square</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Either</span> <span class='hs-conid'>Int</span> <span class='hs-conid'>Symbol</span>+<span class='hs-keyword'>type</span> <span class='hs-conid'>Board</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-keyglyph'>[</span><span class='hs-conid'>Square</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span>+<span class='hs-keyword'>data</span> <span class='hs-conid'>GameState</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Game</span> <span class='hs-layout'>{</span> <span class='hs-varid'>board</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Board</span><span class='hs-layout'>,</span> <span class='hs-varid'>activePlayer</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Symbol</span> <span class='hs-layout'>}</span>++<span class='hs-definition'>initialGameState</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>GameState</span>+<span class='hs-definition'>initialGameState</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Game</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-conid'>Left</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>[</span><span class='hs-keyglyph'>[</span><span class='hs-num'>1</span><span class='hs-layout'>,</span><span class='hs-num'>2</span><span class='hs-layout'>,</span><span class='hs-num'>3</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span><span class='hs-keyglyph'>[</span><span class='hs-num'>4</span><span class='hs-layout'>,</span><span class='hs-num'>5</span><span class='hs-layout'>,</span><span class='hs-num'>6</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span><span class='hs-keyglyph'>[</span><span class='hs-num'>7</span><span class='hs-layout'>,</span><span class='hs-num'>8</span><span class='hs-layout'>,</span><span class='hs-num'>9</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span> <span class='hs-conid'>X</span>++ <span class='hs-comment'>-- list the possible moves to play</span>+<span class='hs-definition'>possibleMoves</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Board</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>Int</span><span class='hs-keyglyph'>]</span>+<span class='hs-definition'>possibleMoves</span> <span class='hs-varid'>board</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>k</span> <span class='hs-keyglyph'>|</span> <span class='hs-conid'>Left</span> <span class='hs-varid'>k</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>concat</span> <span class='hs-varid'>board</span><span class='hs-keyglyph'>]</span>++ <span class='hs-comment'>-- play a stone at a square</span>+<span class='hs-definition'>makeMove</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Int</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>GameState</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Maybe</span> <span class='hs-conid'>GameState</span>+<span class='hs-definition'>makeMove</span> <span class='hs-varid'>k</span> <span class='hs-layout'>(</span><span class='hs-conid'>Game</span> <span class='hs-varid'>board</span> <span class='hs-varid'>player</span><span class='hs-layout'>)</span>+ <span class='hs-keyglyph'>|</span> <span class='hs-varid'>not</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varop'>`elem`</span> <span class='hs-varid'>possibleMoves</span> <span class='hs-varid'>board</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Nothing</span> <span class='hs-comment'>-- illegal move</span>+ <span class='hs-keyglyph'>|</span> <span class='hs-varid'>otherwise</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Just</span> <span class='hs-varop'>$</span> <span class='hs-conid'>Game</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>map</span> <span class='hs-varid'>replace</span><span class='hs-layout'>)</span> <span class='hs-varid'>board</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>switch</span> <span class='hs-varid'>player</span><span class='hs-layout'>)</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>replace</span> <span class='hs-layout'>(</span><span class='hs-conid'>Left</span> <span class='hs-varid'>k'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>|</span> <span class='hs-varid'>k'</span> <span class='hs-varop'>==</span> <span class='hs-varid'>k</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Right</span> <span class='hs-varid'>player</span>+ <span class='hs-varid'>replace</span> <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>x</span>++ <span class='hs-varid'>switch</span> <span class='hs-conid'>X</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>O</span>+ <span class='hs-varid'>switch</span> <span class='hs-conid'>O</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>X</span>++ <span class='hs-comment'>-- has somebody won the game?</span>+<span class='hs-definition'>won</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>GameState</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>+<span class='hs-definition'>won</span> <span class='hs-layout'>(</span><span class='hs-conid'>Game</span> <span class='hs-varid'>board</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>any</span> <span class='hs-varid'>full</span> <span class='hs-varop'>$</span> <span class='hs-varid'>diagonals</span> <span class='hs-varid'>board</span> <span class='hs-varop'>++</span> <span class='hs-varid'>rows</span> <span class='hs-varid'>board</span> <span class='hs-varop'>++</span> <span class='hs-varid'>cols</span> <span class='hs-varid'>board</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>full</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-layout'>,</span><span class='hs-varid'>b</span><span class='hs-layout'>,</span><span class='hs-varid'>c</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>a</span> <span class='hs-varop'>==</span> <span class='hs-varid'>b</span> <span class='hs-varop'>&&</span> <span class='hs-varid'>b</span> <span class='hs-varop'>==</span> <span class='hs-varid'>c</span>+ <span class='hs-varid'>diagonals</span> <span class='hs-keyglyph'>[</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>a1</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>b1</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>+ <span class='hs-keyglyph'>[</span><span class='hs-keyword'>_</span> <span class='hs-layout'>,</span><span class='hs-varid'>c</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span> <span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span>+ <span class='hs-keyglyph'>[</span><span class='hs-varid'>b2</span><span class='hs-layout'>,</span><span class='hs-keyword'>_</span><span class='hs-layout'>,</span><span class='hs-varid'>a2</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>a1</span><span class='hs-layout'>,</span><span class='hs-varid'>c</span><span class='hs-layout'>,</span><span class='hs-varid'>a2</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>,</span><span class='hs-keyglyph'>[</span><span class='hs-varid'>b1</span><span class='hs-layout'>,</span><span class='hs-varid'>c</span><span class='hs-layout'>,</span><span class='hs-varid'>b2</span><span class='hs-keyglyph'>]</span><span class='hs-keyglyph'>]</span>+ <span class='hs-varid'>rows</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>id</span>+ <span class='hs-varid'>cols</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>transpose</span>++ <span class='hs-comment'>-- is the game a draw?</span>+<span class='hs-definition'>draw</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>GameState</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Bool</span>+<span class='hs-definition'>draw</span> <span class='hs-layout'>(</span><span class='hs-conid'>Game</span> <span class='hs-varid'>board</span> <span class='hs-keyword'>_</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>null</span> <span class='hs-layout'>(</span><span class='hs-varid'>possibleMoves</span> <span class='hs-varid'>board</span><span class='hs-layout'>)</span>++ <span class='hs-comment'>-- print the board</span>+<span class='hs-definition'>showSquare</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>either</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>n</span> <span class='hs-keyglyph'>-></span> <span class='hs-str'>" "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-varid'>n</span> <span class='hs-varop'>++</span> <span class='hs-str'>" "</span><span class='hs-layout'>)</span> <span class='hs-layout'>(</span><span class='hs-varid'>concat</span> <span class='hs-varop'>.</span> <span class='hs-varid'>replicate</span> <span class='hs-num'>3</span> <span class='hs-varop'>.</span> <span class='hs-varid'>show</span><span class='hs-layout'>)</span>++<span class='hs-definition'>showBoard</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Board</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>String</span>+<span class='hs-definition'>showBoard</span> <span class='hs-varid'>board</span> <span class='hs-keyglyph'>=</span>+ <span class='hs-varid'>unlines</span> <span class='hs-varop'>.</span> <span class='hs-varid'>surround</span> <span class='hs-str'>"+---+---+---+"</span>+ <span class='hs-varop'>.</span> <span class='hs-varid'>map</span> <span class='hs-layout'>(</span><span class='hs-varid'>concat</span> <span class='hs-varop'>.</span> <span class='hs-varid'>surround</span> <span class='hs-str'>"|"</span><span class='hs-varop'>.</span> <span class='hs-varid'>map</span> <span class='hs-varid'>showSquare</span><span class='hs-layout'>)</span>+ <span class='hs-varop'>$</span> <span class='hs-varid'>board</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>surround</span> <span class='hs-varid'>x</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'>++</span> <span class='hs-varid'>intersperse</span> <span class='hs-varid'>x</span> <span class='hs-varid'>xs</span> <span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>x</span><span class='hs-keyglyph'>]</span>++<span class='hs-definition'>printBoard</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>putStr</span> <span class='hs-varop'>.</span> <span class='hs-varid'>showBoard</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ Player examples+------------------------------------------------------------------------------}</span>+ <span class='hs-comment'>-- a human player on the command line</span>+<span class='hs-definition'>playerHuman</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Player</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>+<span class='hs-definition'>playerHuman</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>forever</span> <span class='hs-varop'>$</span> <span class='hs-varid'>readBoard</span> <span class='hs-varop'>>>=</span> <span class='hs-varid'>liftIO</span> <span class='hs-varop'>.</span> <span class='hs-varid'>printBoard</span> <span class='hs-varop'>>></span> <span class='hs-varid'>doMove</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-comment'>-- ask the player where to move</span>+ <span class='hs-varid'>doMove</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Player</span> <span class='hs-conid'>IO</span> <span class='hs-conid'>()</span>+ <span class='hs-varid'>doMove</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>liftIO</span> <span class='hs-varop'>.</span> <span class='hs-varid'>putStrLn</span> <span class='hs-varop'>$</span> <span class='hs-str'>"At which number would you like to play?"</span>+ <span class='hs-varid'>n</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>liftIO</span> <span class='hs-varid'>getLine</span>+ <span class='hs-varid'>b</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>playMove</span> <span class='hs-layout'>(</span><span class='hs-varid'>read</span> <span class='hs-varid'>n</span><span class='hs-layout'>)</span>+ <span class='hs-varid'>unless</span> <span class='hs-varid'>b</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>liftIO</span> <span class='hs-varop'>.</span> <span class='hs-varid'>putStrLn</span> <span class='hs-varop'>$</span> <span class='hs-str'>"Position "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>show</span> <span class='hs-varid'>n</span> <span class='hs-varop'>++</span> <span class='hs-str'>" is already full."</span>+ <span class='hs-varid'>doMove</span>++ <span class='hs-comment'>-- a random AI,</span>+ <span class='hs-comment'>-- also demonstrates how to use a custom StateT on top</span>+ <span class='hs-comment'>-- of the Player monad</span>+<span class='hs-definition'>playerAI</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>StdGen</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>Player</span> <span class='hs-varid'>m</span> <span class='hs-conid'>()</span>+<span class='hs-definition'>playerAI</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>evalStateT</span> <span class='hs-varid'>ai</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>ai</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-conid'>StateT</span> <span class='hs-conid'>StdGen</span> <span class='hs-layout'>(</span><span class='hs-conid'>ProgramT</span> <span class='hs-conid'>PlayerI</span> <span class='hs-varid'>m</span><span class='hs-layout'>)</span> <span class='hs-conid'>()</span>+ <span class='hs-varid'>ai</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>forever</span> <span class='hs-varop'>$</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>board</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>lift</span> <span class='hs-varop'>$</span> <span class='hs-varid'>readBoard</span>+ <span class='hs-varid'>n</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>uniform</span> <span class='hs-layout'>(</span><span class='hs-varid'>possibleMoves</span> <span class='hs-varid'>board</span><span class='hs-layout'>)</span> <span class='hs-comment'>-- select a random move</span>+ <span class='hs-varid'>lift</span> <span class='hs-varop'>$</span> <span class='hs-varid'>playMove</span> <span class='hs-varid'>n</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-comment'>-- select one element at random</span>+ <span class='hs-varid'>uniform</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Monad</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=></span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>a</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>StateT</span> <span class='hs-conid'>StdGen</span> <span class='hs-varid'>m</span> <span class='hs-varid'>a</span>+ <span class='hs-varid'>uniform</span> <span class='hs-varid'>xs</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>gen</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>get</span>+ <span class='hs-keyword'>let</span> <span class='hs-layout'>(</span><span class='hs-varid'>n</span><span class='hs-layout'>,</span><span class='hs-varid'>gen'</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>randomR</span> <span class='hs-layout'>(</span><span class='hs-num'>1</span><span class='hs-layout'>,</span><span class='hs-varid'>length</span> <span class='hs-varid'>xs</span><span class='hs-layout'>)</span> <span class='hs-varid'>gen</span>+ <span class='hs-varid'>put</span> <span class='hs-varid'>gen'</span>+ <span class='hs-varid'>return</span> <span class='hs-layout'>(</span><span class='hs-varid'>xs</span> <span class='hs-varop'>!!</span> <span class='hs-layout'>(</span><span class='hs-varid'>n</span><span class='hs-comment'>-</span><span class='hs-num'>1</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>++</pre></body>+</html>
+ docs/web/examples/WebSessionState.lhs.html view
@@ -0,0 +1,112 @@+<!DOCTYPE html PUBLIC "-//W3C//DTD XHTML 1.0 Strict//EN" "http://www.w3.org/TR/xhtml1/DTD/xhtml1-strict.dtd">+<html>+<head>+<!-- Generated by HsColour, http://www.cs.york.ac.uk/fp/darcs/hscolour/ -->+<title>examples/WebSessionState.lhs</title>+<link type='text/css' rel='stylesheet' href='hscolour.css' />+</head>+<body>+#!/bin/sh runghc+\begin{code}+<pre><span class='hs-comment'>{------------------------------------------------------------------------------+ Control.Monad.Operational+ + Example:+ A CGI script that maintains session state+ <a href="http://www.informatik.uni-freiburg.de/~thiemann/WASH/draft.pdf">http://www.informatik.uni-freiburg.de/~thiemann/WASH/draft.pdf</a>++------------------------------------------------------------------------------}</span>+<span class='hs-comment'>{-# LANGUAGE GADTs, Rank2Types #-}</span>+<span class='hs-keyword'>module</span> <span class='hs-conid'>WebSessionState</span> <span class='hs-keyword'>where</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Operational</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Control</span><span class='hs-varop'>.</span><span class='hs-conid'>Monad</span><span class='hs-varop'>.</span><span class='hs-conid'>Trans</span> <span class='hs-varid'>hiding</span> <span class='hs-layout'>(</span><span class='hs-varid'>lift</span><span class='hs-layout'>)</span>++<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Char</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Data</span><span class='hs-varop'>.</span><span class='hs-conid'>Maybe</span>++ <span class='hs-comment'>-- external libraries needed</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Text</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span> <span class='hs-keyword'>as</span> <span class='hs-conid'>H</span>+<span class='hs-keyword'>import</span> <span class='hs-conid'>Network</span><span class='hs-varop'>.</span><span class='hs-conid'>CGI</span>++<span class='hs-comment'>{------------------------------------------------------------------------------+ This example shows a "magic" implementation of a web session that+ looks like it needs to be executed in a running process,+ while in fact it's just a CGI script.+ + The key part is a monad, called "Web" for lack of imagination,+ which supports a single operation+ + ask :: String -> Web String+ + which sends a simple minded HTML-Form to the web user+ and returns his answer.+ + How does this work? The trick is that all previous answers+ are logged in a hidden field of the input form.+ The CGI script will simply replays this log when called.+ In other words, the user state is stored in the input form.++------------------------------------------------------------------------------}</span>+<span class='hs-keyword'>data</span> <span class='hs-conid'>WebI</span> <span class='hs-varid'>a</span> <span class='hs-keyword'>where</span>+ <span class='hs-conid'>Ask</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>String</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>WebI</span> <span class='hs-conid'>String</span>++<span class='hs-keyword'>type</span> <span class='hs-conid'>Web</span> <span class='hs-varid'>a</span> <span class='hs-keyglyph'>=</span> <span class='hs-conid'>Program</span> <span class='hs-conid'>WebI</span> <span class='hs-varid'>a</span>++<span class='hs-definition'>ask</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>singleton</span> <span class='hs-varop'>.</span> <span class='hs-conid'>Ask</span>++ <span class='hs-comment'>-- interpreter</span>+<span class='hs-definition'>runWeb</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Web</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CGI</span> <span class='hs-conid'>CGIResult</span>+<span class='hs-definition'>runWeb</span> <span class='hs-varid'>m</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-comment'>-- fetch log</span>+ <span class='hs-varid'>log'</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>maybe</span> <span class='hs-conid'>[]</span> <span class='hs-layout'>(</span><span class='hs-varid'>read</span> <span class='hs-varop'>.</span> <span class='hs-varid'>urlDecode</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>getInput</span> <span class='hs-str'>"log"</span>+ <span class='hs-comment'>-- maybe append form input</span>+ <span class='hs-varid'>f</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>maybe</span> <span class='hs-varid'>id</span> <span class='hs-layout'>(</span><span class='hs-keyglyph'>\</span><span class='hs-varid'>answer</span> <span class='hs-keyglyph'>-></span> <span class='hs-layout'>(</span><span class='hs-varop'>++</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>answer</span><span class='hs-keyglyph'>]</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span> <span class='hs-varop'>`liftM`</span> <span class='hs-varid'>getInput</span> <span class='hs-str'>"answer"</span>+ <span class='hs-keyword'>let</span> <span class='hs-varid'>log</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>f</span> <span class='hs-varid'>log'</span>+ <span class='hs-comment'>-- run Web action and output result</span>+ <span class='hs-varid'>output</span> <span class='hs-varop'>.</span> <span class='hs-varid'>renderHtml</span> <span class='hs-varop'>=<<</span> <span class='hs-varid'>replay</span> <span class='hs-varid'>m</span> <span class='hs-varid'>log</span> <span class='hs-varid'>log</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>replay</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>eval</span> <span class='hs-varop'>.</span> <span class='hs-varid'>view</span>+ + <span class='hs-varid'>eval</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>ProgramView</span> <span class='hs-conid'>WebI</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-keyglyph'>[</span><span class='hs-conid'>String</span><span class='hs-keyglyph'>]</span> <span class='hs-keyglyph'>-></span> <span class='hs-conid'>CGI</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Return</span> <span class='hs-varid'>html</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-keyword'>_</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-varid'>html</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Ask</span> <span class='hs-varid'>question</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-layout'>(</span><span class='hs-varid'>l</span><span class='hs-conop'>:</span><span class='hs-varid'>ls</span><span class='hs-layout'>)</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-- replay answer from log</span>+ <span class='hs-varid'>replay</span> <span class='hs-layout'>(</span><span class='hs-varid'>k</span> <span class='hs-varid'>l</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-varid'>ls</span>+ <span class='hs-varid'>eval</span> <span class='hs-layout'>(</span><span class='hs-conid'>Ask</span> <span class='hs-varid'>question</span> <span class='hs-conop'>:>>=</span> <span class='hs-varid'>k</span><span class='hs-layout'>)</span> <span class='hs-varid'>log</span> <span class='hs-conid'>[]</span> <span class='hs-keyglyph'>=</span> <span class='hs-comment'>-- present HTML page to user</span>+ <span class='hs-varid'>return</span> <span class='hs-varop'>$</span> <span class='hs-varid'>htmlQuestion</span> <span class='hs-varid'>log</span> <span class='hs-varid'>question</span>+++ <span class='hs-comment'>-- HTML page with a single form</span>+<span class='hs-definition'>htmlQuestion</span> <span class='hs-varid'>log</span> <span class='hs-varid'>question</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>htmlEnvelope</span> <span class='hs-varop'>$</span> <span class='hs-varid'>p</span> <span class='hs-varop'><<</span> <span class='hs-varid'>question</span> <span class='hs-varop'>+++</span> <span class='hs-varid'>x</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>x</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>form</span> <span class='hs-varop'>!</span> <span class='hs-keyglyph'>[</span><span class='hs-varid'>method</span> <span class='hs-str'>"post"</span><span class='hs-keyglyph'>]</span> <span class='hs-varop'><<</span> <span class='hs-layout'>(</span><span class='hs-varid'>textfield</span> <span class='hs-str'>"answer"</span>+ <span class='hs-varop'>+++</span> <span class='hs-varid'>submit</span> <span class='hs-str'>"Next"</span> <span class='hs-str'>""</span>+ <span class='hs-varop'>+++</span> <span class='hs-varid'>hidden</span> <span class='hs-str'>"log"</span> <span class='hs-layout'>(</span><span class='hs-varid'>urlEncode</span> <span class='hs-varop'>$</span> <span class='hs-varid'>show</span> <span class='hs-varid'>log</span><span class='hs-layout'>)</span><span class='hs-layout'>)</span>++<span class='hs-definition'>htmlMessage</span> <span class='hs-varid'>s</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>htmlEnvelope</span> <span class='hs-varop'>$</span> <span class='hs-varid'>p</span> <span class='hs-varop'><<</span> <span class='hs-varid'>s</span>++<span class='hs-definition'>htmlEnvelope</span> <span class='hs-varid'>html</span> <span class='hs-keyglyph'>=</span>+ <span class='hs-varid'>header</span> <span class='hs-varop'><<</span> <span class='hs-varid'>thetitle</span> <span class='hs-varop'><<</span> <span class='hs-str'>"Web Session State demo"</span>+ <span class='hs-varop'>+++</span> <span class='hs-varid'>body</span> <span class='hs-varop'><<</span> <span class='hs-varid'>html</span>+++ <span class='hs-comment'>-- example</span>+<span class='hs-definition'>example</span> <span class='hs-keyglyph'>::</span> <span class='hs-conid'>Web</span> <span class='hs-conid'>H</span><span class='hs-varop'>.</span><span class='hs-conid'>Html</span>+<span class='hs-definition'>example</span> <span class='hs-keyglyph'>=</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>haskell</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>ask</span> <span class='hs-str'>"What's your favorite programming language?"</span>+ <span class='hs-keyword'>if</span> <span class='hs-varid'>map</span> <span class='hs-varid'>toLower</span> <span class='hs-varid'>haskell</span> <span class='hs-varop'>/=</span> <span class='hs-str'>"haskell"</span>+ <span class='hs-keyword'>then</span> <span class='hs-varid'>message</span> <span class='hs-str'>"Awww."</span>+ <span class='hs-keyword'>else</span> <span class='hs-keyword'>do</span>+ <span class='hs-varid'>ghc</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>ask</span> <span class='hs-str'>"What's your favorite compiler?"</span>+ <span class='hs-varid'>web</span> <span class='hs-keyglyph'><-</span> <span class='hs-varid'>ask</span> <span class='hs-str'>"What's your favorite monad?"</span>+ <span class='hs-varid'>message</span> <span class='hs-varop'>$</span> <span class='hs-str'>"I like "</span> <span class='hs-varop'>++</span> <span class='hs-varid'>ghc</span> <span class='hs-varop'>++</span> <span class='hs-str'>" too, but "</span>+ <span class='hs-varop'>++</span> <span class='hs-varid'>web</span> <span class='hs-varop'>++</span> <span class='hs-str'>" is debatable."</span>+ <span class='hs-keyword'>where</span>+ <span class='hs-varid'>message</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>return</span> <span class='hs-varop'>.</span> <span class='hs-varid'>htmlMessage</span>++<span class='hs-definition'>main</span> <span class='hs-keyglyph'>=</span> <span class='hs-varid'>runCGI</span> <span class='hs-varop'>.</span> <span class='hs-varid'>runWeb</span> <span class='hs-varop'>$</span> <span class='hs-varid'>example</span>++</pre>\end{code}+</body>+</html>
+ docs/web/examples/hscolour.css view
@@ -0,0 +1,5 @@+.hs-keyglyph, .hs-layout { color: red; }+.hs-keyword { color: blue; }+.hs-comment, .hs-comment a { color: green; }+.hs-str, .hs-chr { color: teal; }+.hs-keyword,.hs-conid, .hs-varid, .hs-conop, .hs-varop, .hs-num, .hs-cpp, .hs-sel, .hs-definition {}
+ docs/web/fptools.css view
@@ -0,0 +1,48 @@+body {+ font-family: Verdana, sans-serif;+ width: 43em;+ margin: 1ex 3em 1ex;+}++div {+ font-family: sans-serif;+ color: black;+ background: white+}++h1, h2, h3, h4, h5, h6, p.title, h1 > a:visited, h2 > a:visited, h1 > a:link, h2 > a:link { color: #005A9C; text-decoration:none; }++h1 { font: 170% sans-serif; }+h2 { font: 140% sans-serif; }+h3 { font: 120% sans-serif; }+h4 { font: bold 100% sans-serif; }+h5 { font: italic 100% sans-serif; }+h6 { font: small-caps 100% sans-serif; }++pre {+ font-family: monospace;+ border-width: 1px;+ border-style: solid;+ padding: 0.3em;+ color: maroon;+}++pre.screen { color: #006400; }+pre.programlisting { color: maroon; }++div.example {+ margin: 1ex 0em;+ border: solid #412e25 1px;+ padding: 0ex 0.4em;+}++div.example, div.example-contents {+ background-color: #fffcf5;+}++a:link { color: #0000C8; }+a:hover { background: #FFFFA8; }+a:active { color: #D00000; }+a:visited { color: #680098; }++h1 > a { color: #000; }
+ docs/web/index.html view
@@ -0,0 +1,24 @@+<html><head><title>The 'operational' package</title></head>+<body>+<h1>The 'operational' package</h1>++Implement monads by specifying instructions and their desired operational semantics.++<h2>Download</h2>+<ul>+<li><a href="http://hackage.haskell.org/package/operational">Latest version</a> on hackage</li>+<li><a href="http://code.haskell.org/operational">Darcs repository</a></li>+</ul>++<h2>Documentation</h2>+<ul>+<li><a href="http://themonadreader.wordpress.com/2010/01/26/issue-15/">The Operational Monad Tutorial</a> - Introductory document explaining the concept.</li>+<li><a href="http://projects.haskell.org/operational/Documentation.html">Library documentation</a> - How to use the libary proper; documents changes with respect to the tutorial.</li>+<li><a href="http://hackage.haskell.org/package/operational/">API Reference</a> on hackage</li>+<li><a href="http://projects.haskell.org/operational/examples.html">Example code</a> - Collection of working examples.</li>+</ul>++<h2>Authors</h2>+<i><a href="http://apfelmus.nfshost.com/">Heinrich Apfelmus</a>, April 2010</i>++</body></html>
operational.cabal view
@@ -1,15 +1,15 @@ Name: operational-Version: 0.1.0.0+Version: 0.2.0.0 Synopsis: Implement monads by specifying operational semantics. Description: Tiny library for implementing monads by specifying the primitive instructions and their operational semantics. The monad laws will hold automatically. Can also be used to define monad transformers,- the lifting laws are, again, automatic.- + and the lifting laws are, again, automatic.+ . Accompanies the article: \"The Operational Monad Tutorial\", published in Issue 15 of The Monad.Reader <http://themonadreader.wordpress.com/2010/01/26/issue-15/>.- + . Related packages: MonadPrompt <http://hackage.haskell.org/package/MonadPrompt>. Category: Control, Monads@@ -23,12 +23,16 @@ build-type: Simple cabal-version: >= 1.6-extra-source-files: docs/*.css- docs/*.html- docs/*.md+extra-source-files: CHANGELOG+ docs/Documentation.md docs/Makefile docs/examples/*.hs docs/examples/*.lhs+ docs/web/fptools.css+ docs/web/*.html+ docs/web/examples/hscolour.css+ docs/web/examples/*.hs.html+ docs/web/examples/*.lhs.html source-repository head type: darcs@@ -39,5 +43,6 @@ hs-source-dirs: src build-depends: base == 4.* , mtl == 1.1.* ghc-options: -Wall- extensions: GADTs+ extensions: GADTs, UndecidableInstances,+ MultiParamTypeClasses, FlexibleInstances exposed-modules: Control.Monad.Operational
src/Control/Monad/Operational.hs view
@@ -1,20 +1,21 @@-{-# LANGUAGE GADTs #-}+{-# LANGUAGE GADTs, UndecidableInstances, MultiParamTypeClasses, FlexibleInstances #-}+-- Search for UndecidableInstances to see why this is needed+ {-| Implement monads by specifying primitive instructions and their operational semantics. This package is based on the \"The Operational Monad Tutorial\", published in Issue 15 of The Monad.Reader <http://themonadreader.wordpress.com/>. -You are reading the API reference. For more thorough documentation including design and implementation notes as well as a correctness proof, please consult the included @doc/Documentation.html@.--This API reference includes only basic example code. More intricate examples are available in the @doc/examples@ directory.+You are reading the API reference. For more thorough documentation including design and implementation notes as well as a correctness proof, please consult the included documentation in @docs\/Documentation.html@, also available at <http://projects.haskell.org/operational/Documentation.html> . +This API reference includes only basic example code. More intricate examples are available in the @docs\/examples@ directory, also available at <http://projects.haskell.org/operational/examples.html>. -} module Control.Monad.Operational ( -- * Basic usage- Program, singleton, Prompt, view,+ Program, singleton, ProgramView, view, -- $example -- * Monad transformer- ProgramT, PromptT(..), viewT+ ProgramT, ProgramViewT(..), viewT, liftProgram -- $exampleT ) where@@ -23,6 +24,14 @@ import Control.Monad.Trans import Control.Applicative + -- mtl classes to instantiate.+ -- Those commented out cannot be instantiated. For reasons see below.+-- import Control.Monad.Cont.Class+-- import Control.Monad.Error.Class+-- import Control.Monad.Reader.Class+import Control.Monad.State.Class+-- import Control.Monad.Writer.Class + {------------------------------------------------------------------------------ Program ------------------------------------------------------------------------------}@@ -39,16 +48,16 @@ -- | View type for inspecting the first instruction. -- It has two constructors 'Return' and @:>>=@.--- (For technical reasons, they are documented at 'PromptT'.)-type Prompt instr a = PromptT instr Identity a+-- (For technical reasons, they are documented at 'ProgramViewT'.)+type ProgramView instr a = ProgramViewT instr Identity a -- | View function for inspecting the first instruction.-view :: Program instr a -> Prompt instr a+view :: Program instr a -> ProgramView instr a view = runIdentity . viewT {- $example -/Example/+/Example usage/ Stack machine from \"The Operational Monad Tutorial\". @@ -66,13 +75,13 @@ interpret :: StackProgram a -> (Stack Int -> a) interpret = eval . view where- eval :: Prompt StackInstruction a -> (Stack Int -> a)+ eval :: ProgramView StackInstruction a -> (Stack Int -> a) eval (Push a :>>= is) stack = interpret (is ()) (a:stack) eval (Pop :>>= is) (a:stack) = interpret (is a ) stack eval (Return a) stack = a @ -Note that since 'Prompt' is a GADT, the type annotation for @eval@ is mandatory.+Note that since 'ProgramView' is a GADT, the type annotation for @eval@ is mandatory. -} @@ -88,7 +97,7 @@ * @a@ is the return type of a program. @'ProgramT' instr m@ is a monad transformer and- automatically obey both the monad and the lifting laws.+ automatically obeys both the monad and the lifting laws. -} data ProgramT instr m a where Lift :: m a -> ProgramT instr m a@@ -96,6 +105,7 @@ -> ProgramT instr m a Instr :: instr a -> ProgramT instr m a + -- basic instances instance Monad m => Monad (ProgramT instr m) where return = Lift . return (>>=) = Bind@@ -115,21 +125,41 @@ singleton = Instr -- | View type for inspecting the first instruction.-data PromptT instr m a where- Return :: a -> PromptT instr m a- (:>>=) :: instr b -> (b -> ProgramT instr m a ) -> PromptT instr m a+data ProgramViewT instr m a where+ Return :: a -> ProgramViewT instr m a+ (:>>=) :: instr b -> (b -> ProgramT instr m a ) -> ProgramViewT instr m a -- | View function for inspecting the first instruction.-viewT :: Monad m => ProgramT instr m a -> m (PromptT instr m a)+viewT :: Monad m => ProgramT instr m a -> m (ProgramViewT instr m a) viewT (Lift m) = m >>= return . Return viewT ((Lift m) `Bind` g) = m >>= viewT . g viewT ((m `Bind` g) `Bind` h) = viewT (m `Bind` (\x -> g x `Bind` h)) viewT ((Instr i) `Bind` g) = return (i :>>= g) viewT (Instr i) = return (i :>>= return) +{-| Lift a plain sequence of instructions to a sequence+ of instructions over a monad 'm'.+ This is the counterpart of the 'lift' function from 'MonadTrans'.+ + It can be defined as follows:++@+ liftProgram = eval . view+ where+ eval :: ProgramView instr a -> ProgramT instr m a+ eval (Return a) = return a+ eval (i :>>= k) = singleton i >>= liftProgram . k+@+ +-}+liftProgram :: Monad m => Program instr a -> ProgramT instr m a+liftProgram (Lift m) = return (runIdentity m)+liftProgram (m `Bind` k) = liftProgram m `Bind` (liftProgram . k)+liftProgram (Instr i) = Instr i+ {- $exampleT -/Example/+/Example usage/ List monad transformer. @@ -147,13 +177,57 @@ runList :: Monad m => ListT m a -> m [a] runList = eval <=< viewT where- eval :: Monad m => PromptT (PlusI m) m a -> m [a]+ eval :: Monad m => ProgramViewT (PlusI m) m a -> m [a] eval (Return x) = return [x]- eval (Zero :>>= g) = return []- eval (Plus m n :>>= g) =- liftM2 (++) (runList (m >>= g)) (runList (n >>= g))+ eval (Zero :>>= k) = return []+ eval (Plus m n :>>= k) =+ liftM2 (++) (runList (m >>= k)) (runList (n >>= k)) @ -Note that since 'Prompt' is a GADT, the type annotation for @eval@ is mandatory.+Note that since 'ProgramView' is a GADT, the type annotation for @eval@ is mandatory. +-}++{------------------------------------------------------------------------------+ mtl instances+ + * All of these instances need UndecidableInstances, because they do not satisfy the coverage condition.+ + * We can only make instances of those classes+ that do not contain control operators. Control operators are+ functions like+ + listen :: m a -> m (a,w)+ + that take arguments of type m a and cannot be implemented with lift .+ + See also Conor McBride's remark on haskell-cafe:+ http://www.haskell.org/pipermail/haskell-cafe/2010-April/076185.html+------------------------------------------------------------------------------}+instance (MonadState s m) => MonadState s (ProgramT instr m) where+ get = lift get+ put = lift . put++instance (MonadIO m) => MonadIO (ProgramT instr m) where+ liftIO = lift . liftIO++{- Attempt to lift control operators anyway. WARNING: HERE BE DRAGONS++ -- lift a control operation with a single argument+ -- Unfortunately, I don't have a specifications in terms of laws yet+ -- I think it makes use of+ -- liftControlOp1 f (lift m >>= k) = lift m >>= liftControlOp1 f . k+ -- and is therefore completely useless.+liftControlOp1 :: Monad m =>+ (m a -> m b) -> (ProgramT instr m a -> ProgramT instr m b)+liftControlOp1 f = join . lift . (eval <=< viewT)+ where+ eval :: ProgramViewT instr m a -> m (ProgramT instr m a)+ eval (Return a) = f (return a)+ eval (i :>>= k) = i :>>= liftControlOp1 f . k++instance (MonadWriter w m) => MonadWriter w (ProgramT instr m) where+ tell = lift . tell+ listen = liftControlOp1 listen+ pass = liftControlOp1 pass -}