New module: Network.HTTP.Lucu.MIMEType.TH

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

diff --git a/Network/HTTP/Lucu/MIMEType/TH.hs b/Network/HTTP/Lucu/MIMEType/TH.hs
new file mode 100644 (file)
index 0000000..1aae0b4
--- /dev/null
+++ b/Network/HTTP/Lucu/MIMEType/TH.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  , ViewPatterns
+  #-}
+module Network.HTTP.Lucu.MIMEType.TH
+    ( mimeType
+    )
+    where
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Language.Haskell.TH.Syntax
+import Language.Haskell.TH.Quote
+import Network.HTTP.Lucu.MIMEType hiding (mimeType)
+import Network.HTTP.Lucu.Utils
+import Prelude.Unicode
+
+-- |A 'QuasiQuoter' for 'MIMEType' literals.
+--
+-- @
+--   textPlain :: 'MIMEType'
+--   textPlain = ['mimeType'| text/plain; charset="UTF-8" |]
+-- @
+mimeType ∷ QuasiQuoter
+mimeType = QuasiQuoter {
+             quoteExp  = (lift ∘ parseMIMEType =≪) ∘ toAscii
+           , quotePat  = const unsupported
+           , quoteType = const unsupported
+           , quoteDec  = const unsupported
+           }
+    where
+      toAscii ∷ Monad m ⇒ String → m Ascii
+      toAscii (A.fromChars ∘ trim → Just a) = return a
+      toAscii str = fail $ "Malformed MIME Type: " ⧺ str
+
+      unsupported ∷ Monad m ⇒ m α
+      unsupported = fail "Unsupported usage of mimeType quasi-quoter."