Lucu now *requires* base >= 4.

[Lucu.git] / Network / HTTP / Lucu / MIMEType / Guess.hs

diff --git a/Network/HTTP/Lucu/MIMEType/Guess.hs b/Network/HTTP/Lucu/MIMEType/Guess.hs
index a0ea1646b4e8e3c29493e0e89743145db825b0c5..d94711ac624cdfa9878243b55f46b1dbca61b223 100644 (file)
--- a/Network/HTTP/Lucu/MIMEType/Guess.hs
+++ b/Network/HTTP/Lucu/MIMEType/Guess.hs
@@ -1,5 +1,5 @@
--- |MIME Type guesser which guesses by a file extension. This is a
--- poor man's way of guessing MIME Types. It is simple and fast.
+-- |MIME Type guessing by a file extension. This is a poor man's way
+-- of guessing MIME Types. It is simple and fast.
 --
 -- In general you don't have to use this module directly.
 module Network.HTTP.Lucu.MIMEType.Guess
@@ -23,7 +23,7 @@ import           Network.HTTP.Lucu.Parser.Http
 import           Network.HTTP.Lucu.Utils
 import           System.IO
 
--- |Map from extension to MIME Type.
+-- |'Data.Map.Map' from extension to MIME Type.
 type ExtMap = Map String MIMEType
 
 -- |Guess the MIME Type of file.
@@ -40,10 +40,13 @@ parseExtMapFile fpath
     = fpath `seq`
       do file <- B.readFile fpath
          case parse (allowEOF extMapP) file of
-           (Success xs, _) -> return $ compile xs
-           (_, input')     -> let near = B.unpack $ B.take 100 input'
-                              in 
-                                fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
+           (# Success xs, _ #)
+               -> return $ compile xs
+
+           (# _, input' #)
+               -> let near = B.unpack $ B.take 100 input'
+                  in 
+                    fail ("Failed to parse: " ++ fpath ++ " (near: " ++ near ++ ")")
 
 
 extMapP :: Parser [ (MIMEType, [String]) ]
@@ -88,7 +91,7 @@ serializeExtMap extMap moduleName variableName
     = let hsModule = HsModule undefined modName (Just exports) imports decls
           modName  = Module moduleName
           exports  = [HsEVar (UnQual (HsIdent variableName))]
-          imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing Nothing
+          imports  = [ HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType") False Nothing (Just (False, []))
                      , HsImportDecl undefined (Module "Network.HTTP.Lucu.MIMEType.Guess") False Nothing Nothing
                      , HsImportDecl undefined (Module "Data.Map") True (Just (Module "M")) Nothing
                      ]
@@ -99,9 +102,9 @@ serializeExtMap extMap moduleName variableName
                                   [] (HsUnGuardedRhs extMapExp) []]
                      ]
           extMapExp = HsApp (HsVar (Qual (Module "M") (HsIdent "fromList"))) (HsList records)
-          comment =    "{- !!! WARNING !!!\n"
-                    ++ "   This file is automatically generated.\n"
-                    ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
+          comment   =    "{- !!! WARNING !!!\n"
+                      ++ "   This file is automatically generated.\n"
+                      ++ "   DO NOT EDIT BY HAND OR YOU WILL REGRET -}\n\n"
       in
         comment ++ prettyPrint hsModule ++ "\n"
     where
@@ -113,19 +116,5 @@ serializeExtMap extMap moduleName variableName
           = HsTuple [HsLit (HsString ext), mimeToExp mime]
                     
       mimeToExp :: MIMEType -> HsExp
-      mimeToExp (MIMEType maj min params)
-          = foldl appendParam (HsInfixApp
-                               (HsLit (HsString maj))
-                               (HsQVarOp (UnQual (HsSymbol "</>")))
-                               (HsLit (HsString min))) params
-
-      appendParam :: HsExp -> (String, String) -> HsExp
-      appendParam x param
-          = HsInfixApp x (HsQVarOp (UnQual (HsSymbol "<:>"))) $ paramToExp param
-
-      paramToExp :: (String, String) -> HsExp
-      paramToExp (name, value)
-          = HsInfixApp
-            (HsLit (HsString name))
-            (HsQVarOp (UnQual (HsSymbol "<=>")))
-            (HsLit (HsString value))
\ No newline at end of file
+      mimeToExp mt
+          = HsApp (HsVar (UnQual (HsIdent "read"))) (HsLit (HsString $ show mt))