X-Git-Url: http://git.cielonegro.org/gitweb.cgi?a=blobdiff_plain;f=Data%2FURI%2FInternal%2FScheme.hs;h=7b8fd5209bc771c53253d27703c20ada55414b96;hb=4a9daff;hp=d77fdb5f184ea333d1aab8049f64ea56c37fa985;hpb=898b208c298d71a13869c46ed96518de23a5a30f;p=Lucu.git

diff --git a/Data/URI/Internal/Scheme.hs b/Data/URI/Internal/Scheme.hs
index d77fdb5..7b8fd52 100644
--- a/Data/URI/Internal/Scheme.hs
+++ b/Data/URI/Internal/Scheme.hs
@@ -1,23 +1,35 @@
 {-# LANGUAGE
     DeriveDataTypeable
+  , FlexibleInstances
   , GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses
   , StandaloneDeriving
+  , TemplateHaskell
+  , TypeSynonymInstances
   , UnicodeSyntax
   #-}
 module Data.URI.Internal.Scheme
     ( Scheme
-    , unsafeCreateScheme
     )
     where
-import Data.Ascii (CIAscii)
+import Data.Ascii (AsciiBuilder, CIAscii)
+import qualified Data.Ascii as A
+import Data.Attoparsec.Char8
+import qualified Data.ByteString.Char8 as BS
 import Data.CaseInsensitive
+import Data.Convertible.Base
+import Data.Default
 import Data.Hashable
 import Data.String
+import Data.URI.Internal
 import Data.Typeable
+import Prelude hiding (takeWhile)
+import Prelude.Unicode
 
 -- |'Scheme' names consist of a non-empty sequence of characters
 -- beginning with a letter and followed by any combination of letters,
--- digits, plus (\'+\'), period (\'.\'), or hyphen (\'-\'):
+-- digits, plus (\'+\'), period (\'.\'), or hyphen (\'-\'). Comparison
+-- of 'Scheme's are always case-insensitive. See:
 -- <http://tools.ietf.org/html/rfc3986#section-3.1>
 newtype Scheme = Scheme CIAscii
     deriving ( Eq
@@ -27,14 +39,43 @@ newtype Scheme = Scheme CIAscii
              , Show
              , Typeable
              )
--- scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )
 
--- |'isString' is a fast but unsafe way to create 'Scheme' such that
+-- |'fromString' is a fast but unsafe way to create 'Scheme' such that
 -- no validation on the string is performed.
 deriving instance IsString Scheme
 
--- |Converts a 'CIAscii' to 'Scheme' without any validation on the
--- string.
-unsafeCreateScheme ∷ CIAscii → Scheme
-{-# INLINE CONLIKE unsafeCreateScheme #-}
-unsafeCreateScheme = Scheme
+instance Default (Parser Scheme) where
+    {-# INLINEABLE def #-}
+    def = do x  ← satisfy first
+             xs ← takeWhile nonFirst
+             return ∘ fromBS $ x `BS.cons` xs
+          <?>
+          "scheme"
+        where
+          {-# INLINE first #-}
+          first = isAlpha_ascii
+          {-# INLINE nonFirst #-}
+          nonFirst c
+              = isAlpha_ascii c ∨
+                isDigit c       ∨
+                c ≡ '+'         ∨
+                c ≡ '-'         ∨
+                c ≡ '.'
+          {-# INLINE fromBS #-}
+          fromBS = Scheme ∘ A.toCIAscii ∘ A.unsafeFromByteString
+
+instance ConvertSuccess Scheme CIAscii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess (Scheme s) = foldCase s
+
+instance ConvertSuccess Scheme AsciiBuilder where
+    {-# INLINE convertSuccess #-}
+    convertSuccess = A.toAsciiBuilder ∘ A.fromCIAscii ∘ cs
+
+instance ConvertAttempt CIAscii Scheme where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = parseAttempt' def ∘ A.fromCIAscii
+
+deriveAttempts [ ([t| Scheme |], [t| AsciiBuilder |])
+               , ([t| Scheme |], [t| CIAscii      |])
+               ]