[Pkg-haskell-commits] [SCM] haskell-testpack branch, master, updated. debian/1.0.2-1-4-gb0d6b36
John Goerzen
jgoerzen at complete.org
Fri Apr 23 14:49:21 UTC 2010
The following commit has been merged in the master branch:
commit 0874de51e50b6238dbf52cf6d807b3be370f4b69
Author: John Goerzen <jgoerzen at complete.org>
Date: Fri Dec 3 22:35:41 2004 +0100
Applied remainder of Einar's patches
Keywords:
(jgoerzen at complete.org--projects/missingh--head--0.7--patch-3)
diff --git a/libsrc/MissingH/ConfigParser.hs b/libsrc/MissingH/ConfigParser.hs
index bb92bcd..1f3e4e4 100644
--- a/libsrc/MissingH/ConfigParser.hs
+++ b/libsrc/MissingH/ConfigParser.hs
@@ -369,27 +369,30 @@ has_option cp s o =
let c = content cp
v = do secthash <- lookupFM c s
return $ elemFM (optionxform cp $ o) secthash
- in
- case v of
- Nothing -> False
- Just x -> x
+ in maybe False id v
+
+
+class Get_C a where
+ get :: MonadError CPError m => ConfigParser -> SectionSpec -> OptionSpec -> m a
{- | Retrieves a string from the configuration file.
Returns an error if no such section\/option could be found.
-}
-get :: MonadError CPError m =>
- ConfigParser -> SectionSpec -> OptionSpec -> m String
--- used to be:
--- get cp = (accessfunc cp) cp
--- but I had to change the type of the accessfunc to return an Either,
--- so we now do this.
-get cp s o = eitherToMonadError $ (accessfunc cp) cp s o
+instance Get_C String where
+ get cp s o = eitherToMonadError $ (accessfunc cp) cp s o
+
+instance Get_C Bool where
+ get = getbool
+
+instance Read t => Get_C t where
+ get cp s o = get cp s o >>= return . read
{- | Retrieves a string from the configuration file and attempts to parse it
as a number. Returns an error if no such option could be found.
An exception may be raised if it
could not be parsed as the destination number. -}
+-- FIXME delete this
getnum :: (Read a, Num a, MonadError CPError m) =>
ConfigParser -> SectionSpec -> OptionSpec -> m a
getnum cp s o = get cp s o >>= return . read
@@ -427,6 +430,7 @@ The following will produce a False value:
*false
-}
+-- FIXME don't export
getbool :: MonadError CPError m =>
ConfigParser -> SectionSpec -> OptionSpec -> m Bool
getbool cp s o =
diff --git a/libsrc/MissingH/IO.hs b/libsrc/MissingH/IO.hs
index cf29c1c..acb5492 100644
--- a/libsrc/MissingH/IO.hs
+++ b/libsrc/MissingH/IO.hs
@@ -58,10 +58,7 @@ newlines as appropriate. The list is not expected to have newlines already.
-}
hPutStrLns :: Handle -> [String] -> IO ()
-hPutStrLns _ [] = return ()
-hPutStrLns h (x:xs) = do
- hPutStrLn h x
- hPutStrLns h xs
+hPutStrLns h = mapM_ $ hPutStrLn h
{- | Given a handle, returns a list of all the lines in that handle.
Thanks to lazy evaluation, this list does not have to be read all at once.
@@ -77,8 +74,8 @@ Example:
-}
+-- FIXME does hGetContents h >>= return.lines not work?
hGetLines :: Handle -> IO [String]
-
hGetLines h = unsafeInterleaveIO (do
ieof <- hIsEOF h
if (ieof)
diff --git a/libsrc/MissingH/Network.hs b/libsrc/MissingH/Network.hs
index a770434..5d4c837 100644
--- a/libsrc/MissingH/Network.hs
+++ b/libsrc/MissingH/Network.hs
@@ -50,6 +50,8 @@ Example:
> main = niceSocketsDo $ do { ... }
-}
+-- FIXME integrate with WebCont.Util.UDP
+
niceSocketsDo :: IO a -> IO a
niceSocketsDo func = do
System.Posix.Signals.installHandler
diff --git a/libsrc/MissingH/Path.hs b/libsrc/MissingH/Path.hs
index 7e7e0aa..6077e62 100644
--- a/libsrc/MissingH/Path.hs
+++ b/libsrc/MissingH/Path.hs
@@ -41,6 +41,9 @@ import MissingH.List
{- | Splits a pathname into a tuple representing the root of the name and
the extension. The extension is considered to be all characters from the last
dot after the last slash to the end. Either returned string may be empty. -}
+
+-- FIXME - See 6.4 API when released.
+
splitExt :: String -> (String, String)
splitExt path =
let dotindex = alwaysElemRIndex '.' path
diff --git a/libsrc/MissingH/Threads.hs b/libsrc/MissingH/Threads.hs
index 5332e61..a863960 100644
--- a/libsrc/MissingH/Threads.hs
+++ b/libsrc/MissingH/Threads.hs
@@ -43,11 +43,4 @@ separate thread. When it is completed, the specified function is called with
its result. This is a simple way of doing callbacks. -}
runInThread :: IO a -> (a -> IO b) -> IO ThreadId
-runInThread action callback =
- let computation :: IO ()
- computation = do
- x <- action
- callback x
- return ()
- in
- forkIO computation
+runInThread action callback = forkIO $ action >>= callback >> return ()
diff --git a/testsrc/ConfigParser/Maintest.hs b/testsrc/ConfigParser/Maintest.hs
index c83aa94..6c65b0b 100644
--- a/testsrc/ConfigParser/Maintest.hs
+++ b/testsrc/ConfigParser/Maintest.hs
@@ -28,6 +28,10 @@ nullfile = openFile "/dev/null" ReadWriteMode
testfile = "testsrc/ConfigParser/test.cfg"
p inp = forceEither $ readstring emptyCP inp
f msg inp exp conv = TestLabel msg $ TestCase $ assertEqual "" (Right exp) (conv (p inp))
+f2s :: String -> Either CPError String -> Either CPError String -> Test
+f2s msg exp res = TestLabel msg $ TestCase $ assertEqual "" exp res
+f2b :: String -> Either CPError Bool -> Either CPError Bool -> Test
+f2b msg exp res = TestLabel msg $ TestCase $ assertEqual "" exp res
f2 msg exp res = TestLabel msg $ TestCase $ assertEqual "" exp res
f3 msg inp exp conv = TestLabel msg $ TestCase $ assertEqual "" exp (conv (p inp))
@@ -76,16 +80,15 @@ test_basic =
to_string
]
-
test_defaults =
let cp = p "def: ault\n[sect1]\nfoo: bar\nbaz: quuz\nint: 2\nfloat: 3\nbool: yes\n[sect4]\ndef: different" in
[
- f2 "default item" (Right "ault") (get cp "sect1" "def")
- ,f2 "normal item" (Right "bar") (get cp "sect1" "foo")
- ,f2 "no option" (Left (NoOption "abc", "get")) (get cp "sect1" "abc")
- ,f2 "no section" (Left (NoSection "sect2", "get")) (get cp "sect2" "foo")
- ,f2 "default from bad sect" (Right "ault") (get cp "sect2" "def")
- ,f2 "overriding default" (Right "different") (get cp "sect4" "def")
+ f2s "default item" (Right "ault") (get cp "sect1" "def")
+ ,f2s "normal item" (Right "bar") (get cp "sect1" "foo")
+ ,f2s "no option" (Left (NoOption "abc", "get")) (get cp "sect1" "abc")
+ ,f2s "no section" (Left (NoSection "sect2", "get")) (get cp "sect2" "foo")
+ ,f2s "default from bad sect" (Right "ault") (get cp "sect2" "def")
+ ,f2s "overriding default" (Right "different") (get cp "sect4" "def")
-- not in haskell: ,f2 "using default feature"
-- default int
-- default float
@@ -95,18 +98,25 @@ test_defaults =
test_nodefault =
let cp = (p "def: ault\n[sect1]\nfoo: bar\nbaz: quuz\nint: 2\nfloat: 3\nbool: yes\n[sect4]\ndef: different"){usedefault = False} in
[
- f2 "default item" (Left (NoOption "def", "get")) (get cp "sect1" "def")
- ,f2 "normal item" (Right "bar") (get cp "sect1" "foo")
- ,f2 "no option" (Left (NoOption "abc", "get")) (get cp "sect1" "abc")
- ,f2 "no section" (Left (NoSection "sect2", "get")) (get cp "sect2" "foo")
- ,f2 "default from bad sect" (Left (NoSection "sect2", "get")) (get cp "sect2" "def")
- ,f2 "overriding default" (Right "different") (get cp "sect4" "def")
+ f2s "default item" (Left (NoOption "def", "get")) (get cp "sect1" "def")
+ ,f2s "normal item" (Right "bar") (get cp "sect1" "foo")
+ ,f2s "no option" (Left (NoOption "abc", "get")) (get cp "sect1" "abc")
+ ,f2s "no section" (Left (NoSection "sect2", "get")) (get cp "sect2" "foo")
+ ,f2s "default from bad sect" (Left (NoSection "sect2", "get")) (get cp "sect2" "def")
+ ,f2s "overriding default" (Right "different") (get cp "sect4" "def")
-- not in haskell: ,f2 "using default feature"
-- default int
-- default float
-- default bool
]
+test_instances =
+ let cp = p "[x]\na: true\nb: 1\n"
+ in [f2b "bool 1st" (Right True) (get cp "x" "a"),
+ f2b "bool 1nd" (Right True) (get cp "x" "b")
+ ]
+
+
test_remove =
let cp = forceEither $ readstring emptyCP "def:ault\n[sect1]\ns1o1: v1\ns1o2:v2\n[sect2]\ns2o1: v1\ns2o2: v2\n[sect3]"
in [
@@ -188,20 +198,20 @@ test_interp =
cp = (forceEither $ (readstring emptyCP interpdoc)){ accessfunc = interpolatingAccess 5}
in
[
- f2 "basic" (Right "i386") (get cp "DEFAULT" "arch")
- ,f2 "filename" (Right "test_i386.c") (get cp "builder" "filename")
- ,f2 "dir" (Right "/usr/src/test_i386.c") (get cp "builder" "dir")
- ,f2 "percents" (Right "5%") (get cp "builder" "percent")
- ,f2 "error" (Left (InterpolationError "unresolvable interpolation reference to \"nonexistent\"", "interpolatingAccess")) (get cp "builder" "bad")
- ,f2 "recursive" (Left (InterpolationError "maximum interpolation depth exceeded", "interpolatingAccess"))
+ f2s "basic" (Right "i386") (get cp "DEFAULT" "arch")
+ ,f2s "filename" (Right "test_i386.c") (get cp "builder" "filename")
+ ,f2s "dir" (Right "/usr/src/test_i386.c") (get cp "builder" "dir")
+ ,f2s "percents" (Right "5%") (get cp "builder" "percent")
+ ,f2s "error" (Left (InterpolationError "unresolvable interpolation reference to \"nonexistent\"", "interpolatingAccess")) (get cp "builder" "bad")
+ ,f2s "recursive" (Left (InterpolationError "maximum interpolation depth exceeded", "interpolatingAccess"))
(get cp "builder" "recursive")
- ,f2 "syn1" (Left (InterpolationError "\"builder/syn1\" (line 1, column 6):\nunexpected \")\"\nexpecting interpolation name","interpolatingAccess"))
+ ,f2s "syn1" (Left (InterpolationError "\"builder/syn1\" (line 1, column 6):\nunexpected \")\"\nexpecting interpolation name","interpolatingAccess"))
(get cp "builder" "syn1")
- ,f2 "syn2" (Left (InterpolationError "\"builder/syn2\" (line 1, column 10):\nunexpected end of input\nexpecting \")s\"","interpolatingAccess"))
+ ,f2s "syn2" (Left (InterpolationError "\"builder/syn2\" (line 1, column 10):\nunexpected end of input\nexpecting \")s\"","interpolatingAccess"))
(get cp "builder" "syn2")
- ,f2 "syn3" (Left (InterpolationError "\"builder/syn3\" (line 1, column 4):\nunexpected \"s\"\nexpecting \"%(\"","interpolatingAccess"))
+ ,f2s "syn3" (Left (InterpolationError "\"builder/syn3\" (line 1, column 4):\nunexpected \"s\"\nexpecting \"%(\"","interpolatingAccess"))
(get cp "builder" "syn3")
- ,f2 "syn4" (Left (InterpolationError "\"builder/syn4\" (line 1, column 1):\nunexpected end of input\nexpecting \"%(\"","interpolatingAccess"))
+ ,f2s "syn4" (Left (InterpolationError "\"builder/syn4\" (line 1, column 1):\nunexpected end of input\nexpecting \"%(\"","interpolatingAccess"))
(get cp "builder" "syn4")
]
@@ -213,3 +223,4 @@ tests = TestList [TestLabel "test_basic" (TestList test_basic),
TestLabel "test_ex_nomonad" (TestCase test_ex_nomonad),
TestLabel "test_ex_errormonad" (TestList test_ex_errormonad),
TestLabel "test_interp" (TestList test_interp)]
+
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list