-import Data.Map (Map)
-import Data.Maybe
-import Language.Haskell.Pretty
-import Language.Haskell.Syntax
-import Network.HTTP.Lucu.MIMEType
-import Network.HTTP.Lucu.Parser
-import Network.HTTP.Lucu.Parser.Http
-import Network.HTTP.Lucu.Utils
-import System.IO
-
-type ExtMap = Map String MIMEType
-
-
-guessTypeByFileName :: ExtMap -> FilePath -> Maybe MIMEType
-guessTypeByFileName extMap fpath
- = let ext = last $ splitBy (== '.') fpath
- in
- M.lookup ext extMap >>= return
-
-
-parseExtMapFile :: FilePath -> IO ExtMap
-parseExtMapFile fpath
- = 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 ++ ")")
-
-
-extMapP :: Parser [ (MIMEType, [String]) ]
-extMapP = do xs <- many (comment <|> validLine <|> emptyLine)
- eof
- return $ catMaybes xs
+import Data.Map (Map)
+import Data.Maybe
+import Data.Typeable
+import Data.Monoid
+import Data.Monoid.Unicode
+import Data.Text (Text)
+import qualified Data.Text as T
+import Data.Text.Encoding
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
+import Network.HTTP.Lucu.MIMEType
+import Network.HTTP.Lucu.Parser
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+import System.FilePath
+
+-- |A 'Map' from file extensions to 'MIMEType's.
+newtype ExtMap
+ = ExtMap (Map Text MIMEType)
+ deriving (Eq, Show, Read, Monoid, Typeable)
+
+instance Lift ExtMap where
+ lift (ExtMap m)
+ = [| ExtMap $(liftMap liftText lift m) |]
+
+-- |'QuasiQuoter' for 'ExtMap' reading Apache @mime.types@.
+--
+-- @
+-- m :: 'ExtMap'
+-- m = ['extMap'|
+-- # MIME Type Extensions
+-- application/xhtml+xml xhtml
+-- image/jpeg jpeg jpg
+-- image/png png
+-- image/svg+xml svg
+-- text/html html
+-- text/plain txt
+-- |]
+-- @
+extMap ∷ QuasiQuoter
+extMap = QuasiQuoter {
+ quoteExp = (lift ∘ parseExtMap =≪) ∘ toAscii
+ , quotePat = const unsupported
+ , quoteType = const unsupported
+ , quoteDec = const unsupported
+ }
+ where
+ toAscii ∷ Monad m ⇒ String → m Ascii
+ toAscii (A.fromChars → Just a) = return a
+ toAscii _ = fail "Malformed extension map"
+
+ unsupported ∷ Monad m ⇒ m α
+ unsupported = fail "Unsupported usage of extMap quasi-quoter."
+
+-- |Parse Apache @mime.types@.
+parseExtMap ∷ Ascii → ExtMap
+parseExtMap src
+ = case parseOnly (finishOff extMapP) $ A.toByteString src of
+ Right xs → case compile xs of
+ Right m → ExtMap m
+ Left e → error ("Duplicate extension: " ⧺ show e)
+ Left err → error ("Unparsable extension map: " ⧺ err)
+
+extMapP ∷ Parser [(MIMEType, [Text])]
+extMapP = catMaybes <$> P.many (try comment <|> try validLine <|> emptyLine)