oi 0.0.5 → 0.1.0

raw patch · 12 files changed

+687/−315 lines, 12 filesdep +filepathdep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: filepath

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• oi.cabal +11/−5
• sample/Makefile +4/−1
• sample/cats.hs +31/−0
• sample/echo.hs +15/−10
• sample/recdircs.hs +28/−30
• sample/talk.hs +14/−12
• src/Data/OI.hs +15/−257
• src/Data/OI/Base.hs +276/−0
• src/Data/OI/Combinator.hs +98/−0
• src/Data/OI/IO.hs +57/−0
• src/Data/OI/Resource.hs +114/−0
• src/Data/OI/System.hs +24/−0

@@ -1,23 +1,29 @@ Name:			oi-Version:		0.0.5+Version:		0.1.0 Category:		Data Synopsis:		Purely Functional Lazy Interaction with the outer world Description:		This package implements a data structure and operations on it  			for making interactive program without using explicitly IO monads.+			Version 0.1.0: APIs are changed from before. Stability:		Experimental License:		BSD3 License-File:		LICENSE Author:			Nobuo Yamashita Maintainer:		nobsun@sampou.org Build-Type:		Simple-Cabal-Version:		>= 1.6+Cabal-Version:		>= 1.14  Data-dir:		sample-Data-files:		Makefile echo.hs recdircs.hs talk.hs+Data-files:		Makefile cats.hs echo.hs recdircs.hs talk.hs  Library+  Default-Language:         Haskell2010   Hs-Source-Dirs:	    src/-  Build-Depends:	    base >= 4 && < 5, parallel, comonad+  Build-Depends:	    base >= 4.5 && < 5, parallel, comonad, filepath   GHC-Options:		    -Wall -O0   Exposed-modules:	    Data.OI-+                           ,Data.OI.Base+                           ,Data.OI.Combinator+                           ,Data.OI.IO+                           ,Data.OI.Resource+                           ,Data.OI.System

@@ -1,4 +1,4 @@-EXECS = echo recdircs talk+EXECS = echo recdircs talk cats  all	: $(EXECS) @@ -9,6 +9,9 @@ 	ghc --make -O0 -threaded $< -o $@  talk	: talk.hs+	ghc --make -O0 -threaded $< -o $@++cats	: cats.hs 	ghc --make -O0 -threaded $< -o $@  clean	:

@@ -0,0 +1,31 @@+{-# LANGUAGE BangPatterns+            ,TypeOperators+  #-}+module Main where++import Data.List+import Data.OI+import Prelude as P++main :: IO ()+main = run pmain'++pmain :: (IOResult (Resource String), ([IOResult (Resource String)], [()])) :-> ()+pmain = forces . (mapR id . inFileResource "files" |/| head3s)++head3s :: [FilePath] -> ([IOResult (Resource String)], [()]) :-> [()]+head3s xs = map (unlines . takeR (3::Int)) . zipWithOI' inFileResource xs |/| zipWithOI' (iooi . P.putStrLn)++pmain' :: (IOResult (Resource String), ([IOResult (Resource String)], IOResult (Resource ()))) :-> ()+pmain' = mapR id . inFileResource "files" |/| head3s'++head3s' :: [FilePath] -> ([IOResult (Resource String)], IOResult (Resource ())) :-> ()+head3s' xs = forceResult . (map (unlines . ("==========":) . takeR (3::Int)) . zipWithOI' inFileResource xs |/| outFileResource "/dev/pts/3")++forceResult :: IOResult (Resource a) -> ()+forceResult (Success s) = forces $ map force $ stream s+forceResult (Failure e) = error e++main' :: IO ()+main' = readFile "files"+    >>= mapM readFile . lines >>= mapM_  putStr . intersperse "==========" . map (unlines . take 3 . lines)

@@ -1,15 +1,17 @@-{-# LANGUAGE TypeOperators-  #-}+{-# LANGUAGE TypeOperators #-} module Main where -import Data.OI+import Data.OI hiding (isEOF)  import Data.Char import System.IO  main :: IO ()-main = do { [] <- run $ puts |<| gets; return () }+main = run $ pmain1 +pmain0 = forces . mapOI echo+pmain1 = forces . echos+ eof :: Int eof = -1 @@ -19,18 +21,21 @@ putc :: Char -> () :-> () putc = iooi . putChar +putc' :: Int -> () :-> ()+putc' (-1) = const ()+putc' c    = iooi (putChar (chr c))  gets :: [Int] :-> String gets = map chr . takeWhile (eof /=) . mapOI getc  puts :: String -> [()] :-> [()]-puts s = dropWhile (()==) . snd . zipWithOI' putc s--choice :: a -> a -> Bool -> a-choice t f c = if c then t else f+puts = zipWithOI' putc  getchar :: IO Int getchar = choice (return (-1)) (return . ord =<< getChar) =<< isEOF  -puts' :: String -> [()] :-> ()-puts' = sequenceOI . map putc+puts' :: String -> OI [()] -> ()+puts' = seqsOI' . map putc++echo  = getc |/| putc'+echos = gets |/| puts

@@ -1,45 +1,43 @@-{-# LANGUAGE TypeOperators #-}+{-# LANGUAGE TupleSections  +            ,PostfixOperators+            ,TypeOperators+            #-} module Main where -import Data.OI-+import Control.Arrow import Data.List-+import Data.OI import System.FilePath import System.Directory-import System.Environment  main :: IO ()-main = do { args <- getArgs-          ; case args of-              []  -> print =<< run (pmain ".")-              a:_ -> print =<< run (pmain a)-          }+main = run pmain -pmain :: FilePath -> [(Bool, [FilePath])] :-> [FilePath]-pmain = recDirectoryContents+pmain :: (([String], [(Bool, IOResult [FilePath])]), ()) :-> ()+pmain = ((args |> head) |/| getDirCsRec) |> snd |/| putStrOI . unlines +putStrOI :: String -> () :-> ()+putStrOI = iooi . putStr+ isDirectory :: FilePath -> Bool :-> Bool isDirectory = iooi . doesDirectoryExist -directoryContents :: FilePath -> [FilePath] :-> [FilePath]-directoryContents f = map (f </>) . filter (`notElem` [".",".."])-                    . iooi (getDirectoryContents f)+getDirCs' :: FilePath -> IOResult [FilePath] :-> [FilePath]+getDirCs' fp = iooi'  (getDirectoryContents fp) |> valid -recDirectoryContents :: FilePath -> [(Bool,[FilePath])] :-> [FilePath]-recDirectoryContents root = fst . recdircs root+valid :: IOResult [FilePath] -> [FilePath]+valid (Success fps) = filter (flip notElem [".",".."]) fps+valid _             = [] -recdircs :: FilePath -> [(Bool,[FilePath])] :-> ([FilePath], OI [(Bool,[FilePath])])-recdircs t r = case deList r of-  Just (rbfps, rbfpss) -> case deTuple rbfps of-    (rb,rfps) -> case isDirectory t rb of-      False -> ([t],rbfpss)-      True  -> let { ts = directoryContents t rfps-                   ; (rs,tss) = mapAccumL acc rbfpss ts-                   ; acc r' fp = swap (recdircs fp r')-                   } in -               (concat tss, rs)-  _ -> error $ "recdircs: perhaps `"++t++"' is not found"+getDirCs :: FilePath -> (Bool, IOResult [FilePath]) :-> (Bool, [FilePath])+getDirCs fp = isDirectory fp+          |/| choice (((,) True) . map (fp </>) . getDirCs' fp) (const (False, [fp])) -swap :: (a,b) -> (b,a)-swap (x,y) = (y,x)+getDirCsRec ::  FilePath+            ->  [(Bool, IOResult [FilePath])]+            :-> (OI [(Bool, IOResult [FilePath])], [FilePath])+getDirCsRec fp oss = case deList oss of+  Just (o,os) -> case getDirCs fp o of+    (False, fps) -> (os,fps)+    (True,  fps) -> second concat $ mapAccumL (flip getDirCsRec) os fps+  _           -> error $ "getDirCs: perhaps `"++ fp ++"' is not found"

@@ -3,6 +3,8 @@ module Main where  import Data.OI++import Control.Concurrent import Control.Parallel import System.Environment @@ -13,23 +15,23 @@  pmain ::  (FilePath,FilePath)       ->  (FilePath,FilePath)-      ->  ((String, [String], ()), (String, [String], ()))-      :-> ()-pmain (kbd1,scr1) (kbd2,scr2)-  = uncurry par . (talk "Alice" (kbd1,scr1) |><| talk "Bob" (kbd2,scr2))+      ->  ((String, [String], ()), (String, [String], ())) :-> ()+pmain devs1 devs2 = uncurry par . (talk "Alice" devs1 |><| talk "Bob" devs2) -talk :: String                   -- Talker's name-     -> (FilePath,FilePath)      -- (Talker's keybord, Talker's screen)-     -> [String]                 -- Messages from the other end-     -> OI (String,[String],())  -- (Talker's input,Merged messages, Process result)-     -> ([String],())            -- (Messages to the other end, Process result)-talk name (kbd,scr) msg r = (ins,showscr scr (mergeOI ins msg os) us)+talk :: String                -- Talker's name+     -> (FilePath,FilePath)   -- (Talker's keybord, Talker's screen)+     -> (String,[String],())  -- (Talker's input,Merged messages, Process result)+    :-> [String]             -- Messages from the other end+     -> ([String],())        -- (Messages to the other end, Process result)+talk name (kbd,scr) r msg = (ins,showscr scr (mergeOI ins msg os) us)   where     (is,os,us) = deTriple r     ins = map ((name ++ ": ")++) $ lines $ readkbd kbd is -readkbd :: FilePath -> String :-> String+readkbd :: FilePath -> OI String -> String readkbd = iooi . readFile -showscr :: FilePath -> [String] -> () :-> ()+showscr :: FilePath -> [String] -> OI () -> () showscr s = iooi . writeFile s . unlines++mergeOI = (iooi .) . mergeIO

@@ -1,265 +1,23 @@-{-# LANGUAGE TypeOperators-            ,ScopedTypeVariables-            ,PostfixOperators-            ,NoMonomorphismRestriction-            ,BangPatterns-  #-}-{-# OPTIONS_GHC -fno-cse #-} -- | -- Module      : Data.OI--- Copyright   : (c) Nobuo Yamashita 2011+-- Copyright   : (c) Nobuo Yamashita 2011-2012 -- License     : BSD3 -- Author      : Nobuo Yamashita -- Maintainer  : nobsun@sampou.org -- Stability   : experimental ----- Comonadic data type for representing interaction with outer world.----module Data.OI (-  -- * Data type-  OI- ,(:->)--  -- * Converter an IO to an interaction function- ,iooi--  -- * Drive an interaction function- ,run--  -- * Primitive operators on the interaction data- ,(=:)- ,(?)- ,(#)--  -- * Category class methods on (:->)- ,idA- ,(<.>)--  -- * Arrow class methods on (:->)- ,arrA- ,firstA--  -- * Embeding interaction data in data structure- ,deTuple- ,deTriple- ,deList--  -- * Interaction combinators- ,(>|>|)- ,(|<|<)- ,(>|->|)- ,(|-|)- ,(|<|)- ,(|>|)- ,(<|)- ,(|>)- ,(|><|)- ,mapOI- ,mapOI'- ,zipWithOI- ,zipWithOI'- ,sequenceOI- ,sequenceOI'- ,mergeOI-- ) where--import Control.Applicative-import Control.Concurrent-import Control.Parallel-import Control.Comonad-import System.IO.Unsafe--data OI a = OI { variable :: LeftValueOf (IO a), value :: a }-type a :-> b = OI a -> b---- | Binding operator-(=:)         ::  a -> a :-> a-x =: OI v y  =   assign ix v `pseq` y-                 where ix = return x---- | Dereference operator-(?)           ::  a :-> a-(?) (OI _ x)  =   x---- | Reference operator-(#)    ::  a -> OI a-(#) x  =   OI { variable = reference (return x), value = x }------instance Functor OI where-  fmap f = (#) . f . (?)--instance Monad OI where-  return = (#)-  x >>= f = f (x?)--instance Applicative OI where-  pure  = (#)-  (<*>) = (. (?)) . ((#) .) . (?)--instance Extend OI where-  duplicate = (#)--instance Comonad OI where-  extract = (?)------idA :: a :-> a-idA = (?)--(<.>) :: (b :-> c) -> (a :-> b) -> (a :-> c)-f <.> g = f . (#) . g------arrA :: (a -> b) -> (a :-> b)-arrA f = f . (?)--firstA :: (a :-> b) -> (a,c) :-> (b,c)-firstA f ac = case deTuple ac of (x,z) -> (f x, (z?))---- | Embed interactions into tuple-deTuple :: OI (a,b) -> (OI a,OI b)-deTuple (OI vxy ~(x,y)) = assign io vxy `pseq` (OI vx x, OI vy y)- where-  vx     = new0 ()-  vy     = new0 ()-  io     = (,) <$> unsafeInterleaveIO (dereference vx) <*> unsafeInterleaveIO (dereference vy)---- | Embed interactions into triple-deTriple :: (a,b,c) :-> (OI a,OI b,OI c)-deTriple (OI vxyz ~(x,y,z)) = assign io vxyz `pseq` (OI vx x, OI vy y, OI vz z)- where-  vx     = new0 ()-  vy     = new0 ()-  vz     = new0 ()-  io     = (,,) <$> unsafeInterleaveIO (dereference vx)-                <*> unsafeInterleaveIO (dereference vy)-                <*> unsafeInterleaveIO (dereference vz)---- | Embed interactions into list-deList :: [a] :-> Maybe (OI a, OI [a])-deList (OI vxxs xxs)- = assign io vxxs-   `pseq` case xxs of-      x:xs -> Just (OI vx x, OI vxs xs)-      _    -> Nothing-   where-     vx  = new0 ()-     vxs = new0 ()-     io  = (:) <$> (unsafeInterleaveIO (dereference vx)) <*> (unsafeInterleaveIO (dereference vxs))---- | Connect two interactions into an interaction--(|<|<) :: (c -> d :-> e) -> (a -> b :-> c) -> (a -> (b,d) :-> e)-(f |<|< g) a bd = case deTuple bd of (b,d) -> f (g a b) d--(>|>|) :: (a -> b :-> c) -> (c -> d :-> e) -> (a -> (b,d) :-> e)-(>|>|) = flip (|<|<)--(>|->|) :: (a -> b :-> c) -> (a' -> b' :-> c') -> ((a,a') -> (b,b') :-> (c,c'))-(f >|->| g) (a,a') bb' = case deTuple bb' of (b,b') -> (f a b, g a' b')--(|-|) :: (a :-> b) -> (a' :-> b') -> (a,a') :-> (b,b')-(f |-| g) aa' = case deTuple aa' of (a,a') -> (f a, g a')--(|<|)  ::  (b -> c :-> d) -> (a :-> b) -> (a,c) :-> d-(f |<| g) ac = case deTuple ac of (a,c) -> f (g a) c--(|>|)  :: (a :-> b) -> (b -> c :-> d) -> (a,c) :-> d-(|>|) = flip (|<|)--infixr 1 |<|-infixl 1 |>|--(|>) :: (a :-> b) -> (b -> c) -> (a :-> c)-(|>) = flip (.)--(<|) :: (b -> c) -> (a :-> b) -> (a :-> c)-(<|) = (.)--(|><|) :: (q -> a :-> (p,c)) -> (p -> b :-> (q,d)) -> ((a,b)  :-> (c,d))-(f |><| g) rab = case deTuple rab of-  (ra,rb) -> (c,d)-   where -     (x,c) = f y ra-     (y,d) = g x rb----- | Map interaction function on an interaction list-mapOI :: (a :-> b) -> [a] :-> [b]-mapOI f xxs = case deList xxs of-  Just (x,xs) -> f x : mapOI f xs-  _           -> []---- | Map interaction function on an interaction list (return results and remainings)-mapOI' :: (a :-> b) -> [a] :-> (OI [a],[b])-mapOI' f xxs = case deList xxs of-  Just (x,xs) -> (zs, f x:ys)-                 where (zs,ys) = mapOI' f xs-  _           -> (xxs,[])---- | Zip a list and an interaction list-zipWithOI :: (a -> b :-> c) -> [a] -> [b] :-> [c]-zipWithOI _ [] _  = []-zipWithOI f (x:xs) yys = case deList yys of-  Just (y,ys) -> f x y : zipWithOI f xs ys-  _           -> []---- | Zip a list and an interaction list (return results and remainings)-zipWithOI' :: (a -> b :-> c) -> [a] -> [b] :-> (OI [b],[c])-zipWithOI' _ []     yys = (yys,[])-zipWithOI' f (x:xs) yys = case deList yys of-  Just (y,ys) -> case zipWithOI' f xs ys of ~(rs,zs) -> (rs,f x y : zs)-  _           -> (yys,[])---- | Sequencing interaction functions-sequenceOI :: [a :-> b] -> [a] :-> ()-sequenceOI (f:fs) xxs = case deList xxs of-  Just (x,xs) -> f x `pseq` sequenceOI fs xs-  Nothing     ->  ()-sequenceOI [] _ = ()---- | Sequencing interaction functions (return remainings)-sequenceOI' :: [a :-> b] -> [a] :-> OI [a]-sequenceOI' (f:fs) xxs = case deList xxs of-  Just (x,xs) -> f x `pseq` sequenceOI' fs xs-  Nothing     ->  xxs-sequenceOI' [] xxs = xxs---- | Merging two lists by using oracles-mergeOI :: [a] -> [a] -> [a] :-> [a]-mergeOI xs ys = iooi $ mergeIO xs ys---- | Convert an IO to an interaction function-iooi            ::  IO a -> (a :-> a)-iooi io (OI vix x)  =   assign io vix `pseq` x---- | Drive an interaction function-run        ::  (a :-> b) -> IO b-run pmain  =   do { vx <- newEmptyMVar-                  ; x  <- unsafeInterleaveIO (dereference vx)-                  ; return $! pmain (OI vx x)-                  }---- --type LeftValueOf = MVar--new0 :: () -> LeftValueOf a-new0 () = unsafePerformIO $ newEmptyMVar--reference :: a -> LeftValueOf a-reference = unsafePerformIO . newMVar--dereference :: LeftValueOf a -> a-dereference = unsafePerformIO . readMVar+module Data.OI +  (+  -- * Export modules+   module Data.OI.Base+  ,module Data.OI.Combinator+  ,module Data.OI.IO+  ,module Data.OI.Resource+  ,module Data.OI.System+  ) where -assign :: a -> LeftValueOf a -> a-assign !x v = unsafePerformIO -            $ do { s <- tryPutMVar v x-                 ; if s then return x else readMVar v-                 }+import Data.OI.Base+import Data.OI.Combinator+import Data.OI.IO+import Data.OI.Resource+import Data.OI.System

@@ -0,0 +1,276 @@+{-# LANGUAGE TypeOperators+            ,ScopedTypeVariables+            ,PostfixOperators+            ,NoMonomorphismRestriction+            ,BangPatterns+  #-}+{-# OPTIONS_GHC -fno-cse #-}+-- |+-- Module      : Data.OI.Base+-- Copyright   : (c) Nobuo Yamashita 2011-2012+-- License     : BSD3+-- Author      : Nobuo Yamashita+-- Maintainer  : nobsun@sampou.org+-- Stability   : experimental+--+module Data.OI.Base+  (+  -- * Interaction datatypes+   OI+  ,(:->)+  -- * Drive an interaction+  ,run+  -- * Primitive operators on OI+  ,(=:)+  ,(??)+  -- * Splitter against OI+  ,dePair+  ,deList+  ,deTriple+  ,deTuple4+  ,deTuple5+  ,deTuple6+  ,deTuple7+  ,deLeft+  ,deRight+  -- * Convert IO to interaction+  ,IOResult(..)+  ,iooi+  ,iooi'+   -- * Forcing+  ,forces+  ,force+  ,split+  )+  where++import Control.Applicative+import Control.Category+import Control.Comonad+import Control.Exception+import Control.Monad+import Control.Concurrent+import Control.Parallel+import System.IO.Unsafe+import Prelude hiding ((.),id,catch)++-- | Datatype for intermediating interaction+data OI a = OI (LeftValueOf a) (RightValueOf a)++-- | Interaction type+type a :-> b = OI a -> b+infixr 0 :->++instance Functor OI where+  fmap f = (##) . f . (??)++instance Monad OI where+  return = (##)+  (>>=)  = flip ($) . (??)++instance Extend OI where+  duplicate = (##)++instance Comonad OI where+  extract = (??)++-- | Assign operator+(=:) :: a -> OI a -> a+(=:) !x (OI var val) = put (return x) var `pseq` val++-- | Dereference operator+(??) :: OI a -> a+(??) (OI _ val) = val++-- | Reference operator+(##) :: a -> OI a+(##) x = OI (unsafeNew x) x+++-- | Decomposer for pair+dePair :: OI (a,b) -> (OI a, OI b)+dePair (OI vxy ~(x,y)) = put io vxy `pseq` (OI vx x, OI vy y)+  where+    vx  = new x+    vy  = new y+    io  = (,) <$> lazy (deref vx) <*> lazy (deref vy)++-- | Decomposer for list+deList :: OI [a] -> Maybe (OI a, OI [a])+deList (OI vxxs xxs) = put io vxxs+  `pseq` case xxs of+     x:xs -> Just (OI vx x, OI vxs xs)+     _    -> Nothing+  where+    vx  = new (undefined :: a)+    vxs = new (undefined :: [a])+    io = (:) <$> lazy (deref vx) <*> lazy (deref vxs)++-- | Decomposer for triple+deTriple :: OI (a,b,c) -> (OI a, OI b, OI c)+deTriple (OI vxyz ~(x,y,z)) = put io vxyz+  `pseq` (OI vx x, OI vy y, OI vz z)+  where+    vx  = new x+    vy  = new y+    vz  = new z+    io  = (,,) <$> lazy (deref vx) +               <*> lazy (deref vy)+               <*> lazy (deref vz)++-- | Decomposer for 4-tuple+deTuple4 :: OI (a,b,c,d) -> (OI a, OI b, OI c, OI d)+deTuple4 (OI vwxyz ~(w,x,y,z)) = put io vwxyz+  `pseq` (OI vw w, OI vx x, OI vy y, OI vz z)+  where+    vw  = new w+    vx  = new x+    vy  = new y+    vz  = new z+    io  = (,,,) +      <$> lazy (deref vw) +      <*> lazy (deref vx) +      <*> lazy (deref vy)+      <*> lazy (deref vz)++-- | Decomposer for 5-tuple+deTuple5 :: OI (a,b,c,d,e) -> (OI a, OI b, OI c, OI d, OI e)+deTuple5 (OI vvwxyz ~(v,w,x,y,z)) = put io vvwxyz+  `pseq` (OI vv v, OI vw w, OI vx x, OI vy y, OI vz z)+  where+    vv  = new v+    vw  = new w+    vx  = new x+    vy  = new y+    vz  = new z+    io  = (,,,,) +      <$> lazy (deref vv) +      <*> lazy (deref vw) +      <*> lazy (deref vx) +      <*> lazy (deref vy)+      <*> lazy (deref vz)++-- | Decomposer for 6-tuple+deTuple6 :: OI (a,b,c,d,e,f) -> (OI a, OI b, OI c, OI d, OI e, OI f)+deTuple6 (OI vuvwxyz ~(u,v,w,x,y,z)) = put io vuvwxyz+  `pseq` (OI vu u, OI vv v, OI vw w, OI vx x, OI vy y, OI vz z)+  where+    vu  = new u+    vv  = new v+    vw  = new w+    vx  = new x+    vy  = new y+    vz  = new z+    io  = (,,,,,) +      <$> lazy (deref vu) +      <*> lazy (deref vv) +      <*> lazy (deref vw) +      <*> lazy (deref vx) +      <*> lazy (deref vy)+      <*> lazy (deref vz)++-- | Decomposer for 7-tuple+deTuple7 :: OI (a,b,c,d,e,f,g) -> (OI a, OI b, OI c, OI d, OI e, OI f, OI g)+deTuple7 (OI vtuvwxyz ~(t,u,v,w,x,y,z)) = put io vtuvwxyz+  `pseq` (OI vt t, OI vu u, OI vv v, OI vw w, OI vx x, OI vy y, OI vz z)+  where+    vt  = new t+    vu  = new u+    vv  = new v+    vw  = new w+    vx  = new x+    vy  = new y+    vz  = new z+    io  = (,,,,,,) +      <$> lazy (deref vt) +      <*> lazy (deref vu) +      <*> lazy (deref vv) +      <*> lazy (deref vw) +      <*> lazy (deref vx) +      <*> lazy (deref vy)+      <*> lazy (deref vz)++deLeft  :: OI (Either a b) -> Either (OI a) (OI b)+deRight :: OI (Either a b) -> Either (OI a) (OI b)++deLeft (OI ve ~(Left a)) = put io ve `pseq` Left (OI vl a)+  where+    vl = new a+    io = Left <$> lazy (deref vl)++deRight (OI ve ~(Right b)) = put io ve `pseq` Right (OI vr b)+  where+    vr = new b+    io = Right <$> lazy (deref vr)++-- | Drive interaction+run :: (OI a -> b) -> IO b+run pmain = do +  { v <- newEmptyMVar+  ; x <- lazy (deref v)+  ; return $! pmain (OI v x)+  }++-- | Convert IO to interaction+iooi :: IO a -> OI a -> a+iooi io (OI var val) = put io var `pseq` val++data IOResult a = Success a | Failure String++instance Functor IOResult where+  fmap f (Success x) = Success (f x)+  fmap _ (Failure s) = Failure s++instance (Show a) => Show (IOResult a) where+  show (Success x) = show x+  show (Failure s) = "Failure: "++s++iooi' :: IO a -> OI (IOResult a) -> IOResult a+iooi' io (OI var val)+  = put ( do { r <- try io+             ; case r of { Left  e -> return $ Failure (show (e :: SomeException))+                         ; Right a -> return $ Success a }}+        ) var `par` val++-- | Forcing utilities++forces :: [()] -> ()+forces = force . dropWhile (()==)++force :: a -> ()+force x = x `pseq` ()++split :: a -> (a,())+split x = x `pseq` (x,())++-- Wrapper++type LeftValueOf  a = MVar (IO a)+type RightValueOf a = a++new :: a -> LeftValueOf a+new   = unsafeNew++deref :: MVar a -> a+deref = unsafeDeref++put   :: a -> MVar a -> a+put   = unsafePut++lazy :: IO a -> IO a+lazy = unsafeInterleaveIO++-- Unsafe primitive++unsafeNew :: a -> LeftValueOf a+unsafeNew _ = unsafePerformIO newEmptyMVar++unsafeDeref :: MVar a -> a+unsafeDeref = unsafePerformIO . readMVar++unsafePut :: a -> MVar a -> a+unsafePut x v = unsafePerformIO $ do+              { s <- tryPutMVar v x+              ; if s then return x else readMVar v+              }+

@@ -0,0 +1,98 @@+-- |+-- Module      : Data.OI.Combinator+-- Copyright   : (c) Nobuo Yamashita 2011-2012+-- License     : BSD3+-- Author      : Nobuo Yamashita+-- Maintainer  : nobsun@sampou.org+-- Stability   : experimental+--+{-# LANGUAGE TypeOperators+            ,BangPatterns+  #-}+module Data.OI.Combinator+  (+   -- * Utility functions+   (|>)+  ,choice+   -- * Interaction Combinators+  ,(|:|)+  ,(|>|),(|/|)+  ,(|><|)+   -- * Iteration+  ,mapOI+  ,zipWithOI+  ,zipWithOI'+   -- * Conditional Choice+  ,ifOI+  ,choiceOI+   -- * Sequencing+  ,seqsOI+  ,seqsOI'+  ) where++import Data.OI.Base++(|>) :: (a -> b) -> (b -> c) -> (a -> c)+(|>) = flip (.)++choice :: a -> a -> Bool -> a+choice t f c = if c then t else f++-- | Connect two interactions into an interaction++infixl 3 |:|+infixl 2 |>|,|/|+infixl 1 |><|++(|:|) :: (a :-> c) -> (b :-> d) -> ((a,b) :-> (c,d))+(f |:| g) o = case dePair o of (a,b) -> (f a, g b)++(|>|) :: (a :-> (p,c)) -> (b :-> (p -> d)) -> ((a,b) :-> (c,d))+(f |>| g) o = case dePair o of (a,b) -> (c, g b p) where (p,c) = f a++(|/|) :: (a :-> c) -> (c -> (b :-> d)) -> ((a,b) :-> d)+(f |/| g) o = case dePair o of (a,b) -> g (f a) b++(|><|) :: (a :-> (p -> (q,c)))+       -> (b :-> (q -> (p,d)))+       -> ((a,b) :-> (c,d))+(f |><| g) o = case dePair o of+  (a,b) -> (c,d) where (q,c) = f a p; (p,d) = g b q++-- | Iteration++mapOI :: (a :-> b) -> ([a] :-> [b])+mapOI f os = case deList os of +  Just (x,xs) -> f x : mapOI f xs+  _           -> []++zipWithOI :: (a :-> (b -> c)) -> ([a] :-> ([b] -> [c]))+zipWithOI _ _  [] = []+zipWithOI f os (b:bs) = case deList os of+  Just (x,xs) -> f x b : zipWithOI f xs bs+  _          -> []++zipWithOI' :: (a -> (b :-> c)) -> ([a] -> ([b] :-> [c]))+zipWithOI' = flip . zipWithOI . flip++-- | Conditional branching++ifOI :: Bool -> (a :-> c) -> (b :-> c) -> (Either a b :-> c)+ifOI True  t _ o = case deLeft o of+  Left x  -> t x+  _       -> error "ifOI: Left expected but Right"+ifOI False _ e o = case deRight o of+  Right y -> e y+  _       -> error "ifOI: Right expected but Left"++choiceOI :: (a :-> c) -> (b :-> c) -> Bool -> (Either a b :-> c)+choiceOI = flip . flip ifOI++-- | Sequencing+seqsOI :: [a] :-> ([a :-> b] -> ())+seqsOI os is = case dropWhile (()==) $ map force $ zipWithOI (flip id) os is of+  [] -> ()+  _  -> error "seqsOI: Impossible!"++seqsOI' :: [a :-> b] -> ([a] :-> ())+seqsOI' = flip seqsOI

@@ -0,0 +1,57 @@+{-# LANGUAGE TypeOperators #-}+-- |+-- Module      : Data.OI.IO+-- Copyright   : (c) Nobuo Yamashita 2011-2012+-- License     : BSD3+-- Author      : Nobuo Yamashita+-- Maintainer  : nobsun@sampou.org+-- Stability   : experimental+--+module Data.OI.IO+  (+  -- * I/O oprations+   openFile+  ,hIsClosed+  ,hIsEOF+  ,hGetLine+  ,hClose+  ,hPutStrLn+  ,isEOF+  ,getLine+  ,putStrLn+  ) where++import Data.OI.Base+import System.IO (IOMode(..),Handle)+import qualified System.IO as IO+import System.FilePath+import Prelude hiding (getLine,putStrLn)++type a :=> b = OI (IOResult a) -> IOResult b++openFile :: FilePath -> IOMode -> Handle :=> Handle+openFile = (iooi' .) . IO.openFile++hIsClosed :: IO.Handle -> Bool :=> Bool+hIsClosed = iooi' . IO.hIsClosed++hIsEOF :: IO.Handle -> Bool :=> Bool+hIsEOF = iooi' . IO.hIsEOF++hGetLine :: IO.Handle -> String :=> String+hGetLine = iooi' . IO.hGetLine++hClose :: IO.Handle -> () :=> ()+hClose = iooi' . IO.hClose++hPutStrLn :: IO.Handle -> String -> () :=> ()+hPutStrLn = (iooi' .) . IO.hPutStrLn++isEOF :: Bool :=> Bool+isEOF = iooi' IO.isEOF++getLine :: String :=> String+getLine = iooi' IO.getLine++putStrLn :: String -> () :=> ()+putStrLn = iooi' . IO.putStrLn

@@ -0,0 +1,114 @@+{-# LANGUAGE TypeOperators #-}+-- |+-- Module      : Data.OI.Resource+-- Copyright   : (c) Nobuo Yamashita 2011-2012+-- License     : BSD3+-- Author      : Nobuo Yamashita+-- Maintainer  : nobsun@sampou.org+-- Stability   : experimental+--+module Data.OI.Resource+  (+  -- * Resource type+   Resource(..)+  -- * File resource+  ,inFileResource+  ,outFileResource+  -- * Resource handlers+  ,mapR+  ,mapR'+  ,filterR+  ,takeR+  ,takeR'+  ,takeWhileR+  ) where++import Control.Exception+import Data.OI.Base+import System.IO (IOMode(..))+import qualified System.IO as IO+import System.IO.Unsafe+import Prelude hiding (readFile, writeFile)++data Resource a = Resource { release :: (), stream :: [IOResult a] }++instance (Show a) => Show (Resource a) where+  show r = show (stream r)++mapR :: (a -> b) -> IOResult (Resource a) -> [b]+mapR f (Success res) = mapR' f res+mapR _ _             = []++mapR' :: (a -> b) -> Resource a -> [b]+mapR' f (Resource r (Success x:xs)) = f x : mapR' f (Resource r xs)+mapR' _ (Resource r _)              = case r of () -> []++filterR :: (a -> Bool) -> IOResult (Resource a) -> [a]+filterR p (Success res) = filterR' p res+filterR _ _             = []++filterR' :: (a -> Bool) -> Resource a -> [a]+filterR' p (Resource r (Success x:xs))+ | p x       = x : filterR' p (Resource r xs)+ | otherwise = filterR' p (Resource r xs)+filterR' _ (Resource r _) = case r of () -> []++takeR :: Integral i => i -> IOResult (Resource a) -> [a]+takeR i (Success res) = takeR' i res+takeR _ _ = []++takeR' :: Integral i => i -> Resource a -> [a]+takeR' i (Resource r (Success x:xs)) | i > 0 = x : takeR' (i-1) (Resource r xs)+takeR' _ (Resource r _)                      = case r of () -> []++takeWhileR :: (a -> Bool) -> IOResult (Resource a) -> [a]+takeWhileR p (Success res) = takeWhileR' p res+takeWhileR _ _             = []++takeWhileR' :: (a -> Bool) -> Resource a -> [a]+takeWhileR' p (Resource r (Success x:xs)) | p x = x : takeWhileR' p (Resource r xs)+takeWhileR' _ _                                 = []++inFileResource :: FilePath -> IOResult (Resource String) :-> IOResult (Resource String)+inFileResource = iooi' . readFileIO++readFileIO :: FilePath -> IO (Resource String)+readFileIO fp = do+  { h <- lazy $ IO.openFile fp ReadMode+  ; r <- lazy $ IO.hClose h+  ; s <- lazy $ getlines r h+  ; return (Resource { release = r, stream = s })+  }+  where+    getlines r hdl = do +      { el <- lazy $ try $ IO.hGetLine hdl+      ; case el of+          Left  e -> case r of () -> return [Failure $ show $ (e :: SomeException)]+          Right l -> do { ls <- lazy $ getlines r hdl+                        ; return (Success l:ls)+                        }+      }++outFileResource :: FilePath -> [String] -> IOResult (Resource ()) :-> IOResult (Resource ())+outFileResource = (iooi' .) . writeFileIO++writeFileIO :: FilePath -> [String] -> IO (Resource ())+writeFileIO fp lls = do+  { h <- lazy $ IO.openFile fp WriteMode+  ; r <- lazy $ IO.hClose h+  ; s <- lazy $ putlines r h lls+  ; return (Resource { release = r, stream = s })+  }+  where+    putlines r hdl []  = IO.hFlush hdl >> case r of () -> return []+    putlines r hdl (l:ls) = do +      { eu <- lazy $ try $ IO.hPutStrLn hdl l+      ; case eu of+          Left  e -> case r of () -> return [Failure $ show $ (e :: SomeException)]+          Right u -> do { us <- lazy $ putlines r hdl ls+                        ; return (Success u:us)+                        }+      }++lazy :: IO a -> IO a+lazy = unsafeInterleaveIO

@@ -0,0 +1,24 @@+{-# LANGUAGE TypeOperators+  #-}++module Data.OI.System +  (+   args+  ,progName+  ,environment+  )+ where++import System.Environment+import Data.OI.Base++args :: [String] :-> [String]+args = iooi getArgs++progName :: String :-> String+progName = iooi getProgName++environment :: [(String, String)] :-> [(String, String)]+environment = iooi getEnvironment++