[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
gwern0
gwern0 at gmail.com
Fri Apr 23 15:22:06 UTC 2010
The following commit has been merged in the master branch:
commit 02076d6c6b74ac70c8f35665d92f03c89206743b
Author: gwern0 <gwern0 at gmail.com>
Date: Fri Nov 30 11:52:37 2007 +0100
partial -Wall for System.IO.HVFS.InstanceHelpers
diff --git a/src/System/IO/HVFS/InstanceHelpers.hs b/src/System/IO/HVFS/InstanceHelpers.hs
index 9674b7f..3c7182b 100644
--- a/src/System/IO/HVFS/InstanceHelpers.hs
+++ b/src/System/IO/HVFS/InstanceHelpers.hs
@@ -21,7 +21,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
Copyright : Copyright (C) 2004 John Goerzen
License : GNU GPL, version 2 or above
- Maintainer : John Goerzen <jgoerzen at complete.org>
+ Maintainer : John Goerzen <jgoerzen at complete.org>
Stability : provisional
Portability: portable
@@ -41,20 +41,19 @@ module System.IO.HVFS.InstanceHelpers(-- * HVFSStat objects
MemoryEntry(..),
-- * Utilities
nice_slice, getFullPath,
- getFullSlice
- )
-where
+ getFullSlice)
+ where
+
+import Data.IORef (newIORef, readIORef, writeIORef, IORef())
+import Data.List (genericLength)
+import System.IO -- (ReadMode)
+import System.IO.Error (doesNotExistErrorType, illegalOperationErrorType, permissionErrorType)
import System.IO.HVFS
-import Data.IORef
-import Data.List
-import System.Path
-import System.Path.NameManip
-import Control.Monad.Error
-import System.IO.Error
-import System.IO
-import System.IO.HVIO
-
-{- | A simple "System.IO.HVFS.HVFSStat"
+import System.IO.HVIO (newStreamReader)
+import System.Path (absNormPath)
+import System.Path.NameManip (slice_path)
+
+{- | A simple "System.IO.HVFS.HVFSStat"
class that assumes that everything is either a file
or a directory. -}
data SimpleStat = SimpleStat {
@@ -69,7 +68,6 @@ instance HVFSStat SimpleStat where
----------------------------------------------------------------------
-- In-Memory Tree Types
----------------------------------------------------------------------
-
{- | The basic node of a 'MemoryVFS'. The String corresponds to the filename,
and the entry to the contents. -}
type MemoryNode = (String, MemoryEntry)
@@ -81,8 +79,7 @@ data MemoryEntry = MemoryDirectory [MemoryNode]
{- | An in-memory read\/write filesystem. Think of it as a dynamically
resizable ramdisk written in Haskell. -}
-
-data MemoryVFS = MemoryVFS
+data MemoryVFS = MemoryVFS
{ content :: IORef [MemoryNode],
cwd :: IORef FilePath
}
@@ -124,7 +121,7 @@ nice_slice path =
getFullPath :: HVFS a => a -> String -> IO String
getFullPath fs path =
do cwd <- vGetCurrentDirectory fs
- case absNormPath cwd path of
+ case (absNormPath cwd path) of
Nothing -> vRaiseError fs doesNotExistErrorType
("Trouble normalizing path " ++ path) (Just (cwd ++ "/" ++ path))
Just newpath -> return newpath
@@ -145,7 +142,7 @@ findMelem x path =
t = tail sliced1
newh = if (h /= "/") && head h == '/' then tail h else h
sliced2 = newh : t
-
+
-- Walk the tree
walk :: MemoryEntry -> [String] -> Either String MemoryEntry
-- Empty list -- return the item we have
@@ -153,14 +150,14 @@ findMelem x path =
-- Root directory -- return the item we have
walk y ["/"] = Right y
-- File but stuff: error
- walk (MemoryFile _) (x : _) =
- Left $ "Attempt to look up name " ++ x ++ " in file"
- walk (MemoryDirectory y) (x : xs) =
- let newentry = case lookup x y of
- Nothing -> Left $ "Couldn't find entry " ++ x
- Just z -> Right z
+ walk (MemoryFile _) (z : _) =
+ Left $ "Attempt to look up name " ++ z ++ " in file"
+ walk (MemoryDirectory y) (z : zs) =
+ let newentry = case lookup z y of
+ Nothing -> Left $ "Couldn't find entry " ++ z
+ Just a -> Right a
in do newobj <- newentry
- walk newobj xs
+ walk newobj zs
in do
c <- readIORef $ content x
case walk (MemoryDirectory c) (sliced2) of
@@ -169,7 +166,7 @@ findMelem x path =
-- | Find an element on the tree, normalizing the path first
getMelem :: MemoryVFS -> String -> IO MemoryEntry
-getMelem x s =
+getMelem x s =
do base <- readIORef $ cwd x
case absNormPath base s of
Nothing -> vRaiseError x doesNotExistErrorType
@@ -182,17 +179,17 @@ instance HVFS MemoryVFS where
do curpath <- vGetCurrentDirectory x
-- Make sure new dir is valid
newdir <- getMelem x fp
- case newdir of
- (MemoryFile _) -> vRaiseError x doesNotExistErrorType
+ case newdir of
+ (MemoryFile _) -> vRaiseError x doesNotExistErrorType
("Attempt to cwd to non-directory " ++ fp)
(Just fp)
- (MemoryDirectory _) ->
+ (MemoryDirectory _) ->
case absNormPath curpath fp of
Nothing -> -- should never happen due to above getMelem call
vRaiseError x illegalOperationErrorType
"Bad internal error" (Just fp)
Just y -> writeIORef (cwd x) y
- vGetFileStatus x fp =
+ vGetFileStatus x fp =
do elem <- getMelem x fp
case elem of
(MemoryFile y) -> return $ HVFSStatEncap $
@@ -210,9 +207,9 @@ instance HVFS MemoryVFS where
MemoryDirectory c -> return $ map fst c
instance HVFSOpenable MemoryVFS where
- vOpen x fp (ReadMode) =
+ vOpen x fp (ReadMode) =
do elem <- getMelem x fp
- case elem of
+ case elem of
MemoryDirectory _ -> vRaiseError x doesNotExistErrorType
"Can't open a directory"
(Just fp)
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list