oi 0.2.1.0 → 0.3.1

raw patch · 16 files changed

+252/−208 lines, 16 filesdep +SafeSemaphoredep +directory

Dependencies added: SafeSemaphore, directory

Files

• oi.cabal +4/−3
• sample/Makefile +4/−7
• sample/cats.hs +38/−0
• sample/cats2.hs +37/−0
• sample/catsIO.hs +0/−35
• sample/catsLIO.hs +0/−45
• sample/catsOI.hs +0/−38
• sample/catsSIO.hs +0/−40
• sample/echo.hs +33/−22
• sample/morec.hs +29/−0
• sample/recdircs.hs +4/−0
• sample/talk.hs +0/−3
• src/Data/OI.hs +2/−0
• src/Data/OI/Combinator.hs +4/−12
• src/Data/OI/Internal.hs +10/−3
• src/Data/OI/Merge.hs +87/−0

@@ -1,5 +1,5 @@ Name:			oi-Version:		0.2.1.0+Version:		0.3.1 Category:		Data Synopsis:		Library for purely functional lazy interactions with the outer world. Description:		This package implements a data structure and operations on it for writing interactive program with no imperative flavor of IO monads.@@ -15,12 +15,12 @@ Cabal-Version:		>= 1.14  Data-dir:		sample-Data-files:		Makefile catsSIO.hs catsLIO.hs catsIO.hs catsOI.hs echo.hs recdircs.hs talk.hs+Data-files:		Makefile cats.hs cats2.hs echo.hs morec.hs recdircs.hs talk.hs  Library   Default-Language:         Haskell2010   Hs-Source-Dirs:	    src/-  Build-Depends:	    base >= 4.5 && < 5, parallel, comonad >= 3, filepath+  Build-Depends:	    base >= 4.5 && < 5, parallel, comonad >= 3, filepath, directory, SafeSemaphore   GHC-Options:		    -Wall -O0   Exposed-modules:	    Data.OI                            ,Data.OI.Internal@@ -28,6 +28,7 @@                            ,Data.OI.Force                            ,Data.OI.IFun                            ,Data.OI.IO+                           ,Data.OI.Merge                            ,Data.OI.Resource                            ,Data.OI.System 

@@ -1,4 +1,4 @@-EXECS = echo recdircs talk catsSIO catsIO catsLIO catsOI+EXECS = echo recdircs talk cats cats2 morec  all	: $(EXECS) @@ -11,16 +11,13 @@ talk	: talk.hs 	ghc --make -O0 -threaded $< -o $@ -catsIO	: catsIO.hs-	ghc --make -O0 -threaded $< -o $@--catsSIO	: catsSIO.hs+cats	: cats.hs 	ghc --make -O0 -threaded $< -o $@ -catsLIO	: catsLIO.hs+cats2	: cats2.hs 	ghc --make -O0 -threaded $< -o $@ -catsOI	: catsOI.hs+morec	: morec.hs 	ghc --make -O0 -threaded $< -o $@  clean	:

@@ -0,0 +1,38 @@+{-# LANGUAGE TypeOperators #-}+module Main where++import Data.OI hiding (openFile)+import System.IO (IOMode (..), Handle)+import qualified System.IO as IO+import Prelude hiding (readFile, writeFile)++main :: IO ()+main = runInteraction pmain++pmain +  :: (([String],Either ((Handle, String), [(Handle, String)]) [(Handle, String)]), (Handle, ()))+  :-> ()+pmain = args +    |/| choiceOIOn (const $ lines . readFile "files" |/| zipWithOI readFile) +                   (zipWithOI readFile)+                   null+    |/| writeFile "output.txt" . concatMap textproc++textproc :: String -> String+textproc = id -- unlines . take 1 . lines++readFile :: FilePath -> (Handle, String) :-> String+readFile f      = openFile f ReadMode   |/| hGetContents++writeFile :: FilePath -> String -> (Handle, ()) :-> ()+writeFile f cs  = openFile f WriteMode  |/| flip hPutStr cs++openFile :: FilePath -> IOMode -> Handle :-> Handle+openFile     = (iooi .) . IO.openFile++hGetContents :: Handle -> String :-> String+hGetContents = iooi . IO.hGetContents++hPutStr :: Handle -> String -> () :-> ()+hPutStr      = (iooi .) . IO.hPutStr+

@@ -0,0 +1,37 @@+{-# LANGUAGE TypeOperators #-}+module Main where++import Control.Applicative ((<*>))+import Data.OI hiding (openFile)+import System.IO (IOMode (..), Handle)+import qualified System.IO as IO+import Prelude hiding (readFile, writeFile)++main :: IO ()+main = runInteraction pmain++pmain +  :: (([String],Either ((Handle, String), [(Handle, String)]) [(Handle, String)]), (Handle, ()))+  :-> ()+pmain = args +    |/| ((choiceOI (lines . readFile "files" |/| zipWithOI readFile) . zipWithOI readFile) <*> null)+    |/| writeFile "output.txt" . concatMap textproc++textproc :: String -> String+textproc = id -- unlines . take 1 . lines++readFile :: FilePath -> (Handle, String) :-> String+readFile f      = openFile f ReadMode   |/| hGetContents++writeFile :: FilePath -> String -> (Handle, ()) :-> ()+writeFile f cs  = openFile f WriteMode  |/| flip hPutStr cs++openFile :: FilePath -> IOMode -> Handle :-> Handle+openFile     = (iooi .) . IO.openFile++hGetContents :: Handle -> String :-> String+hGetContents = iooi . IO.hGetContents++hPutStr :: Handle -> String -> () :-> ()+hPutStr      = (iooi .) . IO.hPutStr+

@@ -1,35 +0,0 @@-module Main where--import System.Environment-import System.IO hiding (readFile, writeFile)-import Prelude hiding (readFile, writeFile)--{-- If "files" contains much many files, "./catsIO" throws a resource-exhaused exception."--}--main :: IO ()-main = do-  args     <- getArgs-  contents <- if not $ null args -                then do-                  mapM readFile args-                else do -                  files <- readFile "files"-                  mapM readFile (lines files)-  writeFile "output.txt" (concatMap textproc contents)--textproc :: String -> String-textproc = unlines . take 1 . lines--readFile :: String -> IO String-readFile f = do-  h  <- openFile f ReadMode-  cs <- hGetContents h-  return cs--writeFile :: String -> String -> IO ()-writeFile f cs = do-  h  <- openFile f WriteMode-  r  <- hPutStr h cs-  return r

@@ -1,45 +0,0 @@-module Main where--import System.Environment-import System.IO hiding (readFile, writeFile)-import System.IO.Unsafe-import Prelude hiding (readFile, writeFile)--main :: IO ()-main = do-  args     <- getArgs-  contents <- if not $ null args -                then do-                  sequenceLz $ map readFile args-                else do -                  files <- readFile "files"-                  sequenceLz $ map readFile (lines files)-  writeFile "output.txt" (concatMap textproc contents)--textproc :: String -> String-textproc = id -- unlines . take 1 . lines--lazy :: IO a -> IO a-lazy = unsafeInterleaveIO--mapLzM :: (a -> IO b) -> [a] -> IO [b]-mapLzM = (sequenceLz .) . map--sequenceLz :: [IO a] -> IO [a]-sequenceLz []     = lazy $ return []-sequenceLz (i:is) = lazy $ do-  r  <- lazy i-  rs <- sequenceLz is-  return (r:rs)--readFile :: String -> IO String-readFile f = do-  h  <- openFile f ReadMode-  cs <- hGetContents h-  return cs--writeFile :: String -> String -> IO ()-writeFile f cs = do-  h  <- openFile f WriteMode-  r  <- hPutStr h cs-  return r

@@ -1,38 +0,0 @@-{-# LANGUAGE TypeOperators #-}-module Main where--import Data.OI hiding (openFile)-import System.IO (IOMode (..), Handle)-import qualified System.IO as IO-import Prelude hiding (readFile, writeFile)--main :: IO ()-main = runInteraction pmain--pmain -  :: (([String],Either ((Handle, String), [(Handle, String)]) [(Handle, String)]), (Handle, ()))-  :-> ()-pmain = args -    |/| choiceOIOn (const $ lines . readFile "files" |/| zipWithOI readFile) -                   (zipWithOI readFile)-                   null-    |/| writeFile "output.txt" . concatMap textproc--textproc :: String -> String-textproc = id -- unlines . take 1 . lines--readFile :: FilePath -> (Handle, String) :-> String-readFile f      = openFile f ReadMode   |/| hGetContents--writeFile :: FilePath -> String -> (Handle, ()) :-> ()-writeFile f cs  = openFile f WriteMode  |/| flip hPutStr cs--openFile :: FilePath -> IOMode -> Handle :-> Handle-openFile     = (iooi .) . IO.openFile--hGetContents :: Handle -> String :-> String-hGetContents = iooi . IO.hGetContents--hPutStr :: Handle -> String -> () :-> ()-hPutStr      = (iooi .) . IO.hPutStr-

@@ -1,40 +0,0 @@-module Main where--import System.Environment-import qualified System.IO as IO-import System.IO.Strict hiding (readFile, writeFile)-import Prelude hiding (readFile, writeFile)--{-- If the amount of size of files contained in "files" is too much, "./catsSIO" throws a out-of-memory exception."--}--main :: IO ()-main = do-  args     <- getArgs-  main' args--main' :: [String] -> IO ()-main' args = run $ do-  contents <- if not $ null args -                then do-                  mapM readFile args-                else do -                  files <- readFile "files"-                  mapM readFile (lines files)-  writeFile "output.txt" (concatMap textproc contents)--textproc :: String -> String-textproc = unlines . take 1 . lines--readFile :: String -> SIO String-readFile f = do-  h  <- openFile f IO.ReadMode-  cs <- hGetContents h-  return cs--writeFile :: String -> String -> SIO ()-writeFile f cs = do-  h  <- openFile f IO.WriteMode-  r  <- hPutStr h cs-  return r

@@ -3,39 +3,50 @@  import Data.OI hiding (isEOF) -import Data.Char+import Data.Maybe import System.IO +import qualified System.Environment as Sys (getArgs)+ main :: IO ()-main = runInteraction $ pmain1+main =  runInteraction pmain -pmain0 = forceSeq . mapOI echo-pmain1 = forceSeq . echos+pmain :: ([String], Either [(Maybe Char, Maybe ())] ([Maybe Char], [Maybe ()])) :-> ()+pmain = null . getArgs |/| choiceOI pmain0 pmain1 -eof :: Int-eof = -1+pmain0 :: [(Maybe Char, Maybe ())] :-> ()+pmain0 = forceSeq . takeWhile isJust . mapOI echochar -getc :: Int :-> Int+pmain1 :: ([Maybe Char], [Maybe ()]) :-> ()+pmain1 = forceSeq . echostring++getc :: Maybe Char :-> Maybe Char getc = iooi getchar -putc :: Char -> () :-> ()-putc = iooi . putChar+putc :: Maybe Char -> Maybe () :-> Maybe ()+putc = iooi . putchar -putc' :: Int -> () :-> ()-putc' (-1) = const ()-putc' c    = iooi (putChar (chr c))+getchar :: IO (Maybe Char)+getchar = choice (return Nothing) (return . Just =<< getChar) =<< isEOF  -gets :: [Int] :-> String-gets = map chr . takeWhile (eof /=) . mapOI getc+putchar :: Maybe Char -> IO (Maybe ())+putchar = maybe (return Nothing)+                ((return . Just =<<) . putChar) -puts :: String -> [()] :-> [()]-puts = zipWithOI putc+gets :: [Maybe Char] :-> String+gets = map fromJust . takeWhile isJust . mapOI getc -getchar :: IO Int-getchar = choice (return (-1)) (return . ord =<< getChar) =<< isEOF +puts :: String -> [Maybe ()] :-> [Maybe ()]+puts = zipWithOI putc . map Just -puts' :: String -> OI [()] -> ()-puts' = seqsOI . map putc+echochar :: (Maybe Char, Maybe ()) :-> Maybe ()+echochar  = getc |/| putc -echo  = getc |/| putc'-echos = gets |/| puts+echostring :: ([Maybe Char], [Maybe ()]) :-> [Maybe ()]+echostring = gets |/| puts++getArgs :: [String] :-> [String]+getArgs = iooi Sys.getArgs++choice :: a -> a -> Bool -> a+choice t f c = if c then t else f

@@ -0,0 +1,29 @@+{-# LANGUAGE TypeOperators #-}+module Main where++import Data.OI+import System.IO++main :: IO ()+main = do +  hSetBuffering stdin NoBuffering+  runInteraction morec+  Prelude.putStrLn ""++(|?|) :: (a :-> c)+      -> (b :-> c)+      -> Bool+      -> (Either a b :-> c)+(|?|) = choiceOI++getc :: Char :-> Char+getc  = iooi getChar++putc :: Char -> (() :-> ())+putc  = iooi . putChar++echoc :: (Char,()) :-> ()+echoc = getc |/| putc++morec :: (Char, Either (Char, ()) ()) :-> ()+morec = ('e' ==) . getc |/| (echoc |?| putc 'q')

@@ -16,6 +16,7 @@ pmain :: (([String], [(Bool, IOResult [FilePath])]), ()) :-> () pmain = (((args >>> head) |/| getDirCsRec) >>> snd) |/| putStrOI . unlines + putStrOI :: String -> () :-> () putStrOI = iooi . putStr @@ -41,3 +42,6 @@     (False, fps) -> (os,fps)     (True,  fps) -> second concat $ mapAccumL (flip getDirCsRec) os fps   _           -> error $ "getDirCs: perhaps `"++ fp ++"' is not found"++choice :: a -> a -> Bool -> a+choice t f c = if c then t else f

@@ -4,7 +4,6 @@  import Data.OI -import Control.Concurrent import Control.Parallel import System.Environment @@ -33,5 +32,3 @@  showscr :: FilePath -> [String] -> () :-> () showscr s = iooi . writeFile s . unlines--mergeOI = (iooi .) . mergeIO

@@ -13,6 +13,7 @@   ,module Data.OI.Combinator   ,module Data.OI.IFun   ,module Data.OI.IO+  ,module Data.OI.Merge   ,module Data.OI.Resource   ,module Data.OI.System   ,module Data.OI.Force@@ -23,5 +24,6 @@ import Data.OI.Force import Data.OI.IFun import Data.OI.IO+import Data.OI.Merge import Data.OI.Resource import Data.OI.System

@@ -6,15 +6,11 @@ -- Maintainer  : nobsun@sampou.org -- Stability   : experimental ---{-# LANGUAGE TypeOperators-            ,BangPatterns-  #-}+{-# LANGUAGE TypeOperators #-} module Data.OI.Combinator   (-   -- * Utility functions-   choice    -- * Interaction Combinators-  ,(|:|)+   (|:|)   ,(|>|),(|/|)   ,(|><|)    -- * Iteration@@ -35,12 +31,6 @@ import Data.OI.Internal import Data.OI.Force -(|>) :: (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 |:|@@ -63,6 +53,7 @@   (a,b) -> (c,d) where (q,c) = f a p; (p,d) = g b q  -- | Iteration+ foldOI :: (a :-> (b -> b)) -> b -> ([a] :-> b) foldOI op z xxs = case deList xxs of   Just (x,xs) -> x `op` foldOI op z xs@@ -104,6 +95,7 @@ choiceOIOn f g p x = choiceOI (f x) (g x) (p x)  -- | Sequencing+ seqsOI :: [a :-> b] -> ([a] :-> ()) seqsOI s os =  forceSeq $ zipWithOI ($) s os 

@@ -19,6 +19,9 @@   ,(:->)   -- * Primitive operators on OI   ,(??)+  ,(##)+  -- * Assign operator+  ,(=:)   -- * Splitters against `OI' datatype   ,dePair   ,deList@@ -39,14 +42,14 @@   where  import Control.Applicative-import Control.Category+-- import Control.Category import Control.Comonad import Control.Exception-import Control.Monad+-- import Control.Monad import Control.Concurrent import Control.Parallel import System.IO.Unsafe-import Prelude hiding ((.),id,catch)+-- import Prelude hiding ((.),id,catch)  -- | Datatype for intermediating interaction:  -- @OI@ has two states (programmer cannot distinguish), non-expressed and exressed.@@ -81,6 +84,10 @@ -- | Reference operator (##) :: a -> OI a (##) x = OI (unsafeNew x) x++-- | Assign Operator+(=:) :: a -> OI a -> a+(=:) !x (OI var val) = put (return x) var `pseq` val  -- | Decomposer for pair dePair :: OI (a,b) -> (OI a, OI b)

@@ -0,0 +1,87 @@+{-# LANGUAGE TypeOperators #-}+module Data.OI.Merge+ ( -- * merge list+  mergeOI+ ,nmergeOI  + ) where++import Data.OI.Internal++import Control.Concurrent (forkIO)+import Control.Concurrent.MVar (MVar,newEmptyMVar,newMVar,takeMVar,putMVar)+import Control.Concurrent.SSem (SSem,new,signal,wait)+import System.IO.Unsafe (unsafeInterleaveIO)++mergeOI :: [a] -> [a] -> [a] :-> [a]+mergeOI = (iooi .) . mergeIO++nmergeOI :: [[a]] -> [a] :-> [a]+nmergeOI =  iooi . nmergeIO++-- The origin of following codes came from Control.Concurrent module.+-- The original codes using Control.Concurrent.QSem were deprecated.+-- The following codes are made by modifying the original code to use+-- Control.Concurrent.SSem module (privided by SafeSemaphore).++mergeIO :: [a] -> [a] -> IO [a]+nmergeIO :: [[a]] -> IO [a]++mergeIO ls rs+ = newEmptyMVar                >>= \ tail_node ->+   newMVar tail_node           >>= \ tail_list ->+   new max_buff_size           >>= \ e ->+   newMVar 2                   >>= \ branches_running ->+   let+    buff = (tail_list,e)+   in+    forkIO (suckIO branches_running buff ls) >>+    forkIO (suckIO branches_running buff rs) >>+    takeMVar tail_node  >>= \ val ->+    signal e            >>+    return val++nmergeIO lss+ = let+    len = length lss+   in+    newEmptyMVar          >>= \ tail_node ->+    newMVar tail_node     >>= \ tail_list ->+    new     max_buff_size >>= \ e ->+    newMVar len           >>= \ branches_running ->+    let+     buff = (tail_list,e)+    in+    mapIO (\ x -> forkIO (suckIO branches_running buff x)) lss >>+    takeMVar tail_node  >>= \ val ->+    signal e            >>+    return val+  where+    mapIO f xs = sequence (map f xs)++max_buff_size  ::  Int+max_buff_size  =   1++type Buffer a+ = (MVar (MVar [a]), SSem)++suckIO :: MVar Int -> Buffer a -> [a] -> IO ()+suckIO branches_running buff@(tail_list,e) vs+ = case vs of+        [] -> takeMVar branches_running >>= \ val ->+              if val == 1 then+                 takeMVar tail_list     >>= \ node ->+                 putMVar node []        >>+                 putMVar tail_list node+              else+                 putMVar branches_running (val-1)+        (x:xs) ->+                wait e                           >>+                takeMVar tail_list               >>= \ node ->+                newEmptyMVar                     >>= \ next_node ->+                unsafeInterleaveIO (+                        takeMVar next_node  >>= \ y ->+                        signal     e        >>+                        return y)                >>= \ next_node_val ->+                putMVar node (x:next_node_val)   >>+                putMVar tail_list next_node      >>+                suckIO branches_running buff xs