[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:45:12 UTC 2010
The following commit has been merged in the master branch:
commit ed5b883aefa18a2197568d5dfc4e6da8aa4a605f
Author: John Goerzen <jgoerzen at complete.org>
Date: Thu Oct 21 23:15:45 2004 +0100
Working guessType and tests for it
Keywords:
(jgoerzen at complete.org--projects/missingh--head--1.0--patch-93)
diff --git a/ChangeLog b/ChangeLog
index 461b14a..9d24959 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,22 @@
# arch-tag: automatic-ChangeLog--jgoerzen at complete.org--projects/missingh--head--1.0
#
+2004-10-21 17:15:45 GMT John Goerzen <jgoerzen at complete.org> patch-93
+
+ Summary:
+ Working guessType and tests for it
+ Revision:
+ missingh--head--1.0--patch-93
+
+
+ new files:
+ testsrc/MIMETypestest.hs
+
+ modified files:
+ ChangeLog libsrc/MissingH/FiniteMap.hs
+ libsrc/MissingH/MIMETypes.hs testsrc/Tests.hs
+
+
2004-10-21 14:17:52 GMT John Goerzen <jgoerzen at complete.org> patch-92
Summary:
diff --git a/libsrc/MissingH/FiniteMap.hs b/libsrc/MissingH/FiniteMap.hs
index f3a22e7..8d7dcc1 100644
--- a/libsrc/MissingH/FiniteMap.hs
+++ b/libsrc/MissingH/FiniteMap.hs
@@ -47,7 +47,8 @@ flipFM :: (Ord key, Ord val) => FiniteMap key val -> FiniteMap val [key]
flipFM = listToFM . flipAL . fmToList
{- | Returns a list of all keys in the finite map whose value matches the
-parameter. -}
+parameter. If the value does not occur in the finite map, the empty
+list is returned. -}
flippedLookupFM :: (Ord val, Ord key) => FiniteMap key val -> val-> [key]
flippedLookupFM fm v =
diff --git a/libsrc/MissingH/MIMETypes.hs b/libsrc/MissingH/MIMETypes.hs
index 122f4f3..a92ea30 100644
--- a/libsrc/MissingH/MIMETypes.hs
+++ b/libsrc/MissingH/MIMETypes.hs
@@ -32,7 +32,7 @@ Written by John Goerzen, jgoerzen\@complete.org
-}
module MissingH.MIMETypes (-- * Creating Lookup Objects
- defaultMIMETypeData,
+ defaultmtd,
readMIMETypes,
hReadMIMETypes,
readSystemMIMETypes,
@@ -51,6 +51,8 @@ import Monad
import System.IO
import System.IO.Error
import MissingH.IO
+import MissingH.Path
+import Data.Char
----------------------------------------------------------------------
-- Basic type decl
@@ -130,8 +132,23 @@ guessType :: MIMETypeData -- ^ Source data for guessing
-> Bool -- ^ Whether to limit to strict data
-> String -- ^ File or URL name to consider
-> MIMEResults -- ^ Result of guessing (see 'MIMEResults' for details on interpreting it)
--- FIXME
-guessType mtd strict fn = (Nothing, Nothing)
+guessType mtd strict fn =
+ let mapext (base, ext) =
+ case lookupFM (suffixMap mtd) ext of
+ Nothing -> (base, ext)
+ Just x -> mapext (splitext (base ++ x))
+ checkencodings (base, ext) =
+ case lookupFM (encodingsMap mtd) ext of
+ Nothing -> (base, ext, Nothing)
+ Just x -> (fst (splitext base),
+ snd (splitext base),
+ Just x)
+ (base, ext, enc) = checkencodings . mapext $ splitext fn
+ typemap = getStrict mtd strict
+ in
+ case lookupFM typemap ext of
+ Nothing -> (lookupFM typemap (map toLower ext), enc)
+ Just x -> (Just x, enc)
{- | Guess the extension of a file based on its MIME type.
The return value includes the leading dot.
@@ -156,8 +173,8 @@ addType :: MIMETypeData -- ^ Source data
addType mtd strict thetype theext = mtd
{- | Default MIME type data to use -}
-defaultMIMETypeData :: MIMETypeData
-defaultMIMETypeData =
+defaultmtd :: MIMETypeData
+defaultmtd =
MIMETypeData {suffixMap = default_suffix_map,
encodingsMap = default_encodings_map,
typesMap = default_types_map,
diff --git a/testsrc/MIMETypestest.hs b/testsrc/MIMETypestest.hs
new file mode 100644
index 0000000..753df75
--- /dev/null
+++ b/testsrc/MIMETypestest.hs
@@ -0,0 +1,40 @@
+{- arch-tag: MIMETypes tests main file
+Copyright (C) 2004 John Goerzen <jgoerzen at complete.org>
+
+This program is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
+-}
+
+module MIMETypestest(tests) where
+import HUnit
+import MissingH.MIMETypes
+
+test_guessType =
+ let f strict inp exp = exp @=? guessType defaultmtd strict inp in
+ do
+ f True "" (Nothing, Nothing)
+ f True "foo" (Nothing, Nothing)
+ f True "foo.txt" (Just "text/plain", Nothing)
+ f True "foo.txt.gz" (Just "text/plain", Just "gzip")
+ f True "foo.txt.blah" (Nothing, Nothing)
+ f True "foo.tar" (Just "application/x-tar", Nothing)
+ f True "foo.tar.gz" (Just "application/x-tar", Just "gzip")
+ f True "foo.tgz" (Just "application/x-tar", Just "gzip")
+ f True "http://foo/test.dir/blah.rtf" (Nothing, Nothing)
+ f False "http://foo/test.dir/blah.rtf" (Just "application/rtf", Nothing)
+ f True "foo.pict" (Nothing, Nothing)
+ f False "foo.pict" (Just "image/pict", Nothing)
+
+tests = TestList [TestLabel "guessType" (TestCase test_guessType)
+ ]
\ No newline at end of file
diff --git a/testsrc/Tests.hs b/testsrc/Tests.hs
index 2e890d1..106b60f 100644
--- a/testsrc/Tests.hs
+++ b/testsrc/Tests.hs
@@ -18,6 +18,7 @@ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
module Tests(tests) where
import HUnit
+import qualified MIMETypestest
import qualified Listtest
import qualified FiniteMaptest
import qualified Pathtest
@@ -30,6 +31,7 @@ tests = TestList [TestLabel "test1" test1,
TestLabel "List" Listtest.tests,
TestLabel "Str" Strtest.tests,
TestLabel "FiniteMap" FiniteMaptest.tests,
- TestLabel "Path" Pathtest.tests]
+ TestLabel "Path" Pathtest.tests,
+ TestLabel "MIMETypes" MIMETypestest.tests]
--
haskell-testpack
More information about the Pkg-haskell-commits
mailing list