oi (empty) → 0.0.1

raw patch · 7 files changed

+300/−0 lines, 7 filesdep +basedep +comonaddep +parallelsetup-changed

Dependencies added: base, comonad, parallel

Files

• LICENSE +24/−0
• Setup.hs +6/−0
• oi.cabal +23/−0
• sample/Makefile +13/−0
• sample/echo.hs +33/−0
• sample/recdircs.hs +45/−0
• src/Data/OI.hs +156/−0

@@ -0,0 +1,24 @@+Copyright (c) 2011, Nobuo Yamashita+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:+    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.+    * Redistributions in binary form must reproduce the above copyright+      notice, this list of conditions and the following disclaimer in the+      documentation and/or other materials provided with the distribution.+    * Neither the name of the SampouOrg nor the+      names of its contributors may be used to endorse or promote products+      derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED+WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE+DISCLAIMED. IN NO EVENT SHALL Nobuo Yamashita BE LIABLE FOR ANY+DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES+(INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES;+LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND+ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS+SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

@@ -0,0 +1,6 @@+module Main where++import Distribution.Simple++main :: IO ()+main = defaultMain

@@ -0,0 +1,23 @@+Name:			oi+Version:		0.0.1+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.+Stability:		Experimental+License:		BSD3+License-File:		LICENSE+Author:			Nobuo Yamashita+Maintainer:		nobsun@sampou.org+Build-Type:		Simple+Cabal-Version:		>= 1.6++Data-dir:		sample+Data-files:		Makefile echo.hs recdircs.hs++Library+  Hs-Source-Dirs:	    src/+  Build-Depends:	    base >= 4 && < 5, parallel, comonad+  GHC-Options:		    -Wall -O0+  Exposed-modules:	    Data.OI+

@@ -0,0 +1,13 @@+EXECS = echo recdircs++all	: $(EXECS)++echo	: echo.hs+	ghc --make -O0 -threaded $< -o $@++recdircs	: recdircs.hs+	ghc --make -O0 -threaded $< -o $@++clean	:+	-rm $(EXECS) *.hi *.o *~+

@@ -0,0 +1,33 @@+{-# LANGUAGE TypeOperators+  #-}+module Main where++import Data.OI++import Data.Char+import System.IO++main :: IO ()+main = do { [] <- run $ puts <| gets; return () }++eof :: Int+eof = -1++getc :: Int :-> Int+getc = iooi getchar++putc :: Char -> () :-> ()+putc = iooi . putChar+++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++getchar :: IO Int+getchar = choice (return (-1)) (return . ord =<< getChar) =<< isEOF 

@@ -0,0 +1,45 @@+{-# LANGUAGE TypeOperators #-}+module Main where++import Data.OI++import Data.List++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)+          }++pmain :: FilePath -> [(Bool, [FilePath])] :-> [FilePath]+pmain = recDirectoryContents++isDirectory :: FilePath -> Bool :-> Bool+isDirectory = iooi . doesDirectoryExist++directoryContents :: FilePath -> [FilePath] :-> [FilePath]+directoryContents f = map (f </>) . filter (`notElem` [".",".."])+                    . iooi (getDirectoryContents f)++recDirectoryContents :: FilePath -> [(Bool,[FilePath])] :-> [FilePath]+recDirectoryContents root = fst . recdircs root++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"++swap :: (a,b) -> (b,a)+swap (x,y) = (y,x)

@@ -0,0 +1,156 @@+{-# LANGUAGE TypeOperators+            ,ScopedTypeVariables+            ,PostfixOperators+            ,NoMonomorphismRestriction+            ,BangPatterns+  #-}+{-# OPTIONS_GHC -fno-cse #-}+module Data.OI (+  OI+ ,(:->)+ ,iooi+ ,run+ ,(=:)+ ,(?)+ ,(#)+ ,idA+ ,(<.>)+ ,arrA+ ,firstA+ ,deTuple+ ,deList+ ,(<|)+ ,zipWithOI+ ,zipWithOI'+ ,mapOI+ ) where++import Control.Applicative+import Control.Concurrent.MVar+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++(=:)         ::  a -> a :-> a+x =: OI v y  =   assign ix v `pseq` y+                 where ix = return x++(?)           ::  a :-> a+(?) (OI _ x)  =   x++(#)    ::  a -> OI a+(#) x  =   OI { variable = reference (return x), value = x }++--++instance Functor OI where+  fmap f x = (#) (f (x?))++instance Monad OI where+  return = (#)+  x >>= f = f (x?)++instance Applicative OI where+  pure = (#)+  f <*> x = (#)((f?)(x?))++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?))++--++deTuple :: (a,b) :-> (OI a,OI b)+deTuple (OI vxy ~(x,y)) = assign io vxy `pseq` (OI vx x, OI vy y)+ where+  vx     = new ()+  vy     = new ()+  io     = (,) <$> unsafeInterleaveIO (dereference vx) <*> unsafeInterleaveIO (dereference vy)++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  = new ()+     vxs = new ()+     io  = (:) <$> (unsafeInterleaveIO (dereference vx)) <*> (unsafeInterleaveIO (dereference vxs))++--++(<|)  ::  (b -> c :-> d) -> (a :-> b) -> (a,c) :-> d+(f <| g) ac = case deTuple ac of (a,c) -> f (g a) c++mapOI :: (a :-> b) -> [a] :-> [b]+mapOI f xxs = case deList xxs of+  Just (x,xs) -> f x : mapOI f xs+  _           -> []++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+  _           -> []++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,[])++--++iooi            ::  IO a -> (a :-> a)+iooi io (OI vix x)  =   assign io vix `pseq` x++run        ::  (a :-> b) -> IO b+run pmain  =   do { vx <- unsafeInterleaveIO newEmptyMVar+                  ; x  <- unsafeInterleaveIO (dereference vx)+                  ; return $! pmain (OI vx x)+                  }++--++type LeftValueOf = MVar++{-# INLINE new #-}+new :: () -> LeftValueOf a+new _ = unsafePerformIO $ newEmptyMVar++{-# INLINE reference #-}+reference :: a -> LeftValueOf a+reference = unsafePerformIO . newMVar++{-# INLINE dereference #-}+dereference :: LeftValueOf a -> a+dereference = unsafePerformIO . readMVar++{-# INLINE assign #-}+assign :: a -> LeftValueOf a -> a+assign !x v = unsafePerformIO +            $ do { s <- tryPutMVar v x+                 ; if s then return x else readMVar v+                 }