Code reorganisation

[Lucu.git] / Network / HTTP / Lucu / StatusCode / Internal.hs

diff --git a/Network/HTTP/Lucu/StatusCode/Internal.hs b/Network/HTTP/Lucu/StatusCode/Internal.hs
deleted file mode 100644 (file)
index 026b1a8..0000000
--- a/Network/HTTP/Lucu/StatusCode/Internal.hs
+++ /dev/null
@@ -1,199 +0,0 @@
-{-# LANGUAGE
-    ExistentialQuantification
-  , FlexibleInstances
-  , MultiParamTypeClasses
-  , OverlappingInstances
-  , TemplateHaskell
-  , TypeFamilies
-  , UndecidableInstances
-  , UnicodeSyntax
-  , ViewPatterns
-  #-}
-{-# OPTIONS_GHC -fno-warn-orphans #-}
-module Network.HTTP.Lucu.StatusCode.Internal
-    ( StatusCode(..)
-    , SomeStatusCode
-    , statusCodes
-    )
-    where
-import Control.Applicative
-import Data.Ascii (Ascii, AsciiBuilder)
-import qualified Data.Ascii as A
-import Data.Attoparsec.Char8
-import qualified Data.Attoparsec.Lazy as LP
-import qualified Data.ByteString.Lazy.Char8 as Lazy
-import Data.Convertible.Base
-import Data.Convertible.Instances.Ascii ()
-import Data.Convertible.Utils
-import Data.List
-import Language.Haskell.TH.Lib
-import Language.Haskell.TH.Syntax
-import Language.Haskell.TH.Quote
-import Network.HTTP.Lucu.Parser
-import Prelude.Unicode
-
--- |Type class for HTTP status codes.
---
--- Declaring types for each statuses is surely a pain. See:
--- 'statusCodes' quasi-quoter.
---
--- Minimal complete definition: 'numericCode' and 'textualStatus'.
-class (Eq sc, Show sc) ⇒ StatusCode sc where
-    -- |Return the 3-digit integer for this status e.g. @200@
-    numericCode ∷ sc → Int
-    -- |Return the combination of 3-digit integer and reason phrase
-    -- for this status e.g. @200 OK@
-    textualStatus ∷ sc → AsciiBuilder
-    -- |Wrap the status code into 'SomeStatusCode'.
-    fromStatusCode ∷ sc → SomeStatusCode
-    fromStatusCode = SomeStatusCode
-
-instance StatusCode sc ⇒ ConvertSuccess sc SomeStatusCode where
-    {-# INLINE convertSuccess #-}
-    convertSuccess = fromStatusCode
-
-instance StatusCode sc ⇒ ConvertSuccess sc Ascii where
-    {-# INLINE convertSuccess #-}
-    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)
-
-instance StatusCode sc ⇒ ConvertSuccess sc AsciiBuilder where
-    {-# INLINE convertSuccess #-}
-    convertSuccess = textualStatus
-
-instance StatusCode sc ⇒ ConvertAttempt sc SomeStatusCode where
-    {-# INLINE convertAttempt #-}
-    convertAttempt = return ∘ cs
-
-instance StatusCode sc ⇒ ConvertAttempt sc Ascii where
-    {-# INLINE convertAttempt #-}
-    convertAttempt = return ∘ cs
-
-instance StatusCode sc ⇒ ConvertAttempt sc AsciiBuilder where
-    {-# INLINE convertAttempt #-}
-    convertAttempt = return ∘ cs
-
--- |Container type for the 'StatusCode' type class.
-data SomeStatusCode
-    = ∀sc. StatusCode sc ⇒ SomeStatusCode sc
-
--- |Equivalence of 'StatusCode's. Two 'StatusCode's @α@ and
--- @β@ are said to be equivalent iff @'numericCode' α '=='
--- 'numericCode' β@.
-instance Eq SomeStatusCode where
-    {-# INLINE (==) #-}
-    (==) = (∘ numericCode) ∘ (==) ∘ numericCode
-
-instance Show SomeStatusCode where
-    show (SomeStatusCode sc) = show sc
-
-instance StatusCode SomeStatusCode where
-    numericCode   (SomeStatusCode sc) = numericCode   sc
-    textualStatus (SomeStatusCode sc) = textualStatus sc
-    fromStatusCode = id
-
--- |'QuasiQuoter' for 'StatusCode' declarations.
---
--- Top-level splicing
---
--- @
---   ['statusCodes'|
---   200 OK
---   400 Bad Request
---   405 Method Not Allowed
---   |]
--- @
---
--- becomes:
---
--- @
---   data OK = OK deriving ('Eq', 'Show')
---   instance OK where
---     'numericCode'   _ = 200
---     'textualStatus' _ = 'cs' (\"200 OK\" ∷ Ascii)
---
---   data BadRequest = BadRequest deriving ('Eq', 'Show')
---   instance BadRequest where
---     'numericCode'   _ = 400
---     'textualStatus' _ = 'cs' (\"400 Bad Request\" ∷ Ascii)
---
---   data MethodNotAllowed = MethodNotAllowed deriving ('Eq', 'Show')
---   instance MethodNotAllowed where
---     'numericCode'   _ = 405
---     'textualStatus' _ = 'cs' (\"405 Method Not Allowed\" ∷ Ascii)
--- @
-statusCodes ∷ QuasiQuoter
-statusCodes = QuasiQuoter {
-                quoteExp  = const unsupported
-              , quotePat  = const unsupported
-              , quoteType = const unsupported
-              , quoteDec  = (concat <$>) ∘ mapM statusDecl ∘ parseStatusCodes ∘ Lazy.pack
-              }
-    where
-      unsupported ∷ Monad m ⇒ m α
-      unsupported = fail "Unsupported usage of statusCodes quasi-quoter."
-
-parseStatusCodes ∷ Lazy.ByteString → [(Int, [Ascii])]
-parseStatusCodes src
-    = case LP.parse pairs src of
-        LP.Fail _ eCtx e
-            → error $ "Unparsable status codes: "
-                    ⧺ intercalate ", " eCtx
-                    ⧺ ": "
-                    ⧺ e
-        LP.Done _ xs
-            → xs
-    where
-      pairs ∷ Parser [(Int, [Ascii])]
-      pairs = do skipMany endOfLine
-                 xs ← sepBy pair (skipMany1 endOfLine)
-                 skipMany endOfLine
-                 endOfInput
-                 return xs
-              <?>
-              "pairs"
-
-      pair ∷ Parser (Int, [Ascii])
-      pair = do skipSpace
-                num ← decimal
-                skipSpace1
-                phrase ← sepBy1 word $ skipWhile1 (≡ '\x20')
-                return (num, phrase)
-             <?>
-             "pair"
-
-      word ∷ Parser Ascii
-      word = A.unsafeFromByteString <$> takeWhile1 isAlpha_ascii
-
-statusDecl ∷ (Int, [Ascii]) → Q [Dec]
-statusDecl (num, phrase)
-    = do a  ← dataDecl
-         bs ← instanceDecl
-         return (a:bs)
-    where
-      name ∷ Name
-      name = mkName $ concatMap cs phrase
-
-      dataDecl ∷ Q Dec
-      dataDecl = dataD (cxt []) name [] [con] [''Eq, ''Show]
-
-      instanceDecl ∷ Q [Dec]
-      instanceDecl
-          = [d| instance StatusCode $typ where
-                  {-# INLINE CONLIKE numericCode #-}
-                  numericCode _ = $(lift num)
-                  {-# INLINE CONLIKE textualStatus #-}
-                  textualStatus _ = $txt
-              |]
-
-      typ ∷ Q Type
-      typ = conT name
-
-      con ∷ Q Con
-      con = return $ NormalC name []
-
-      txt ∷ Q Exp
-      txt = [| cs ($(lift txt') ∷ Ascii) |]
-
-      txt' ∷ String
-      txt' = concat $ intersperse "\x20"
-                    $ show num : map cs phrase