Update code

code/State.hs

@@ -0,0 +1,124 @@
+{- A Haskell version of the companion code for "State of effectful programming".
+   Tested with GHCi 8.6.5. -}
+import Control.Monad.ST (runST)
+import Data.STRef       (newSTRef, readSTRef, writeSTRef)
+-- State monad
+newtype State s a = State { runState :: s -> (a,s) }
+
+-- | State is a functor
+instance Functor (State s) where
+  fmap f m = State (\st -> let (x, st') = runState m st in
+                           (f x, st'))
+
+-- | State is an applicative functor
+instance Applicative (State s) where
+  pure x = State (\st -> (x, st))
+  m1 <*> m2 = State (\st -> let (f, st') = runState m1 st in
+                            runState (fmap f m2) st')
+
+-- | State is a monad
+instance Monad (State s) where
+  return = pure
+  m >>= k = State (\st -> let (x, st') = runState m st in
+                          runState (k x) st')
+
+-- | State operations
+get :: () -> State s s
+get () = State (\st -> (st, st))
+
+put :: s -> State s ()
+put st = State (\st' -> ((), st))
+
+-- Continuation monad
+newtype Cont r a = Cont { runCont :: (a -> r) -> r }
+
+-- | Cont is a functor
+instance Functor (Cont r) where
+  fmap f k = Cont (\g -> runCont k (\x -> g (f x)))
+
+-- | Cont is an applicative functor
+instance Applicative (Cont r) where
+  pure x  = Cont (\k -> k x)
+  k <*> k' = Cont (\r -> runCont k
+                   (\k'' -> runCont k'
+                     (\x -> r (k'' x))))
+
+-- | Cont is a monad
+instance Monad (Cont r) where
+  return  = pure
+  m >>= k = Cont (\k' -> runCont m
+                   (\x -> runCont (k x)
+                     (\y -> k' y)))
+
+-- | State operations
+
+getk :: () -> Cont (State s a) s
+getk () = Cont (\k -> State (\st -> runState (k st) st))
+
+putk :: s -> Cont (State s a) ()
+putk st' = Cont (\k -> State (\st -> runState (k ()) st'))
+
+-- Free monad
+data Free f a = Return a
+              | Op (f (Free f a))
+
+-- | Free is a functor
+instance Functor f => Functor (Free f) where
+  fmap f (Return x) = Return (f x)
+  fmap f (Op y)     = Op (fmap (fmap f) y)
+
+-- | Free is an applicative functor
+instance Functor f => Applicative (Free f) where
+  pure  = Return
+  (Return f) <*> xs = fmap f xs
+  (Op f)     <*> xs = Op (fmap (\g -> g <*> xs) f)
+
+-- | Free is a monad
+instance Functor f => Monad (Free f) where
+  return = Return
+  (Return x) >>= k = k x
+  (Op y)     >>= k = Op (fmap (\m' -> m' >>= k) y)
+
+-- | Auxiliary function for constructing operation nodes
+do' :: Functor f => f a -> Free f a
+do' op = Op (fmap Return op)
+
+-- Instantiate Free with state
+data FreeState s r = Get (s -> r)
+                   | Put s (() -> r)
+
+-- | FreeState is a functor
+instance Functor (FreeState s) where
+  fmap f (Get k) = Get (\st -> f (k st))
+  fmap f (Put st' k) = Put st' (\() -> f (k ()))
+
+-- | State operations
+get' :: () -> Free (FreeState s) s
+get' () = do' (Get (\x -> x))
+
+put' :: s -> Free (FreeState s) ()
+put' st = do' (Put st (\() -> ()))
+
+-- | State handler
+runState' :: s -> Free (FreeState s) a -> (a, s)
+runState' st0 (Op (Get k))    = runState' st0 (k st0)
+runState' st0 (Op (Put st k)) = runState' st (k ())
+runState' st0 (Return x)      = (x, st0)
+
+-- Generic state example
+incrEven :: Monad m => (() -> m Int, Int -> m ()) -> () -> m Bool
+incrEven (get, put) () = get () >>= (\st -> put (1 + st) >>= (\() -> return (even st)))
+
+runExamples :: Int -> [(String, (Bool, Int))]
+runExamples st0 = map (\(s, f) -> (s, f st0)) examples
+  where examples = [ ("builtin state", \st -> runST $ do
+                         st' <- newSTRef st
+                         v   <- readSTRef st'
+                         writeSTRef st' (v + 1)
+                         v'  <- readSTRef st'
+                         return (even v, v'))
+                   , ("pure state passing", \st -> (even st, st + 1))
+                   , ("state monad", \st -> runState (incrEven (get, put) ()) st)
+                   , ("continuation monad", \st -> runState (runCont (incrEven (getk, putk) ())
+                                                              (\x -> State (\st -> (x, st)))) st)
+                   , ("free monad", \st -> runState' st (incrEven (get', put') ())) ]

code/state.ml

@@ -0,0 +1,396 @@
+(* Companion for "State of effectful programming"
+   Tested with OCaml 4.10.0+multicore. *)
+
+(* Generic direct-style incr_even *)
+let even : int -> bool
+  = fun n -> n mod 2 = 0
+
+let incr_even : (unit -> int) * (int -> unit) -> unit -> bool
+  = fun (get, put) () ->
+  let st = get () in
+  put (1 + st);
+  even st
+
+(* Delimited control *)
+module Prompt : sig
+  type 'a t
+  val make : unit -> 'a t
+  val reify : 'a t -> (('b -> 'a) -> 'a) -> 'b
+  val install : 'a t -> (unit -> 'a) -> 'a
+end = struct
+  type 'a t = {
+      install : (unit -> 'a) -> 'a;
+      reify : 'b. (('b -> 'a) -> 'a) -> 'b
+    }
+
+  let make (type a) () =
+    let module M = struct
+        effect Prompt : (('b -> a) -> a) -> 'b
+      end
+    in
+    let reify f = perform (M.Prompt f) in
+    let install f =
+      match f () with
+      | x -> x
+      | effect (M.Prompt f) k -> f (continue k)
+    in
+    { install; reify }
+
+  let install { install; _ } = install
+  let reify { reify; _ } = reify
+  let resume k v = continue k v
+end
+
+module type CTRL = sig
+  type ans
+  val reset : (unit -> ans) -> ans
+  val shift : (('a -> ans) -> ans) -> 'a
+end
+
+module Ctrl(R : sig type ans end) : sig
+  include CTRL with type ans = R.ans
+end = struct
+  type ans = R.ans
+
+  let p : ans Prompt.t = Prompt.make ()
+
+  let reset m =
+    Prompt.install p m
+
+  let shift f =
+    Prompt.reify p
+      (fun k ->
+        Prompt.install p
+          (fun () ->
+            f (fun x ->
+                Prompt.install p
+                  (fun () -> k x))))
+end
+
+module CtrlState
+         (S : sig type s end)
+         (R : sig type ans end): sig
+  type s = S.s
+  type ans = s -> R.ans * s
+
+  val get : unit -> s
+  val put : s -> unit
+
+  val run : (unit -> R.ans) -> ans
+end = struct
+  type s = S.s
+  type ans = s -> R.ans * s
+  module Ctrl = Ctrl(struct type nonrec ans = ans end)
+
+  let get ()  = Ctrl.shift (fun k -> fun st -> k st st)
+  let put st' = Ctrl.shift (fun k -> fun st -> k () st')
+
+  let run m =
+    Ctrl.reset
+      (fun () ->
+        let x = m () in
+        fun st -> (x, st))
+end
+
+module CtrlIntState = CtrlState(struct type s = int end)(struct type ans = bool end)
+
+(* Monadic programming *)
+module type MONAD = sig
+  type 'a t
+  val return : 'a -> 'a t
+  val (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+end
+
+(** State monad **)
+module type STATE_MONAD = sig
+  type ans
+  type s
+  include MONAD
+
+  val get : unit -> s t
+  val put : s -> unit t
+  val run : (unit -> ans t) -> s -> ans * s
+end
+
+module StateMonad(S : sig type s end)(R : sig type ans end): sig
+  include STATE_MONAD with type s = S.s
+                       and type ans = R.ans
+end = struct
+  type ans = R.ans
+  type s = S.s
+  type 'a t = s -> 'a * s
+
+  let return : 'a -> 'a t
+    = fun x -> fun st -> (x, st)
+
+  let (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    = fun m k -> fun st ->
+      let (x, st') = m st in
+      k x st'
+
+  let get : unit -> s t
+    = fun () st -> (st, st)
+
+  let put : s -> unit t
+    = fun st st' -> ((), st)
+
+  let run : (unit -> ans t) -> s -> ans * s
+    = fun m st -> m () st
+end
+
+module IntStateMonad = StateMonad(struct type s = int end)(struct type ans = bool end)
+
+(** Continuation monad **)
+module type CONTINUATION_MONAD = sig
+  type r
+  include MONAD with type 'a t = ('a -> r) -> r
+end
+
+module ContinuationMonad(R : sig type ans end): sig
+  include CONTINUATION_MONAD with type r = R.ans
+end = struct
+  type r = R.ans
+  type 'a t = ('a -> r) -> r
+
+  let return : 'a -> 'a t
+    = fun x -> fun k -> k x
+
+  let (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    = fun m k -> fun c ->
+      m (fun x -> k x c)
+end
+
+module ContinuationStateMonad
+         (S : sig type s end)
+         (R : sig type ans end): sig
+  type s = S.s
+  type ans = R.ans
+  include CONTINUATION_MONAD with type r = s -> ans * s
+
+  val get : unit -> s t
+  val put : s -> unit t
+  val run : (unit -> ans t) -> s -> ans * s
+end = struct
+  type s = S.s
+  type ans = R.ans
+  module ContinuationMonad : CONTINUATION_MONAD with type r = s -> ans * s
+    = ContinuationMonad(struct type nonrec ans = s -> ans * s end)
+  include ContinuationMonad
+
+  let get : unit -> s t
+    = fun () -> fun k -> fun st -> k st st
+
+  let put : s -> unit t
+    = fun st' -> fun k -> fun st -> k () st'
+
+  let run : (unit -> R.ans t) -> s -> R.ans * s =
+    fun m st -> m () (fun x -> fun st -> (x, st)) st
+end
+
+module ContinuationIntStateMonad
+  = ContinuationStateMonad(struct type s = int end)(struct type ans = bool end)
+
+(** Free monad **)
+module type FUNCTOR = sig
+  type 'a t
+  val fmap : ('a -> 'b) -> 'a t -> 'b t
+end
+
+module type FREE_MONAD = sig
+  type 'a op
+  type 'a free = Return of 'a
+               | Op of 'a free op
+
+  include MONAD with type 'a t = 'a free
+
+  val do' : 'a op -> 'a free
+end
+
+module FreeMonad(F : FUNCTOR) : sig
+  include FREE_MONAD with type 'a op = 'a F.t
+end = struct
+  type 'a op = 'a F.t
+  type 'a free = Return of 'a
+               | Op of 'a free F.t
+
+  type 'a t = 'a free
+
+  let return : 'a -> 'a t
+    = fun x -> Return x
+
+  let rec (>>=) : 'a t -> ('a -> 'b t) -> 'b t
+    = fun m k ->
+    match m with
+    | Return x -> k x
+    | Op y -> Op (F.fmap (fun m' -> m' >>= k) y)
+
+  let do' : 'a F.t -> 'a free
+    = fun op -> Op (F.fmap (fun x -> Return x) op)
+end
+
+module type FREE_STATE = sig
+  type s
+  type 'r opsig = Get of (s -> 'r)
+                | Put of s * (unit -> 'r)
+  include FUNCTOR with type 'r t = 'r opsig
+end
+
+module FreeState(S : sig type s end) = struct
+  type s = S.s
+  type 'r opsig = Get of (s -> 'r)
+                | Put of s * (unit -> 'r)
+  type 'r t = 'r opsig
+
+  let fmap : ('a -> 'b) -> 'a t -> 'b t
+    = fun f op ->
+    match op with
+    | Get k -> Get (fun st -> f (k st))
+    | Put (st', k) -> Put (st', fun st -> f (k ()))
+end
+
+module FreeIntStateMonad: sig
+  include STATE_MONAD with type s = int
+                       and type ans = bool
+end = struct
+
+  module rec FreeIntState : FREE_STATE with type s = int
+    = FreeState(struct type s = int end)
+  and FreeIntStateMonad : FREE_MONAD with type 'r op = 'r FreeIntState.opsig
+    = FreeMonad(FreeIntState)
+
+  open FreeIntState
+  include FreeIntStateMonad
+
+  type s = int
+  type ans = bool
+
+  let get : unit -> s t
+    = fun () -> do' (Get (fun st -> st))
+
+  let put : s -> unit t
+    = fun st -> do' (Put (st, fun () -> ()))
+
+  let rec run : (unit -> ans t) -> s -> ans * s
+    = fun m st ->
+    match m () with
+    | Return x          -> (x, st)
+    | Op (Get k)        -> run (fun () -> k st) st
+    | Op (Put (st', k)) -> run k st'
+end
+
+(** Monadic reflection **)
+module Reflect
+         (M : MONAD)
+         (R : sig type ans end): sig
+  type ans = R.ans
+
+  val reify : (unit -> ans) -> ans M.t
+  val reflect : 'a M.t -> 'a
+
+end = struct
+  type ans = R.ans
+  effect Reflect : 'a M.t -> 'a
+
+  let reify : (unit -> ans) -> ans M.t
+    = fun f ->
+    let open M in
+    match f () with
+    | x -> return x
+    | effect (Reflect m) k -> m >>= (continue k)
+
+  let reflect : 'a M.t -> 'a
+    = fun m ->
+    perform (Reflect m)
+end
+
+module ReflectIntStateMonad
+  = Reflect(IntStateMonad)(struct type ans = bool end)
+
+module ReflectIntState = struct
+  open ReflectIntStateMonad
+
+  let get : unit -> int
+    = fun () -> reflect (IntStateMonad.get ())
+
+  let put : int -> unit
+    = fun st -> reflect (IntStateMonad.put st)
+
+  let run : (unit -> bool) -> int -> bool * int
+    = fun m st -> IntStateMonad.run (fun () -> reify m) st
+end
+
+(* Generic monadic incr_even *)
+module MonadExample(T : STATE_MONAD with type s = int) = struct
+  let incr_even : unit -> bool T.t
+    = fun () ->
+    let open T in
+    (get ()) >>= (fun st -> put (1 + st)
+             >>= (fun () -> return (even st)))
+end
+
+(** Effect handlers **)
+module type STATE_HANDLER = sig
+  type s
+
+  val get : unit -> s
+  val put : s -> unit
+  val run : (unit -> 'a) -> s -> 'a * s
+end
+
+module StateHandler(S : sig type s end) : STATE_HANDLER with type s = S.s = struct
+  type s = S.s
+
+  effect Put : s -> unit
+  let put st = perform (Put st)
+
+  effect Get : unit -> s
+  let get () = perform (Get ())
+
+  let run
+    = fun m st ->
+    let f = match m () with
+      | x -> (fun st -> (x, st))
+      | effect (Put st') k -> (fun st -> continue k () st')
+      | effect (Get ()) k -> (fun st -> continue k st st)
+    in f st
+end
+
+module IntStateHandler = StateHandler(struct type s = int end)
+
+let run_examples () =
+  let examples = [
+      "builtin", (fun st ->
+        let st = ref st in let v = !st in st := 1 + v; (even v, !st));
+      "pure state passing", (fun st -> (even st, 1 + st));
+      "shift/reset", (fun st ->
+        CtrlIntState.run (incr_even CtrlIntState.(get, put)) st);
+      "state monad", (fun st ->
+        let module MonadStateExample = MonadExample(IntStateMonad) in
+        IntStateMonad.run MonadStateExample.incr_even st);
+      "continuation monad", (fun st ->
+        let module ContinuationMonadExample = MonadExample(ContinuationIntStateMonad) in
+        ContinuationIntStateMonad.run ContinuationMonadExample.incr_even st);
+      "free monad", (fun st ->
+        let module FreeMonadExample = MonadExample(FreeIntStateMonad) in
+        FreeIntStateMonad.run FreeMonadExample.incr_even st);
+      "monadic reflection", (fun st ->
+        ReflectIntState.run (incr_even ReflectIntState.(get, put)) st);
+      "state handler", (fun st ->
+        IntStateHandler.run (incr_even IntStateHandler.(get, put)) st) ]
+  in
+  List.map (fun (s, f) -> (s, f 4)) examples
+(* module IntStateMRefl : MREFL with type ans := bool and type 'a t = 'a IntState.t
+ *   = MRefl(struct type ans = bool end)(IntState)
+ * 
+ * let get () = IntStateMRefl.reflect (IntState.get ())
+ * let put st = IntStateMRefl.reflect (IntState.put st)
+ * let run m st = IntState.run (IntStateMRefl.reify m) st
+ * 
+ * let even : int -> bool
+ *   = fun n -> n mod 2 = 0
+ * 
+ * let incr_even : unit -> bool
+ *   = fun () ->
+ *   let st = get () in
+ *   put (1 + st);
+ *   even st *)

code/unix.links

@@ -45,8 +45,6 @@ module Queue {
   fun singleton(x) { enqueue(x, empty) }
 }
 
-
-
 ##
 ## Environment
 ##
@@ -106,6 +104,27 @@ fun usermgr(user, envs, m) {
 ## Basic IO
 ##
 typename FileDescr = Int;
+typename FileCursor = Int;
+
+module File {
+  typename T = [String];
+
+  sig empty : T
+  var empty = [];
+
+  sig read : (FileCursor, T) ~> Option(String)
+  fun read(start, file) {
+    switch (drop(start, file)) {
+      case []     -> None
+      case x :: _ -> Some(x)
+    }
+  }
+
+  sig write : (String, FileCursor, T) ~> T
+  fun write(contents, fptr, file) {
+    take(fptr, file) ++ [contents] ++ drop(fptr, file)
+  }
+}
 
 sig stdout : FileDescr
 var stdout = 1;
@@ -113,7 +132,7 @@ var stdout = 1;
 sig puts : (FileDescr,String) {Puts:(FileDescr,String) -> () |_}-> ()
 fun puts(fd, s) { do Puts(fd, s) }
 
-sig basicIO : (Comp(a, {Puts:(FileDescr,String) -> () |e})) {Puts{_} |e}~> [String]
+sig basicIO : (Comp(a, {Puts:(FileDescr,String) -> () |e})) {Puts{_} |e}~> File.T
 fun basicIO(m) {
   handle(m()) {
     case Return(_) -> []
@@ -121,8 +140,6 @@ fun basicIO(m) {
   }
 }
 
-# TODO: implement file space.
-
 ##
 ## Generic state handling.
 ##
@@ -153,118 +170,125 @@ var stderr = 2;
 sig eof : String
 var eof = "\x00";
 
-sig gets : (FileDescr) {Gets:(FileDescr) -> String |_}-> String
+typename Mode = [|Read|Write|];
-fun gets(fd) { do Gets(fd) }
 
-typename Mode = [|Create|Append|];
+typename FileDescr = Int;
+typename INode = (loc:Option(Int),refc:Int);
 
-sig fopen : (Mode, String) {Fopen:(Mode, String) -> FileDescr |_}-> FileDescr
+typename INodeTable = [(INode, File.T)];
-fun fopen(mode, filename) { do Fopen(mode, filename) }
+typename FileTable  = [(Mode, INode)];
+typename 
 
-sig fclose : (FileDescr) {Fclose:(FileDescr) -> () |_}-> ()
+# sig gets : (FileDescr) {Gets:(FileDescr) -> String |_}-> String
-fun fclose(fd) { do Fclose(fd) }
+# fun gets(fd) { do Gets(fd) }
 
-typename File = Queue.T(String);
+# sig fopen : (Mode, String) {Fopen:(Mode, String) -> FileDescr |_}-> FileDescr
+# fun fopen(mode, filename) { do Fopen(mode, filename) }
 
-sig emptyFile : File
+# sig fclose : (FileDescr) {Fclose:(FileDescr) -> () |_}-> ()
-var emptyFile = Queue.empty;
+# fun fclose(fd) { do Fclose(fd) }
 
-sig writeFile : (String, File) -> File
+# typename File = Queue.T(String);
-fun writeFile(s, file) { Queue.enqueue(s, file) }
 
-sig readFile : (File) ~> (String, File)
+# sig emptyFile : File
-fun readFile(file) {
+# var emptyFile = Queue.empty;
-  switch (Queue.dequeue(file)) {
-    case (None, file) -> (eof, file)
-    case (Some(s), file) -> (s, file)
-  }
-}
 
-typename FileTable = [(FileDescr, File)];
+# sig writeFile : (String, File) -> File
-typename FileStore = [(String, FileDescr)];
+# fun writeFile(s, file) { Queue.enqueue(s, file) }
-typename FileSystem = (next:Int,ft:FileTable,fs:FileStore);
 
-sig defaultFileSystem : () -> FileSystem
+# sig readFile : (File) ~> (String, File)
-fun defaultFileSystem() {
+# fun readFile(file) {
-  var defaultTable = [ (stdin , emptyFile)
+#   switch (Queue.dequeue(file)) {
-                     , (stdout, emptyFile)
+#     case (None, file) -> (eof, file)
-                     , (stderr, emptyFile) ];
+#     case (Some(s), file) -> (s, file)
+#   }
+# }
 
-  var defaultStore = [ ("stdin" , stdin)
+# typename FileTable = [(FileDescr, File)];
-                     , ("stdout", stdout)
+# typename FileStore = [(String, FileDescr)];
-                     , ("stderr", stderr) ];
+# typename FileSystem = (next:Int,ft:FileTable,fs:FileStore);
 
-  (next=3,ft=defaultTable,fs=defaultStore)
+# sig defaultFileSystem : () -> FileSystem
-}
+# fun defaultFileSystem() {
+#   var defaultTable = [ (stdin , emptyFile)
+#                      , (stdout, emptyFile)
+#                      , (stderr, emptyFile) ];
 
-sig lookupFile : (FileDescr, FileSystem) ~> File
+#   var defaultStore = [ ("stdin" , stdin)
-fun lookupFile(fd, fsys) {
+#                      , ("stdout", stdout)
-   switch (lookup(fd, fsys.ft)) {
+#                      , ("stderr", stderr) ];
-     case Nothing -> error("err: No such file(" ^^ intToString(fd) ^^ ")")
-     case Just(file) -> file
-   }
-}
 
-sig replaceFile : (FileDescr, File, FileSystem) ~> FileSystem
+#   (next=3,ft=defaultTable,fs=defaultStore)
-fun replaceFile(fd, file, fsys) {
+# }
-  var ft = modify(fd, file, fsys.ft);
-  (fsys with ft = ft) # TODO handle nonexistent file.
-}
 
-sig createFile : (String, FileSystem) -> (FileDescr, FileSystem)
+# sig lookupFile : (FileDescr, FileSystem) ~> File
-fun createFile(filename, fsys) {
+# fun lookupFile(fd, fsys) {
-  var fd = fsys.next;
+#    switch (lookup(fd, fsys.ft)) {
-  (fd, (next = fd + 1, fs = (filename, fd) :: fsys.fs, ft = (fd, emptyFile) :: fsys.ft))
+#      case Nothing -> error("err: No such file(" ^^ intToString(fd) ^^ ")")
-}
+#      case Just(file) -> file
+#    }
+# }
 
-sig openFile : (Mode, String, FileSystem) ~> (FileDescr, FileSystem)
+# sig replaceFile : (FileDescr, File, FileSystem) ~> FileSystem
-fun openFile(mode, filename, fsys) {
+# fun replaceFile(fd, file, fsys) {
-  var (fd, fsys') = switch (lookup(filename, fsys.fs)) {
+#   var ft = modify(fd, file, fsys.ft);
-      case Nothing -> createFile(filename, fsys)
+#   (fsys with ft = ft) # TODO handle nonexistent file.
-      case Just(fd) -> (fd, fsys)
+# }
-  };
-  switch (mode) {
-    case Create -> error("erase")
-    case Append -> (fd, fsys')
-  }
-}
 
-sig closeFile : (File) ~> File
+# sig createFile : (String, FileSystem) -> (FileDescr, FileSystem)
-fun closeFile((=front,=rear)) {
+# fun createFile(filename, fsys) {
-  (front=front ++ reverse(rear), rear=[])
+#   var fd = fsys.next;
-}
+#   (fd, (next = fd + 1, fs = (filename, fd) :: fsys.fs, ft = (fd, emptyFile) :: fsys.ft))
+# }
 
-sig allowState : (() {Get-,Put- |e}~> a) -> () {Get:s,Put:(s) -> () |e}~> a
+# sig openFile : (Mode, String, FileSystem) ~> (FileDescr, FileSystem)
-fun allowState(f) { (f : (() {Get:s,Put:(s) -> () |e}~> a) <- (() {Get-,Put- |e}~> a)) }
+# fun openFile(mode, filename, fsys) {
+#   var (fd, fsys') = switch (lookup(filename, fsys.fs)) {
+#       case Nothing -> createFile(filename, fsys)
+#       case Just(fd) -> (fd, fsys)
+#   };
+#   switch (mode) {
+#     case Create -> error("erase")
+#     case Append -> (fd, fsys')
+#   }
+# }
 
-sig fileIO : (Comp(a, {Get-,Put-,Gets:(FileDescr) -> String,Puts:(FileDescr,String) -> (),Fclose:(FileDescr) -> (),Fopen:(Mode,String) -> FileDescr |e})) {Get:() {}-> FileSystem,Put:(FileSystem) -> (),Gets{_},Puts{_},Fclose{_},Fopen{_} |e}~> a
+# sig closeFile : (File) ~> File
-fun fileIO(m) {
+# fun closeFile((=front,=rear)) {
-  handle(allowState(m)()) {
+#   (front=front ++ reverse(rear), rear=[])
-    case Gets(fd, resume) ->
+# }
-      var fsys = get();
-      var (ch, file) = readFile(lookupFile(fd, fsys));
-      put(replaceFile(fd, file, fsys)); resume(ch)
-    case Puts(fd, ch, resume) ->
-      var fsys = get();
-      var fsys' = replaceFile(fd, writeFile(ch, lookupFile(fd, fsys)), fsys);
-      put(fsys'); resume(())
-    case Fopen(mode, filename, resume) ->
-      var fsys = get();
-      var (fd, fsys') = openFile(mode, filename, fsys);
-      put(fsys'); resume(fd)
-    case Fclose(fd, resume) ->
-      var fsys = get();
-      var fsys' = replaceFile(fd, closeFile(lookupFile(fd, fsys)), fsys);
-      put(fsys'); resume(())
-  }
-}
 
-sig redirect : (Comp(a, {Puts:(FileDescr,String) -> () |e}), FileDescr) {Puts:(FileDescr,String) -> () |e}~> a
+# sig allowState : (() {Get-,Put- |e}~> a) -> () {Get:s,Put:(s) -> () |e}~> a
-fun redirect(m, fd) {
+# fun allowState(f) { (f : (() {Get:s,Put:(s) -> () |e}~> a) <- (() {Get-,Put- |e}~> a)) }
-  handle(m()) {
+
-    case Puts(_,s,resume) -> resume(puts(fd, s))
+# sig fileIO : (Comp(a, {Get-,Put-,Gets:(FileDescr) -> String,Puts:(FileDescr,String) -> (),Fclose:(FileDescr) -> (),Fopen:(Mode,String) -> FileDescr |e})) {Get:() {}-> FileSystem,Put:(FileSystem) -> (),Gets{_},Puts{_},Fclose{_},Fopen{_} |e}~> a
-  }
+# fun fileIO(m) {
-}
+#   handle(allowState(m)()) {
+#     case Gets(fd, resume) ->
+#       var fsys = get();
+#       var (ch, file) = readFile(lookupFile(fd, fsys));
+#       put(replaceFile(fd, file, fsys)); resume(ch)
+#     case Puts(fd, ch, resume) ->
+#       var fsys = get();
+#       var fsys' = replaceFile(fd, writeFile(ch, lookupFile(fd, fsys)), fsys);
+#       put(fsys'); resume(())
+#     case Fopen(mode, filename, resume) ->
+#       var fsys = get();
+#       var (fd, fsys') = openFile(mode, filename, fsys);
+#       put(fsys'); resume(fd)
+#     case Fclose(fd, resume) ->
+#       var fsys = get();
+#       var fsys' = replaceFile(fd, closeFile(lookupFile(fd, fsys)), fsys);
+#       put(fsys'); resume(())
+#   }
+# }
+
+# sig redirect : (Comp(a, {Puts:(FileDescr,String) -> () |e}), FileDescr) {Puts:(FileDescr,String) -> () |e}~> a
+# fun redirect(m, fd) {
+#   handle(m()) {
+#     case Puts(_,s,resume) -> resume(puts(fd, s))
+#   }
+# }
 
 ##
 ## Processes
@@ -331,70 +355,70 @@ fun whoami() { getenv("USER") }
 ##
 
 # Tags puts with the name of the current user.
-sig provenance : (Comp(a, {Getenv:(String) -> String,Puts:(FileDescr,String) -> () |e})) {Getenv:(String) -> String,Puts:(FileDescr,String) -> () |e}~> a
+# sig provenance : (Comp(a, {Getenv:(String) -> String,Puts:(FileDescr,String) -> () |e})) {Getenv:(String) -> String,Puts:(FileDescr,String) -> () |e}~> a
-fun provenance(m) {
+# fun provenance(m) {
-  handle(m()) {
+#   handle(m()) {
-    case Puts(fd, s, resume) ->
+#     case Puts(fd, s, resume) ->
-      var user = whoami();
+#       var user = whoami();
-      resume(do Puts(fd, user ^^ "> " ^^ s))
+#       resume(do Puts(fd, user ^^ "> " ^^ s))
-  }
+#   }
-}
+# }
 
-# An example of everything plugged together: a time-shared 'Hello World'.
+# # An example of everything plugged together: a time-shared 'Hello World'.
-sig example : () {Fork:Bool,Getenv:(String) -> String,Su:(User) -> (),Puts:(FileDescr,String) -> (),Yield:() |_}~> ()
+# sig example : () {Fork:Bool,Getenv:(String) -> String,Su:(User) -> (),Puts:(FileDescr,String) -> (),Yield:() |_}~> ()
-fun example() {
+# fun example() {
-  var pid = fork();
+#   var pid = fork();
-  var () = {
+#   var () = {
-    if (pid) redirect(fun(){puts(stdout, "dummy")}, stderr)
+#     if (pid) redirect(fun(){puts(stdout, "dummy")}, stderr)
-    else if (fork()) su(Alice)
+#     else if (fork()) su(Alice)
-    else su(Bob)
+#     else su(Bob)
-  };
+#   };
-  var user = whoami();
+#   var user = whoami();
-  puts(stdout, "Hello World!");
+#   puts(stdout, "Hello World!");
-  var uid = getenv("UID");
+#   var uid = getenv("UID");
-  echo("My UID is " ^^ uid);
+#   echo("My UID is " ^^ uid);
-  (if (amiroot()) { yield(); echo(user ^^ " is running as root.") } else ());
+#   (if (amiroot()) { yield(); echo(user ^^ " is running as root.") } else ());
-  echo("My home dir is /home/" ^^ user)
+#   echo("My home dir is /home/" ^^ user)
-}
+# }
 
-# Wiring of handlers.
+# # Wiring of handlers.
-sig init : () {Fork{_},Getenv{_},Su{_},Puts{_},Yield{_} |_}~> [String]
+# sig init : () {Fork{_},Getenv{_},Su{_},Puts{_},Yield{_} |_}~> [String]
-fun init() {
+# fun init() {
-  basicIO(fun() {
+#   basicIO(fun() {
-    schedule(fun() {
+#     schedule(fun() {
-      usermgr(Root, envs, fun() {
+#       usermgr(Root, envs, fun() {
-        provenance(example)
+#         provenance(example)
-      })
+#       })
-    })
+#     })
-  })
+#   })
-}
+# }
 
-sig example' : () {Fork:Bool,Fclose:(FileDescr) -> (),Fopen:(Mode,String) -> FileDescr,Getenv:(String) -> String,Su:(User) -> (),Puts:(FileDescr,String) -> (),Yield:() |_}~> ()
+# sig example' : () {Fork:Bool,Fclose:(FileDescr) -> (),Fopen:(Mode,String) -> FileDescr,Getenv:(String) -> String,Su:(User) -> (),Puts:(FileDescr,String) -> (),Yield:() |_}~> ()
-fun example'() {
+# fun example'() {
-  var pid = fork();
+#   var pid = fork();
-  var () = {
+#   var () = {
-    if (pid) redirect(fun(){puts(stdout, "dummy")}, stderr)
+#     if (pid) redirect(fun(){puts(stdout, "dummy")}, stderr)
-    else if (fork()) su(Alice)
+#     else if (fork()) su(Alice)
-    else su(Bob)
+#     else su(Bob)
-  };
+#   };
-  var user = whoami();
+#   var user = whoami();
-  var fd = fopen(Append, user ^^ ".txt");
+#   var fd = fopen(Append, user ^^ ".txt");
-  puts(fd, "Hello World!");
+#   puts(fd, "Hello World!");
-  var uid = getenv("UID");
+#   var uid = getenv("UID");
-  echo("My UID is " ^^ uid);
+#   echo("My UID is " ^^ uid);
-  (if (amiroot()) { yield(); echo(user ^^ " is running as root.") } else ());
+#   (if (amiroot()) { yield(); echo(user ^^ " is running as root.") } else ());
-  echo("My home dir is /home/" ^^ user);
+#   echo("My home dir is /home/" ^^ user);
-  fclose(fd)
+#   fclose(fd)
-}
+# }
 
 
-sig init' : (FileSystem) {Fclose{_},Fopen{_},Fork{_},Get{_},Getenv{_},Gets{_},Put{_},Puts{_},Su{_},Yield{_}|_}~> ((), FileSystem)
+# sig init' : (FileSystem) {Fclose{_},Fopen{_},Fork{_},Get{_},Getenv{_},Gets{_},Put{_},Puts{_},Su{_},Yield{_}|_}~> ((), FileSystem)
-fun init'(fsys) {
+# fun init'(fsys) {
-  runState(fsys, fun() {
+#   runState(fsys, fun() {
-    fileIO(fun() {
+#     fileIO(fun() {
-      schedule(fun() {
+#       schedule(fun() {
-        usermgr(Root, envs, example')
+#         usermgr(Root, envs, example')
-      })
+#       })
-    })
+#     })
-  })
+#   })
-}
+# }

code/unix2.links

@@ -680,3 +680,18 @@ fun tcphandshakeFail() {
     performTCP(tcpserver, 84, sfd, cfd)
   }
 }
+
+#
+# Grep
+#
+#sig grep : (String) {Await:Char,Yield:(Char) -> () |_}~> ()
+fun grep(str) {
+  var cs = explode(str);
+  fun match(c,cs) {
+    switch (cs) {
+      case c' :: cs' ->
+        if (c == '\n') fail()
+        if (c == c') 
+    }
+  }
+}