[Assorted-commits] SF.net SVN: assorted: [252] haskell-commons/trunk/src

[<yan...@us...>]

Revision: 252
          http://assorted.svn.sourceforge.net/assorted/?rev=252&view=rev
Author:   yangzhang
Date:     2008-01-19 22:31:46 -0800 (Sat, 19 Jan 2008)

Log Message:
-----------
adding haskell commons code

Added Paths:
-----------
    haskell-commons/trunk/src/Commons/
    haskell-commons/trunk/src/Commons/Concurrent.hs
    haskell-commons/trunk/src/Commons/Control.hs
    haskell-commons/trunk/src/Commons/Exception.hs
    haskell-commons/trunk/src/Commons/Io.hs
    haskell-commons/trunk/src/Commons/Posix.hs
    haskell-commons/trunk/src/Commons/Text.hs

Added: haskell-commons/trunk/src/Commons/Concurrent.hs
===================================================================
--- haskell-commons/trunk/src/Commons/Concurrent.hs	                        (rev 0)
+++ haskell-commons/trunk/src/Commons/Concurrent.hs	2008-01-20 06:31:46 UTC (rev 252)
@@ -0,0 +1,75 @@
+module Commons.Concurrent where
+
+import Control.Concurrent
+import Control.Concurrent.MVar
+import Control.Exception
+import Control.Monad
+import Data.Maybe
+import Data.Typeable
+
+tryReadMVar v = do
+  x <- tryTakeMVar v
+  case x of 
+    Just x  -> putMVar v x
+    Nothing -> return ()
+  return x
+
+-- TODO extend this to allow interruptibles to specify exactly which
+-- exceptions they tolerate
+
+-- This is designed for only one interrupt to ever happen; there is
+-- currently no mechanism to clear interrupts. This is also designed
+-- for only one client thread.
+
+newInterruptible :: (Typeable e) =>
+                    Bool -> IO ((forall a. IO a -> IO a), (e -> IO ()))
+newInterruptible saveInterrupts = do
+  -- omnipotent lock
+  lock <- newMVar ()
+  -- any ThreadId currently running and is interruptible
+  tid <- newEmptyMVar
+  -- any pending interrupt
+  pending <- newEmptyMVar
+
+  let acquire    = takeMVar lock
+      release    = putMVar lock ()
+      withLock f = bracket acquire (const release) (const f)
+
+  let
+      -- the interruptible first puts tid, then takes pending
+      interruptible f = do
+        myTid  <- myThreadId
+        acquire
+        intr   <- tryReadMVar pending
+        case intr of
+          Nothing -> do
+            -- Let interruptors know who to throw to.
+            putMVar tid myTid
+
+            -- We're clear to proceed; we'll get async exceptions for
+            -- interrupts.
+            release
+            res <- f
+
+            -- If an async exception is on its way, then we'll
+            -- (thankfully, due to async exception semantics) receive
+            -- it while blocked either on acquire or on takeMVar.
+            withLock $ do
+              takeMVar tid
+              return res
+
+          Just ex -> do
+            -- There's an interrupt just waiting for us; raise the
+            -- exception.
+            release
+            throwDyn ex
+
+      -- The interrupter first puts pending, then takes tid.
+      interrupt ex = withLock $ do
+        when saveInterrupts $ putMVar pending ex
+        current <- tryTakeMVar tid
+        case current of
+          Just tid -> throwDynTo tid ex
+          Nothing  -> return ()
+
+  return (interruptible, interrupt)
\ No newline at end of file

Added: haskell-commons/trunk/src/Commons/Control.hs
===================================================================
--- haskell-commons/trunk/src/Commons/Control.hs	                        (rev 0)
+++ haskell-commons/trunk/src/Commons/Control.hs	2008-01-20 06:31:46 UTC (rev 252)
@@ -0,0 +1,13 @@
+module Commons.Control where
+
+import Control.Monad
+
+while :: Bool -> IO a -> IO ()
+while cond body =
+  when cond (body `seq` while cond body)
+
+loop :: IO a -> IO ()
+loop = while True
+
+discard :: (Monad m) => m a -> m ()
+discard f = f >> return ()
\ No newline at end of file

Added: haskell-commons/trunk/src/Commons/Exception.hs
===================================================================
--- haskell-commons/trunk/src/Commons/Exception.hs	                        (rev 0)
+++ haskell-commons/trunk/src/Commons/Exception.hs	2008-01-20 06:31:46 UTC (rev 252)
@@ -0,0 +1,8 @@
+module Commons.Exception where
+
+import Control.Exception
+
+-- avoid monomorphism restriction
+handleDyn body handler = catchDyn handler body
+
+f `or` handler = f `Prelude.catch` handler
\ No newline at end of file

Added: haskell-commons/trunk/src/Commons/Io.hs
===================================================================
--- haskell-commons/trunk/src/Commons/Io.hs	                        (rev 0)
+++ haskell-commons/trunk/src/Commons/Io.hs	2008-01-20 06:31:46 UTC (rev 252)
@@ -0,0 +1,24 @@
+module Commons.Io where
+
+import Data.List
+import System.IO
+
+-- TODO available in 6.8
+{-
+withFile path mode f = do
+  h <- openFile path mode
+  res <- f h
+  hClose h
+  return res
+-}
+
+unhidden = filter (not . ("." `isPrefixOf`))
+
+strict f = do
+  xs <- f
+  length xs `seq` return xs
+
+hGetContents' = strict . hGetContents
+
+readFileOrNil path = readFile path `catch` const (return "")
+readFileOrNil' = strict . readFileOrNil
\ No newline at end of file

Added: haskell-commons/trunk/src/Commons/Posix.hs
===================================================================
--- haskell-commons/trunk/src/Commons/Posix.hs	                        (rev 0)
+++ haskell-commons/trunk/src/Commons/Posix.hs	2008-01-20 06:31:46 UTC (rev 252)
@@ -0,0 +1,12 @@
+module Commons.Posix where
+
+import Data.List
+import System.Posix.Files
+
+mergeModes = foldl' unionFileModes nullFileMode
+
+executeMode = mergeModes [ownerExecuteMode, groupExecuteMode, otherExecuteMode]
+
+chmod mode path = do
+  origMode <- fmap fileMode $ getFileStatus path
+  setFileMode path $ origMode `unionFileModes` mode

Added: haskell-commons/trunk/src/Commons/Text.hs
===================================================================
--- haskell-commons/trunk/src/Commons/Text.hs	                        (rev 0)
+++ haskell-commons/trunk/src/Commons/Text.hs	2008-01-20 06:31:46 UTC (rev 252)
@@ -0,0 +1,9 @@
+module Commons.Text where
+
+import Control.Arrow
+
+indent n = lines >>> map (replicate n ' ' ++) >>> unlines
+
+--grep pat = lines >>> filter (contains pat) >>> unlines
+--
+--fgrep_v = filter (contains "
\ No newline at end of file


This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site.