uri-templater 0.1.0.0 → 0.2.0.0

raw patch · 6 files changed

+135/−97 lines, 6 filesdep +containersdep +textdep +unordered-containersdep ~trifectaPVP ok

version bump matches the API change (PVP)

Dependencies added: containers, text, unordered-containers, vector

Dependency ranges changed: trifecta

API changes (from Hackage documentation)

Files

• src/Network/URI/Template.hs +2/−0
• src/Network/URI/Template/Internal.hs +49/−33
• src/Network/URI/Template/TH.hs +6/−21
• src/Network/URI/Template/Types.hs +61/−30
• test/Test.hs +10/−9
• uri-templater.cabal +7/−4

@@ -8,6 +8,8 @@   , ValueModifier(..)   , TemplateValue(..)   , ToTemplateValue(..)+  , AList(..)+  , TemplateString(..) ) where import Network.URI.Template.Internal import Network.URI.Template.Parser

@@ -18,7 +18,7 @@  data Allow = Unreserved | UnreservedOrReserved -allowEncoder Unreserved = urlEncode+allowEncoder Unreserved           = urlEncode allowEncoder UnreservedOrReserved = id  data ProcessingOptions = ProcessingOptions@@ -29,34 +29,36 @@   , modifierAllow :: Allow   } +type BoundValue = (String, WrappedValue)+ option :: Maybe Char -> Char -> Bool -> Maybe Char -> Allow -> ProcessingOptions option = ProcessingOptions  options :: Modifier -> ProcessingOptions options m = case m of-  Simple            -> option Nothing    ',' False Nothing    Unreserved-  Reserved          -> option Nothing    ',' False Nothing    UnreservedOrReserved-  Label             -> option (Just '.') '.' False Nothing    Unreserved-  PathSegment       -> option (Just '/') '/' False Nothing    Unreserved-  PathParameter     -> option (Just ';') ';' True  Nothing    Unreserved-  Query             -> option (Just '?') '&' True  (Just '=') Unreserved-  QueryContinuation -> option (Just '&') '&' True  (Just '=') Unreserved-  Fragment          -> option (Just '#') ',' False Nothing    UnreservedOrReserved+  Simple            -> option  Nothing   ',' False  Nothing    Unreserved+  Reserved          -> option  Nothing   ',' False  Nothing    UnreservedOrReserved+  Label             -> option (Just '.') '.' False  Nothing    Unreserved+  PathSegment       -> option (Just '/') '/' False  Nothing    Unreserved+  PathParameter     -> option (Just ';') ';' True   Nothing    Unreserved+  Query             -> option (Just '?') '&' True  (Just '=')  Unreserved+  QueryContinuation -> option (Just '&') '&' True  (Just '=')  Unreserved+  Fragment          -> option (Just '#') ',' False  Nothing    UnreservedOrReserved -templateValueIsEmpty :: InternalTemplateValue -> Bool-templateValueIsEmpty (SingleVal s) = null s-templateValueIsEmpty (AssociativeVal s) = null s-templateValueIsEmpty (ListVal s) = null s+templateValueIsEmpty :: TemplateValue a -> Bool+templateValueIsEmpty (Single s)      = null s+templateValueIsEmpty (Associative s) = null s+templateValueIsEmpty (List s)        = null s -namePrefix :: ProcessingOptions -> String -> InternalTemplateValue -> StringBuilder ()+namePrefix :: ProcessingOptions -> String -> TemplateValue a -> StringBuilder () namePrefix opts name val = do   addString name   if templateValueIsEmpty val     then maybe (return ()) addChar $ modifierIfEmpty opts     else addChar '=' -processVariable :: Modifier -> Bool -> Variable -> InternalTemplateValue -> StringBuilder ()-processVariable m isFirst (Variable varName varMod) val = do+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@@ -68,46 +70,60 @@     (MaxLength l) -> do       when (modifierSupportsNamed settings) (namePrefix settings varName val)       -- TODO: this is wrong. we need to truncate prior to encoding.-      censor (fromList . take l . toList) unexploded+      censor (fromList . take l . Data.DList.toList) unexploded   where     settings = options m++    addEncodeString :: String -> StringBuilder ()     addEncodeString = addString . (allowEncoder $ modifierAllow settings)+     sepByCommas = sequence_ . intersperse (addChar ',')-    associativeCommas (n, v) = addEncodeString n >> addChar ',' >> addEncodeString v++    associativeCommas :: (TemplateValue Single, TemplateValue Single) -> StringBuilder ()+    associativeCommas (Single n, Single v) = addEncodeString n >> addChar ',' >> addEncodeString v+     unexploded = case val of-      (AssociativeVal l) -> sepByCommas $ map associativeCommas l-      (ListVal l) -> sepByCommas $ map addEncodeString l-      (SingleVal s) -> addEncodeString s-    explodedAssociative (k, v) = do+      (Associative l) -> sepByCommas $ map associativeCommas l+      (List l) -> sepByCommas $ map (\(Single s) -> addEncodeString s) l+      (Single s) -> addEncodeString s++    explodedAssociative :: (TemplateValue Single, TemplateValue Single) -> StringBuilder ()+    explodedAssociative (Single k, Single v) = do       addEncodeString k       addChar '='       addEncodeString v+           exploded :: StringBuilder ()     exploded = case val of-      (SingleVal s) -> do+      (Single s) -> do         when (modifierSupportsNamed settings) (namePrefix settings varName val)         addEncodeString s-      (AssociativeVal l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map explodedAssociative l-      (ListVal l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map addEncodeString l+      (Associative l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map explodedAssociative l+      (List l) -> sequence_ $ intersperse (addChar $ modifierSeparator settings) $ map (\(Single s) -> addEncodeString s) l -processVariables :: [(String, InternalTemplateValue)] -> Modifier -> [Variable] -> StringBuilder ()+processVariables :: [(String, WrappedValue)] -> Modifier -> [Variable] -> StringBuilder () processVariables env m vs = sequence_ $ processedVariables   where     findValue (Variable varName _) = lookup varName env-    nonEmptyVariables :: [(Variable, InternalTemplateValue)]++    nonEmptyVariables :: [(Variable, WrappedValue)]     nonEmptyVariables = catMaybes $ map (\v -> fmap (\mv -> (v, mv)) $ findValue v) vs-    processors :: [Variable -> InternalTemplateValue -> StringBuilder ()]++    processors :: [Variable -> WrappedValue -> StringBuilder ()]     processors = (processVariable m True) : repeat (processVariable m False)+     processedVariables :: [StringBuilder ()]     processedVariables = zipWith uncurry processors nonEmptyVariables -render :: forall a. UriTemplate -> [(String, TemplateValue a)] -> String-render tpl env = render' tpl $ map (\(l, r) -> (l, internalize r)) env+render :: UriTemplate -> [BoundValue] -> String+render tpl env = render' tpl env -render' :: UriTemplate -> [(String, InternalTemplateValue)] -> String-render' tpl env = toList $ execWriter $ mapM_ go tpl+render' :: UriTemplate -> [BoundValue] -> String+render' tpl env = Data.DList.toList $ execWriter $ mapM_ go tpl   where     go :: TemplateSegment -> StringBuilder ()     go (Literal s) = addString s     go (Embed m vs) = processVariables env m vs-      {-(processVariable m True) : repeat (processVariable m False)-}+++

@@ -9,16 +9,6 @@ import Network.URI.Template.Parser import Network.URI.Template.Types -{--  mTpl <- parse qqInput-  case mTpl of-    Left err -> error err-    Right tpl -> do-      varNames <- distinct <$> getAllVariableNames-      convert varNames to [(varName, toTemplateValue $ varExpr for varName)]-      render tpl convertedValues--}- variableNames :: UriTemplate -> [String] variableNames = nub . foldr go []   where@@ -29,7 +19,11 @@ segmentToExpr (Literal str) = appE (conE 'Literal) (litE $ StringL str) segmentToExpr (Embed m vs) = appE (appE (conE 'Embed) modifier) $ listE $ map variableToExpr vs   where-    modifier = conE $ mkName ("Network.URI.Template.Types." ++ show m)+    modifier = do+      mname <- lookupValueName (show m)+      case mname of+        Nothing -> fail (show m ++ " is not a valid modifier")+        Just n -> conE n     variableToExpr (Variable varName varModifier) = [| Variable $(litE $ StringL varName) $(varModifierE varModifier) |]     varModifierE vm = case vm of       Normal -> conE 'Normal@@ -41,16 +35,7 @@   where     templateValues = listE $ map makePair vns     vns = variableNames ts-    makePair str = [| ($(litE $ StringL str), internalize $ toTemplateValue $ $(varE $ mkName str)) |]---- AppE (VarE 'concat) $ ListE $ concatMap segmentToExp ts--{-segmentToExp (Literal s) = [LitE $ StringL s]-}-{-segmentToExp (Embed m v) = map (AppE prefix . enc . VarE . mkName) v-}-  {-where-}-    {-enc = AppE (VarE $ encoder m)-}-    {--- cons the prefix onto the beginning of each embedded segment-}-    {-prefix = InfixE (Just $ LitE $ CharL $ subsequentSeparator m) (ConE $ '(:)) Nothing-}+    makePair str = [| ($(litE $ StringL str), WrappedValue $ toTemplateValue $ $(varE $ mkName str)) |]  quasiEval :: String -> Q Exp quasiEval str = do

@@ -1,47 +1,78 @@-{-# LANGUAGE EmptyDataDecls, GADTs, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances #-}+{-# LANGUAGE EmptyDataDecls, GADTs, FunctionalDependencies, MultiParamTypeClasses, FlexibleContexts, TypeSynonymInstances, FlexibleInstances, TypeFamilies, OverlappingInstances, GeneralizedNewtypeDeriving #-} module Network.URI.Template.Types where--data SingleElement-data AssociativeListElement-data ListElement+import Control.Arrow+import Data.Foldable as F+import Data.List+import qualified Data.String as S+import qualified Data.HashMap.Strict as HS+import qualified Data.Map.Strict as MS+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Vector as V -newtype ListElem a = ListElem { fromListElem :: a }+data Single+data Associative+data List  data TemplateValue a where-  Single :: String -> TemplateValue SingleElement-  Associative :: [(String, TemplateValue SingleElement)] -> TemplateValue AssociativeListElement-  List :: [TemplateValue SingleElement] -> TemplateValue ListElement+  Single :: String -> TemplateValue Single+  Associative :: [(TemplateValue Single, TemplateValue Single)] -> TemplateValue Associative+  List :: [TemplateValue Single] -> TemplateValue List -data InternalTemplateValue-  = SingleVal String-  | AssociativeVal [(String, String)]-  | ListVal [String]+instance Show (TemplateValue a) where+  show (Single s) = "Single " ++ s+  show (Associative as) = "Associative [" ++ intercalate ", " (map formatTuple as) ++ "]"+    where+      formatTuple (k, v) = "(" ++ show k ++ ", " ++ show v ++ ")"+  show (List s) = "List [" ++ intercalate ", " (map show s) ++ "]" -fromSingle :: TemplateValue SingleElement -> String-fromSingle (Single s) = s+data WrappedValue where+  WrappedValue :: TemplateValue a -> WrappedValue -fromSingleVal :: InternalTemplateValue -> String-fromSingleVal (SingleVal s) = s+newtype TemplateString = String { fromString :: String }+  deriving (Read, Show, Eq, S.IsString) -internalize :: TemplateValue a -> InternalTemplateValue-internalize (Single s) = SingleVal s-internalize (Associative ls) = AssociativeVal $ map (\(l, r) -> (l, fromSingleVal $ internalize r)) ls-internalize (List l) = ListVal $ map (fromSingleVal . internalize) l+newtype AList k v = AList { fromAList :: [(k, v)] } -class ToTemplateValue a e | a -> e where-  toTemplateValue :: a -> TemplateValue e+class ToTemplateValue a where+  type TemplateRep a+  toTemplateValue :: a -> TemplateValue (TemplateRep a) -instance ToTemplateValue Int SingleElement where+instance ToTemplateValue Int where+  type TemplateRep Int = Single   toTemplateValue = Single . show -instance ToTemplateValue a SingleElement => ToTemplateValue (ListElem [a]) ListElement where-  toTemplateValue = List . map toTemplateValue . fromListElem+instance ToTemplateValue TemplateString where+  type TemplateRep TemplateString = Single+  toTemplateValue = Single . fromString -instance ToTemplateValue a SingleElement => ToTemplateValue [(String, a)] AssociativeListElement where-  toTemplateValue = Associative . map (\(l, r) -> (l, toTemplateValue r))+instance (ToTemplateValue a, (TemplateRep a) ~ Single) => ToTemplateValue [a] where+  type TemplateRep [a] = List+  toTemplateValue = List . map toTemplateValue -instance ToTemplateValue String SingleElement where-  toTemplateValue = Single+instance (ToTemplateValue k, (TemplateRep k) ~ Single, ToTemplateValue v, (TemplateRep v) ~ Single) => ToTemplateValue (AList k v) where+  type TemplateRep (AList k v) = Associative+  toTemplateValue = Associative . map (toTemplateValue *** toTemplateValue) . fromAList++instance (ToTemplateValue a, (TemplateRep a) ~ Single) => ToTemplateValue (V.Vector a) where+  type TemplateRep (V.Vector a) = List+  toTemplateValue = List . F.toList . fmap toTemplateValue++instance ToTemplateValue T.Text where+  type TemplateRep T.Text = Single+  toTemplateValue = Single . T.unpack++instance ToTemplateValue TL.Text where+  type TemplateRep TL.Text = Single+  toTemplateValue = Single . TL.unpack++instance (ToTemplateValue k, (TemplateRep k) ~ Single, ToTemplateValue v, (TemplateRep v) ~ Single) => ToTemplateValue (HS.HashMap k v) where+  type TemplateRep (HS.HashMap k v) = Associative+  toTemplateValue = toTemplateValue . AList . HS.toList++instance (ToTemplateValue k, (TemplateRep k) ~ Single, ToTemplateValue v, (TemplateRep v) ~ Single) => ToTemplateValue (MS.Map k v) where+  type TemplateRep (MS.Map k v) = Associative+  toTemplateValue = toTemplateValue . AList . MS.toList  data ValueModifier   = Normal

@@ -1,5 +1,6 @@-{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE QuasiQuotes, OverloadedStrings #-} module Main where+import Control.Arrow import Control.Monad.Writer.Strict import Network.URI.Template.Parser import Network.URI.Template@@ -67,7 +68,7 @@   label "Explode" $ embedTest "{foo*}" "bar"   label "Max Length" $ embedTest "{foo:1}" "b" -embedTestEnv = [("foo", Single "bar")]+embedTestEnv = [("foo", WrappedValue $ Single "bar")]  embedTest :: String -> String -> TestRegistry () embedTest t expect = test $ do@@ -75,20 +76,20 @@   let rendered = render tpl embedTestEnv   rendered @?= expect -var :: String+var :: TemplateString var = "value" -hello :: String+hello :: TemplateString hello = "Hello World!" -path :: String+path :: TemplateString path = "/foo/bar" -list :: ListElem [String]-list = ListElem ["red", "green", "blue"]+list :: [TemplateString]+list = ["red", "green", "blue"] -keys :: [(String, String)]-keys = [("semi", ";"), ("dot", "."), ("comma", ",")]+keys :: AList TemplateString TemplateString+keys = AList [("semi", ";"), ("dot", "."), ("comma", ",")]  quasiQuoterTests = label "QuasiQuoter Tests" $ suite $ do   label "Simple" $ test ([uri|{var}|] @?= "value")

@@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/  name:                uri-templater-version:             0.1.0.0+version:             0.2.0.0 synopsis:            Parsing & Quasiquoting for RFC 6570 URI Templates description:         Parsing & Quasiquoting for RFC 6570 URI Templates homepage:            http://github.com/sanetracker/uri-templater@@ -10,7 +10,7 @@ license-file:        LICENSE author:              Ian Duncan maintainer:          ian@iankduncan.com-copyright:           SaneTracker+copyright:           Ian Duncan category:            Network build-type:          Simple cabal-version:       >=1.8@@ -18,7 +18,6 @@   type:                git   location:            http://github.com/sanetracker/uri-templater - library   exposed-modules:   Network.URI.Template,                      Network.URI.Template.TH,@@ -33,7 +32,11 @@                      HTTP,                      dlist,                      mtl,-                     ansi-wl-pprint+                     ansi-wl-pprint,+                     vector,+                     containers,+                     unordered-containers,+                     text   hs-source-dirs:    src  test-suite test-uri-templates