diff --git a/src/Network/URI/Template.hs b/src/Network/URI/Template.hs --- a/src/Network/URI/Template.hs +++ b/src/Network/URI/Template.hs @@ -8,6 +8,8 @@ , ValueModifier(..) , TemplateValue(..) , ToTemplateValue(..) + , AList(..) + , TemplateString(..) ) where import Network.URI.Template.Internal import Network.URI.Template.Parser diff --git a/src/Network/URI/Template/Internal.hs b/src/Network/URI/Template/Internal.hs --- a/src/Network/URI/Template/Internal.hs +++ b/src/Network/URI/Template/Internal.hs @@ -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)-} + + + diff --git a/src/Network/URI/Template/TH.hs b/src/Network/URI/Template/TH.hs --- a/src/Network/URI/Template/TH.hs +++ b/src/Network/URI/Template/TH.hs @@ -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 diff --git a/src/Network/URI/Template/Types.hs b/src/Network/URI/Template/Types.hs --- a/src/Network/URI/Template/Types.hs +++ b/src/Network/URI/Template/Types.hs @@ -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 diff --git a/test/Test.hs b/test/Test.hs --- a/test/Test.hs +++ b/test/Test.hs @@ -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") diff --git a/uri-templater.cabal b/uri-templater.cabal --- a/uri-templater.cabal +++ b/uri-templater.cabal @@ -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