uri-templater 0.2.2.0 → 0.3.0.0

raw patch · 5 files changed

+188/−82 lines, 5 filesdep +bytestringdep ~basedep ~containersPVP ok

version bump matches the API change (PVP)

Dependencies added: bytestring

Dependency ranges changed: base, containers

API changes (from Hackage documentation)

Files

• src/Network/URI/Template.hs +1/−0
• src/Network/URI/Template/Internal.hs +134/−52
• src/Network/URI/Template/Types.hs +5/−1
• test/Test.hs +45/−27
• uri-templater.cabal +3/−2

@@ -10,6 +10,7 @@   , ToTemplateValue(..)   , AList(..)   , TemplateString(..)+  , Buildable(..) ) where import Network.URI.Template.Internal import Network.URI.Template.Parser

@@ -1,21 +1,78 @@-{-# LANGUAGE RankNTypes, GADTs, ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE TypeSynonymInstances #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FlexibleContexts #-} module Network.URI.Template.Internal where import Control.Monad.Writer.Strict+import qualified Data.ByteString.Builder as BB+import qualified Data.ByteString.Char8 as BS+import qualified Data.ByteString.Lazy.Char8 as BL+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TB+ import Data.DList hiding (map) import Data.List (intersperse) import Data.Maybe import Data.Monoid+import Data.Proxy import Network.HTTP.Base (urlEncode) import Network.URI.Template.Types -type StringBuilder = Writer (DList Char)+class Monoid (StringBuilder a) => Buildable a where+  type StringBuilder a+  build :: StringBuilder a -> a+  addChar :: Proxy a -> Char -> StringBuilder a+  addString :: Proxy a -> String -> StringBuilder a -addChar :: Char -> StringBuilder ()-addChar = tell . singleton+instance Buildable String where+  type StringBuilder String = DList Char+  build = Data.DList.toList+  addChar _ = singleton+  addString _ = fromList -addString :: String -> StringBuilder ()-addString = tell . fromList+instance Buildable BS.ByteString where+  type StringBuilder BS.ByteString = BB.Builder+  build = BL.toStrict . BB.toLazyByteString+  addChar _ = BB.char8+  addString _ = BB.string8 +instance Buildable BL.ByteString where+  type StringBuilder BL.ByteString = BB.Builder+  build = BB.toLazyByteString+  addChar _ = BB.char8+  addString _ = BB.string8++instance Buildable T.Text where+  type StringBuilder T.Text = TB.Builder+  build = TL.toStrict . TB.toLazyText+  addChar _ = TB.singleton+  addString _ = TB.fromString++instance Buildable TL.Text where+  type StringBuilder TL.Text = TB.Builder+  build = TB.toLazyText+  addChar _ = TB.singleton+  addString _ = TB.fromString++instance Buildable BB.Builder where+  type StringBuilder BB.Builder = BB.Builder+  build = id+  addChar _ = BB.char8+  addString _ = BB.string8++instance Buildable TB.Builder where+  type StringBuilder TB.Builder = TB.Builder+  build = id+  addChar _ = TB.singleton+  addString _ = TB.fromString++-- instance Buildable (Path, QueryParams, Hash)+ data Allow = Unreserved | UnreservedOrReserved  allowEncoder Unreserved           = urlEncode@@ -50,36 +107,47 @@ templateValueIsEmpty (Associative s) = null s templateValueIsEmpty (List s)        = null s -namePrefix :: ProcessingOptions -> String -> TemplateValue a -> StringBuilder ()-namePrefix opts name val = do-  addString name-  if templateValueIsEmpty val-    then maybe (return ()) addChar $ modifierIfEmpty opts-    else addChar '='+namePrefix :: forall str a.+              (Buildable str)+           => Proxy str -> ProcessingOptions -> String -> TemplateValue a -> StringBuilder str+namePrefix p opts name val = addString p name <> if templateValueIsEmpty val+  then maybe mempty (addChar p) $ modifierIfEmpty opts+  else addChar p '=' -processVariable :: Modifier -> Bool -> Variable -> WrappedValue -> StringBuilder ()-processVariable m isFirst (Variable varName varMod) (WrappedValue val) = do-  if isFirst-    then maybe (return ()) addChar $ modifierPrefix settings-    else addChar $ modifierSeparator settings-  case varMod of-    Normal -> do-      when (modifierSupportsNamed settings) (namePrefix settings varName val)-      unexploded-    Explode -> exploded-    (MaxLength l) -> do-      when (modifierSupportsNamed settings) (namePrefix settings varName val)-      unexploded+whenM :: Monoid m => Bool -> m -> m+whenM pred m = if pred then m else mempty++processVariable+  :: forall str.+     (Buildable str)+  => Proxy str -> Modifier -> Bool -> Variable -> WrappedValue -> StringBuilder str+processVariable p m isFirst (Variable varName varMod) (WrappedValue val) =+  let prefix = maybe mempty (addChar p) $ modifierPrefix settings+      separator = addChar p $ modifierSeparator settings+      rest = case varMod of+        Normal -> do+          whenM+            (modifierSupportsNamed settings)+            (namePrefix p settings varName val) <> unexploded+        Explode -> exploded+        MaxLength l ->+          whenM+            (modifierSupportsNamed settings)+            (namePrefix p settings varName val) <> unexploded+  in (if isFirst then prefix else separator) <> rest   where     settings = options m -    addEncodeString :: String -> StringBuilder ()-    addEncodeString = addString . (allowEncoder $ modifierAllow settings)+    addEncodeString :: String -> StringBuilder str+    addEncodeString = addString p . (allowEncoder $ modifierAllow settings) -    sepByCommas = sequence_ . intersperse (addChar ',')+    sepByCommas = mconcat . intersperse (addChar p ',') -    associativeCommas :: (String -> String) -> (TemplateValue Single, TemplateValue Single) -> StringBuilder ()-    associativeCommas f (Single n, Single v) = addEncodeString n >> addChar ',' >> addEncodeString (f v)+    associativeCommas :: (String -> String) -> (TemplateValue Single, TemplateValue Single) -> StringBuilder str+    associativeCommas f (Single n, Single v) =+      addEncodeString n <>+      addChar p ',' <>+      addEncodeString (f v)      preprocess :: String -> String     preprocess = case varMod of@@ -91,43 +159,57 @@       (List l) -> sepByCommas $ map (\(Single s) -> addEncodeString $ preprocess s) l       (Single s) -> addEncodeString $ preprocess s -    explodedAssociative :: (TemplateValue Single, TemplateValue Single) -> StringBuilder ()-    explodedAssociative (Single k, Single v) = do-      addEncodeString k-      addChar '='-      addEncodeString $ preprocess v+    explodedAssociative :: (TemplateValue Single, TemplateValue Single) -> StringBuilder str+    explodedAssociative (Single k, Single v) =+      addEncodeString k <>+      addChar p '=' <>+      addEncodeString (preprocess v) -    exploded :: StringBuilder ()+    exploded :: StringBuilder str     exploded = case val of-      (Single s) -> do-        when (modifierSupportsNamed settings) (namePrefix settings varName val)-        addEncodeString $ preprocess s-      (Associative l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map explodedAssociative l-      (List l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map (\(Single s) -> addEncodeString $ preprocess s) l+      (Single s) -> whenM+                    (modifierSupportsNamed settings)+                    (namePrefix p settings varName val) <> addEncodeString (preprocess s)+      (Associative l) ->+        mconcat $+        intersperse (addChar p $ modifierSeparator settings) $+        map explodedAssociative l+      (List l) ->+        mconcat $+        intersperse (addChar p $ modifierSeparator settings) $+        map (\(Single s) ->+               whenM+                 (modifierSupportsNamed settings)+                 (namePrefix p settings varName val) <> addEncodeString (preprocess s)) l -processVariables :: [(String, WrappedValue)] -> Modifier -> [Variable] -> StringBuilder ()-processVariables env m vs = sequence_ $ processedVariables+processVariables :: forall str.+                    (Buildable str)+                 => Proxy str -> [(String, WrappedValue)] -> Modifier -> [Variable] -> StringBuilder str+processVariables p env m vs = mconcat processedVariables   where     findValue (Variable varName _) = lookup varName env      nonEmptyVariables :: [(Variable, WrappedValue)]     nonEmptyVariables = catMaybes $ map (\v -> fmap (\mv -> (v, mv)) $ findValue v) vs -    processors :: [Variable -> WrappedValue -> StringBuilder ()]-    processors = (processVariable m True) : repeat (processVariable m False)+    processors :: [Variable -> WrappedValue -> StringBuilder str]+    processors = (processVariable p m True) : repeat (processVariable p m False) -    processedVariables :: [StringBuilder ()]+    processedVariables :: [StringBuilder str]     processedVariables = zipWith uncurry processors nonEmptyVariables -render :: UriTemplate -> [BoundValue] -> String+render :: (Buildable str) => UriTemplate -> [BoundValue] -> str render tpl env = render' tpl env -render' :: UriTemplate -> [BoundValue] -> String-render' tpl env = Data.DList.toList $ execWriter $ mapM_ go tpl+render' :: forall str. (Buildable str) => UriTemplate -> [BoundValue] -> str+render' tpl env = build $ mconcat $ map go tpl   where-    go :: TemplateSegment -> StringBuilder ()-    go (Literal s) = addString s-    go (Embed m vs) = processVariables env m vs+    p :: Proxy str+    p = Proxy++    go :: TemplateSegment -> StringBuilder str+    go (Literal s) = addString p s+    go (Embed m vs) = processVariables p env m vs   

@@ -1,4 +1,4 @@-{-# LANGUAGE EmptyDataDecls, GADTs, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, OverlappingInstances, GeneralizedNewtypeDeriving #-}+{-# LANGUAGE EmptyDataDecls, GADTs, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, GeneralizedNewtypeDeriving #-} module Network.URI.Template.Types where import Control.Arrow import Data.Foldable as F@@ -67,6 +67,10 @@ instance ToTemplateValue TL.Text where   type TemplateRep TL.Text = Single   toTemplateValue = Single . TL.unpack++instance (ToTemplateValue a, TemplateRep a ~ Single) => ToTemplateValue (Maybe a) where+  type TemplateRep (Maybe a) = Single+  toTemplateValue = maybe (Single "") toTemplateValue  instance (ToTemplateValue k, (TemplateRep k) ~ Single, ToTemplateValue v, (TemplateRep v) ~ Single) => ToTemplateValue (HS.HashMap k v) where   type TemplateRep (HS.HashMap k v) = Associative

@@ -1,7 +1,8 @@-{-# LANGUAGE QuasiQuotes, OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings, TypeApplications #-} module Main where import Control.Arrow import Control.Monad.Writer.Strict+import Data.String import Network.URI.Template.Parser import Network.URI.Template import Network.URI.Template.TH@@ -35,7 +36,19 @@     then exitFailure     else exitSuccess   where-    testRun = runTestRegistry (parserTests >> quasiQuoterTests >> embedTests)+    strEq = (@?=) @String+    testRun = runTestRegistry $ do+      parserTests+      quasiQuoterTests strEq+      embedTests+      label "RFC example cases" $ suite $ do+        label "unescaped" $ test $ unescaped strEq+        label "fragment" $ test $ fragment strEq+        label "label tests" $ test $ labelTests strEq+        label "path tests" $ test $ pathTests strEq+        label "path params" $ test $ pathParams strEq+        label "query params" $ test $ queryParams strEq+        label "continued query params" $ test $ queryParams strEq  parserTests = label "Parser Tests" $ suite $ do   let foo = Variable "foo" Normal@@ -94,7 +107,8 @@ keys :: AList TemplateString TemplateString keys = AList [("semi", ";"), ("dot", "."), ("comma", ",")] -quasiQuoterTests = label "QuasiQuoter Tests" $ suite $ do+quasiQuoterTests :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> TestRegistry ()+quasiQuoterTests (@?=) = label "QuasiQuoter Tests" $ suite $ do   label "Simple" $ test ([uri|{var}|] @?= "value")   label "Simple with sufficient length" $ test ([uri|{var:20}|] @?= "value")   label "Simple with insufficient length" $ test ([uri|{var:3}|] @?= "val")@@ -106,30 +120,35 @@   label "List" $ test ([uri|{list}|] @?= "red,green,blue")   label "Explode List" $ test ([uri|{list*}|] @?= "red,green,blue")   label "Associative List" $ test ([uri|{keys}|] @?= "semi,%3B,dot,.,comma,%2C")-  label "Explode Associative List" $ test ([uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C")+  label "Explode Associative List" $ test ([uri|{keys*}|] @?= "semi=%3B,dot=.,comma=%2C")+  label "Explode Associative List Query Params" $ test ([uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C") -unescaped = do+unescaped :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion+unescaped (@?=) = do   [uri|{+path:6}/here|] @?= "/foo/b/here"   [uri|{+list}|] @?= "red,green,blue"-  [uri|{+list}|] @?= "red,green,blue"+  [uri|{+list*}|] @?= "red,green,blue"   [uri|{+keys}|] @?= "semi,;,dot,.,comma,,"-  [uri|{+keys}|] @?= "semi=;,dot=.,comma=,"+  [uri|{+keys*}|] @?= "semi=;,dot=.,comma=," -fragment = do+fragment :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion+fragment (@?=) = do   [uri|{#path:6}/here|] @?= "#/foo/b/here"   [uri|{#list}|] @?= "#red,green,blue"   [uri|{#list*}|] @?= "#red,green,blue"   [uri|{#keys}|] @?= "#semi,;,dot,.,comma,,"   [uri|{#keys*}|] @?= "#semi=;,dot=.,comma=," -labelTests = test $ do+labelTests :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion+labelTests (@?=) = do   [uri|X{.var:3}|] @?= "X.val"   [uri|X{.list}|] @?= "X.red,green,blue"   [uri|X{.list*}|] @?= "X.red.green.blue"   [uri|X{.keys}|] @?= "X.semi,%3B,dot,.,comma,%2C"   [uri|X{.keys*}|] @?= "X.semi=%3B.dot=..comma=%2C" -pathTests = test $ do+pathTests :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion+pathTests (@?=) = do   [uri|{/var:1,var}|] @?= "/v/value"   [uri|{/list}|] @?= "/red,green,blue"   [uri|{/list*}|] @?= "/red/green/blue"@@ -137,27 +156,26 @@   [uri|{/keys}|] @?= "/semi,%3B,dot,.,comma,%2C"   [uri|{/keys*}|] @?= "/semi=%3B/dot=./comma=%2C" -pathParams = do+pathParams :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion+pathParams (@?=) = do   [uri|{;hello:5}|] @?= ";hello=Hello"   [uri|{;list}|] @?= ";list=red,green,blue"   [uri|{;list*}|] @?= ";list=red;list=green;list=blue"   [uri|{;keys}|] @?= ";keys=semi,%3B,dot,.,comma,%2C"   [uri|{;keys*}|] @?= ";semi=%3B;dot=.;comma=%2C" -queryParams = do-  [uri|{?foo}|] @?= "?foo=1"-  [uri|{?foo,bar}|] @?= "?foo=1&bar=2"-  where-    foo :: Int-    foo = 1-    bar :: Int-    bar = 2+queryParams :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion+queryParams (@?=) = do+  [uri|{?var:3}|] @?= "?var=val"+  [uri|{?list}|] @?= "?list=red,green,blue"+  [uri|{?list*}|] @?= "?list=red&list=green&list=blue"+  [uri|{?keys}|] @?= "?keys=semi,%3B,dot,.,comma,%2C"+  [uri|{?keys*}|] @?= "?semi=%3B&dot=.&comma=%2C" -continuedQueryParams = do-  [uri|{&foo}|] @?= "&foo=1"-  [uri|{&foo,bar}|] @?= "&foo=1&bar=2"-  where-    foo :: Int-    foo = 1-    bar :: Int-    bar = 2+continuedQueryParams :: (Eq s, IsString s, Buildable s) => (s -> s -> Assertion) -> Assertion+continuedQueryParams (@?=) = do+  [uri|{&var:3}|] @?= "&var=val"+  [uri|{&list}|] @?= "&list=red,green,blue"+  [uri|{&list*}|] @?= "&list=red&list=green&list=blue"+  [uri|{&keys}|] @?= "&keys=semi,%3B,dot,.,comma,%2C"+  [uri|{&keys*}|] @?= "&semi=%3B&dot=.&comma=%2C"

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                uri-templater-version:             0.2.2.0+version:             0.3.0.0 synopsis:            Parsing & Quasiquoting for RFC 6570 URI Templates description:         Parsing & Quasiquoting for RFC 6570 URI Templates homepage:            https://github.com/iand675/uri-templater@@ -36,7 +36,8 @@                      vector,                      containers,                      unordered-containers,-                     text+                     text,+                     bytestring   hs-source-dirs:    src  test-suite test-uri-templates