From 087dd4f3ffb5aba8107c38f2eae0c82545ec21ca Mon Sep 17 00:00:00 2001
From: PHO <pho@cielonegro.org>
Date: Fri, 13 Jan 2012 07:46:58 +0900
Subject: [PATCH] Parser and co-parser for Data.URI.Scheme

Ditz-issue: c80e79a2585ac20cc5ed677d70b6983a2842a81d
---
 Data/URI.hs                 |  1 -
 Data/URI/Internal.hs        | 37 ++++++++++++++++++++++++++++
 Data/URI/Internal/Scheme.hs | 48 +++++++++++++++++++++++++++++++------
 Lucu.cabal                  |  1 +
 4 files changed, 79 insertions(+), 8 deletions(-)
 create mode 100644 Data/URI/Internal.hs

diff --git a/Data/URI.hs b/Data/URI.hs
index 11618bd..c55a55f 100644
--- a/Data/URI.hs
+++ b/Data/URI.hs
@@ -1,7 +1,6 @@
 -- |FIXME
 module Data.URI
     ( Scheme
-    , unsafeCreateScheme
     )
     where
 import Data.URI.Internal.Scheme
diff --git a/Data/URI/Internal.hs b/Data/URI/Internal.hs
new file mode 100644
index 0000000..ffb8a7b
--- /dev/null
+++ b/Data/URI/Internal.hs
@@ -0,0 +1,37 @@
+{-# LANGUAGE
+    UnicodeSyntax
+  #-}
+module Data.URI.Internal
+    ( finishOff
+    , parseAttempt
+    , parseAttempt'
+    )
+    where
+import Control.Applicative
+import Control.Exception.Base
+import Control.Monad.Unicode
+import Data.Ascii (Ascii)
+import qualified Data.Ascii as A
+import Data.Attempt
+import Data.Attoparsec.Char8
+import Data.ByteString (ByteString)
+import Prelude.Unicode
+
+finishOff ∷ Parser α → Parser α
+{-# INLINE finishOff #-}
+finishOff = ((endOfInput *>) ∘ return =≪)
+
+parseAttempt ∷ Exception e
+             ⇒ (String → e)
+             → Parser α
+             → ByteString
+             → Attempt α
+{-# INLINEABLE parseAttempt #-}
+parseAttempt f p bs
+    = case parseOnly (finishOff p) bs of
+        Right α → Success α
+        Left  e → Failure $ f e
+
+parseAttempt' ∷ Parser α → Ascii → Attempt α
+{-# INLINE parseAttempt' #-}
+parseAttempt' = (∘ A.toByteString) ∘ parseAttempt StringException
diff --git a/Data/URI/Internal/Scheme.hs b/Data/URI/Internal/Scheme.hs
index d77fdb5..2e3ba24 100644
--- a/Data/URI/Internal/Scheme.hs
+++ b/Data/URI/Internal/Scheme.hs
@@ -1,19 +1,30 @@
 {-# LANGUAGE
     DeriveDataTypeable
+  , FlexibleInstances
   , GeneralizedNewtypeDeriving
+  , MultiParamTypeClasses
   , StandaloneDeriving
+  , TemplateHaskell
+  , TypeSynonymInstances
   , UnicodeSyntax
   #-}
 module Data.URI.Internal.Scheme
     ( Scheme
-    , unsafeCreateScheme
     )
     where
 import Data.Ascii (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,
@@ -27,14 +38,37 @@ newtype Scheme = Scheme CIAscii
              , Show
              , Typeable
              )
--- scheme = ALPHA *( ALPHA / DIGIT / "+" / "-" / "." )
 
 -- |'isString' 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 ∨
+                c ≡ '+'         ∨
+                c ≡ '-'         ∨
+                c ≡ '.'
+          {-# INLINE fromBS #-}
+          fromBS = Scheme ∘ A.toCIAscii ∘ A.unsafeFromByteString
+
+instance ConvertSuccess Scheme CIAscii where
+    {-# INLINE convertSuccess #-}
+    convertSuccess (Scheme s) = s
+
+instance ConvertAttempt CIAscii Scheme where
+    {-# INLINE convertAttempt #-}
+    convertAttempt = parseAttempt' def ∘ A.fromCIAscii
+
+deriveAttempts [ ([t| Scheme |], [t| CIAscii |])
+               ]
diff --git a/Lucu.cabal b/Lucu.cabal
index cff6ae8..2778a2a 100644
--- a/Lucu.cabal
+++ b/Lucu.cabal
@@ -122,6 +122,7 @@ Library
         Network.HTTP.Lucu.Utils
 
     Other-Modules:
+        Data.URI.Internal
         Data.URI.Internal.Scheme
         Network.HTTP.Lucu.Abortion.Internal
         Network.HTTP.Lucu.Chunk
-- 
2.40.0