mirror of
https://github.com/tildearrow/furnace.git
synced 2024-11-06 04:45:05 +00:00
76 lines
2.1 KiB
OCaml
76 lines
2.1 KiB
OCaml
|
(*
|
||
|
|
* Copyright (c) 1997-1999 Massachusetts Institute of Technology
|
||
|
|
* Copyright (c) 2003, 2007-14 Matteo Frigo
|
||
|
|
* Copyright (c) 2003, 2007-14 Massachusetts Institute of Technology
|
||
|
|
*
|
||
|
|
* This program is free software; you can redistribute it and/or modify
|
||
|
|
* it under the terms of the GNU General Public License as published by
|
||
|
|
* the Free Software Foundation; either version 2 of the License, or
|
||
|
|
* (at your option) any later version.
|
||
|
|
*
|
||
|
|
* This program is distributed in the hope that it will be useful,
|
||
|
|
* but WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
|
|
* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
|
||
|
|
* GNU General Public License for more details.
|
||
|
|
*
|
||
|
|
* You should have received a copy of the GNU General Public License
|
||
|
|
* along with this program; if not, write to the Free Software
|
||
|
|
* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
||
|
|
*
|
||
|
|
*)
|
||
|
|
|
||
|
|
(*************************************************************
|
||
|
|
* Monads
|
||
|
|
*************************************************************)
|
||
|
|
|
||
|
|
(*
|
||
|
|
* Phil Wadler has many well written papers about monads. See
|
||
|
|
* http://cm.bell-labs.com/cm/cs/who/wadler/
|
||
|
|
*)
|
||
|
|
(* vanilla state monad *)
|
||
|
|
module StateMonad = struct
|
||
|
|
let returnM x = fun s -> (x, s)
|
||
|
|
|
||
|
|
let (>>=) = fun m k ->
|
||
|
|
fun s ->
|
||
|
|
let (a', s') = m s
|
||
|
|
in let (a'', s'') = k a' s'
|
||
|
|
in (a'', s'')
|
||
|
|
|
||
|
|
let (>>) = fun m k ->
|
||
|
|
m >>= fun _ -> k
|
||
|
|
|
||
|
|
let rec mapM f = function
|
||
|
|
[] -> returnM []
|
||
|
|
| a :: b ->
|
||
|
|
f a >>= fun a' ->
|
||
|
|
mapM f b >>= fun b' ->
|
||
|
|
returnM (a' :: b')
|
||
|
|
|
||
|
|
let runM m x initial_state =
|
||
|
|
let (a, _) = m x initial_state
|
||
|
|
in a
|
||
|
|
|
||
|
|
let fetchState =
|
||
|
|
fun s -> s, s
|
||
|
|
|
||
|
|
let storeState newState =
|
||
|
|
fun _ -> (), newState
|
||
|
|
end
|
||
|
|
|
||
|
|
(* monad with built-in memoizing capabilities *)
|
||
|
|
module MemoMonad =
|
||
|
|
struct
|
||
|
|
open StateMonad
|
||
|
|
|
||
|
|
let memoizing lookupM insertM f k =
|
||
|
|
lookupM k >>= fun vMaybe ->
|
||
|
|
match vMaybe with
|
||
|
|
Some value -> returnM value
|
||
|
|
| None ->
|
||
|
|
f k >>= fun value ->
|
||
|
|
insertM k value >> returnM value
|
||
|
|
|
||
|
|
let runM initial_state m x = StateMonad.runM m x initial_state
|
||
|
|
end
|