urlpath 0.2 → 1.0.0
raw patch · 6 files changed
+303/−284 lines, 6 filesdep +criteriondep +deepseqdep +monoid-subclassesdep ~base
Dependencies added: criterion, deepseq, monoid-subclasses, urlpath
Dependency ranges changed: base
Files
- benchmarks/Main.hs +13/−0
- src/Data/Url.hs +82/−0
- src/Data/Url/Types.hs +179/−0
- src/UrlPath.hs +0/−86
- src/UrlPath/Types.hs +0/−181
- urlpath.cabal +29/−17
+ benchmarks/Main.hs view
@@ -0,0 +1,13 @@+module Main where++import Criterion.Main+import qualified Data.Text as T+import TextBenchmarks (TextBenchmark (..), benchmarks)++-- | Function to run the benchmarks using criterion+main :: IO ()+main = defaultMain $ map benchUrl benchmarks+ where+ benchUrl (TextBenchmark name f x) = bgroup name+ [bench "Text" $ nf (T.length . f) x+ ]
+ src/Data/Url.hs view
@@ -0,0 +1,82 @@+{-# LANGUAGE+ OverloadedStrings+ , MultiParamTypeClasses+ , FlexibleInstances+ , FlexibleContexts+ , KindSignatures+ , InstanceSigs+ , TypeFamilies+ , RankNTypes+ #-}++module Data.Url+ ( UrlReader (..)+ , Url (..)+ , module Data.Url.Types ) where++import Data.Url.Types++import Data.String+import Data.Monoid+import Data.Monoid.Textual (TextualMonoid)+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Reader.Class++-- * Classes++-- | @Url@ is a relationship between an underlying (monomorphic) string type+-- @plain@, and a deployment context @m@. We try to make the deployment style+-- coercible at the top level - if the expression has a type+-- @Url String (AbsoluteUrlT String Identity)@ or+-- @Monad m => Url T.Text (GroundedUrlT LT.Text m)@ will force+-- /all use-cases within the expression/ to coerce to that type.+class ( TextualMonoid plain+ , MonadReader plain m+ ) => Url plain (m :: * -> *) where+ url :: UrlString plain -- ^ Url type, parameterized over a string type @plain@+ -> m plain -- ^ Rendered Url in some context.+ plainUrl :: plain -- ^ raw small string+ -> m plain -- ^ Rendered string in some context.+++-- | Overload deployment schemes with this - then, all that's needed is a type+-- coercion to change deployment.+class Url plain m => UrlReader plain m where+ type Result m :: * -> *+ runUrlReader :: Url plain m =>+ m b -- ^ MonadReader with index @string@ and result @b@+ -> plain -- ^ Reader index+ -> Result m b -- ^ Final result+++instance ( Monad m+ , TextualMonoid plain ) => Url plain (RelativeUrlT plain m) where+ url = RelativeUrlT . const . return . expandRelative+ plainUrl x = RelativeUrlT $ const $ return $ expandRelative $ UrlString x []++instance ( Monad m+ , TextualMonoid plain ) => UrlReader plain (RelativeUrlT plain m) where+ type Result (RelativeUrlT plain m) = m+ runUrlReader = runRelativeUrlT++instance ( Monad m+ , TextualMonoid plain ) => Url plain (GroundedUrlT plain m) where+ url = GroundedUrlT . const . return . expandGrounded+ plainUrl x = GroundedUrlT $ const $ return $ expandGrounded $ UrlString x []++instance ( Monad m+ , TextualMonoid plain ) => UrlReader plain (GroundedUrlT plain m) where+ type Result (GroundedUrlT plain m) = m+ runUrlReader = runGroundedUrlT++instance ( Monad m+ , TextualMonoid plain ) => Url plain (AbsoluteUrlT plain m) where+ url = expandAbsolute+ plainUrl x = expandAbsolute $ UrlString x []++instance ( Monad m+ , TextualMonoid plain ) => UrlReader plain (AbsoluteUrlT plain m) where+ type Result (AbsoluteUrlT plain m) = m+ runUrlReader = runAbsoluteUrlT
+ src/Data/Url/Types.hs view
@@ -0,0 +1,179 @@+{-# LANGUAGE+ GADTs+ , BangPatterns+ , OverloadedStrings+ , FlexibleContexts+ , FlexibleInstances+ , MultiParamTypeClasses+ , DeriveFunctor+ , StandaloneDeriving+ #-}++module Data.Url.Types where++import Data.String+import Data.Monoid+import Data.Monoid.Textual (TextualMonoid)+import Data.Functor.Identity+import Control.Applicative+import Control.Monad+import Control.Monad.Trans+import Control.Monad.Reader.Class++-- | Abstract data type for a Url - a "target" and GET parameters. We require @IsString@+-- and @Monoid@ for generic construction, but rendering will require a monomorphic type.+--+-- The type constructor is parameterized over it's underlying @IsString@ &+-- @Monoid@ instance.+data UrlString a where+ UrlString :: ( TextualMonoid a ) =>+ a+ -> [(a, a)]+ -> UrlString a++-- | We can't provide a @Show@ instance for @UrlString@ because that would force+-- us to use @String@.+showUrlString :: UrlString a+ -> a+showUrlString (UrlString !t []) = t+showUrlString (UrlString !t ((!k,!v):xs)) =+ t <> "?" <> k <> "=" <> v <>+ foldl (\acc (x,y) -> acc <> "&" <> x <> "=" <> y) "" xs+++-- | Makes a @UrlString@ out of a raw target path and a GET parameter pair.+(<?>) :: ( TextualMonoid a ) =>+ a -- ^ Target string+ -> (a, a) -- ^ GET Parameter+ -> UrlString a+(<?>) !t !kv = UrlString t [kv]++infixl 9 <?>++-- | Adds another GET parameter pair to a @UrlString@.+(<&>) :: ( TextualMonoid a ) =>+ UrlString a -- ^ Old Url+ -> (a, a) -- ^ Additional GET Parameter+ -> UrlString a+(<&>) (UrlString !t !p) !kv = UrlString t $ p ++ [kv]++infixl 8 <&>+++-- | Render the Url String flatly - without anything prepended to the target.+expandRelative :: ( TextualMonoid plain ) =>+ UrlString plain+ -> plain+expandRelative = showUrlString++-- | Render the Url String as grounded - prepended with a "root" @//@ character.+expandGrounded :: ( TextualMonoid plain ) =>+ UrlString plain+ -> plain+expandGrounded !x = "/" <> showUrlString x++-- | Render the Url String as absolute - getting the root from a @MonadReader@+-- context.+expandAbsolute :: ( MonadReader plain m+ , TextualMonoid plain ) =>+ UrlString plain+ -> m plain+expandAbsolute !x = do+ host <- ask+ return $ host <> "/" <> showUrlString x++-- | Render the Url String as absolute, but with your own configuration type.+--+-- > data SiteConfig = SiteConfig { host :: T.Text+-- > , cdnHost :: T.Text+-- > }+-- > deriving (Show, Eq)+-- >+-- > foo :: HtmlT (Reader SiteConfig) ()+-- > foo = do+-- > url <- lift $ expandAbsoluteWith ("foo.php" <?> ("bar","baz")) host+-- > script_ [src_ url] ""+-- >+-- > bar :: LT.Text+-- > bar = (runReader (runTextT foo)) $+-- > SiteConfig "example.com" "cdn.example.com"+expandAbsoluteWith :: ( MonadReader a m+ , TextualMonoid plain ) =>+ UrlString plain+ -> (a -> plain)+ -> m plain+expandAbsoluteWith !x f = do+ root <- liftM f ask+ return $ root <> "/" <> showUrlString x++newtype RelativeUrlT h m b = RelativeUrlT { runRelativeUrlT :: h -> m b }+ deriving Functor++instance Applicative f => Applicative (RelativeUrlT h f) where+ (<*>) f x = RelativeUrlT $ \a ->+ (<*>) (runRelativeUrlT f a) (runRelativeUrlT x a)++instance Monad m => Monad (RelativeUrlT h m) where+ return x = RelativeUrlT $ \_ -> return x+ m >>= f = RelativeUrlT $ \a ->+ runRelativeUrlT m a >>= (\x -> runRelativeUrlT (f x) a)++instance MonadTrans (RelativeUrlT h) where+ lift = RelativeUrlT . const++instance ( Monad m+ , IsString h ) => MonadReader h (RelativeUrlT h m) where+ ask = return ""++instance MonadIO m => MonadIO (RelativeUrlT h m) where+ liftIO = lift . liftIO++type RelativeUrl h b = RelativeUrlT h Identity b++newtype GroundedUrlT h m b = GroundedUrlT { runGroundedUrlT :: h -> m b }+ deriving Functor++instance Applicative f => Applicative (GroundedUrlT h f) where+ (<*>) f x = GroundedUrlT $ \a ->+ (<*>) (runGroundedUrlT f a) (runGroundedUrlT x a)++instance Monad m => Monad (GroundedUrlT h m) where+ return x = GroundedUrlT $ \_ -> return x+ m >>= f = GroundedUrlT $ \a ->+ runGroundedUrlT m a >>= (\x -> runGroundedUrlT (f x) a)++instance MonadTrans (GroundedUrlT h) where+ lift = GroundedUrlT . const++instance ( Monad m+ , IsString h ) => MonadReader h (GroundedUrlT h m) where+ ask = return "/"++instance MonadIO m => MonadIO (GroundedUrlT h m) where+ liftIO = lift . liftIO++type GroundedUrl h b = GroundedUrlT h Identity b++newtype AbsoluteUrlT h m b = AbsoluteUrlT { runAbsoluteUrlT :: h -> m b }+ deriving Functor++instance Applicative f => Applicative (AbsoluteUrlT h f) where+ (<*>) f x = AbsoluteUrlT $ \a ->+ (<*>) (runAbsoluteUrlT f a) (runAbsoluteUrlT x a)++instance Monad m => Monad (AbsoluteUrlT h m) where+ return x = AbsoluteUrlT $ const $ return x+ m >>= f = AbsoluteUrlT $ \a ->+ runAbsoluteUrlT m a >>= (\x -> runAbsoluteUrlT (f x) a)++instance MonadTrans (AbsoluteUrlT h) where+ lift = AbsoluteUrlT . const++instance ( Monad m+ , IsString h ) => MonadReader h (AbsoluteUrlT h m) where+ ask = AbsoluteUrlT return++instance MonadIO m => MonadIO (AbsoluteUrlT h m) where+ liftIO = lift . liftIO++type AbsoluteUrl h b = AbsoluteUrlT h Identity b
− src/UrlPath.hs
@@ -1,86 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE KindSignatures #-}-{-# LANGUAGE InstanceSigs #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE RankNTypes #-}--module UrlPath- ( UrlReader (..)- , Url (..)- , module UrlPath.Types ) where--import UrlPath.Types--import Data.String-import Data.Monoid-import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Reader.Class------ | @Url@ is a relationship between an underlying (monomorphic) string type--- @plain@, and a deployment context @m@. We try to make the deployment style--- coercible at the top level - if the--- expression has a type @Url String (AbsoluteUrlT String Identity)@--- or @Monad m => Url T.Text (GroundedUrlT LT.Text m)@ will force /all use-cases--- within the expression/ to coerce to that type.-class ( IsString plain- , Monoid plain- , MonadReader plain m- ) => Url plain (m :: * -> *) where- url :: UrlString plain -- ^ Url type, parameterized over a string type @plain@- -> m plain -- ^ Rendered Url in some context.- plainUrl :: plain -- ^ raw small string- -> m plain -- ^ Rendered string in some context.----- | Overload deployment schemes with this - then, all that's needed is a type --- coercion to change deployment.-class Url plain m => UrlReader plain m where- type Result m :: * -> *- runUrlReader :: Url plain m =>- m b -- ^ MonadReader with index @string@ and result @b@- -> plain -- ^ Reader index- -> Result m b -- ^ Final result---instance ( Monad m- , Monoid plain- , IsString plain ) => Url plain (RelativeUrlT plain m) where- url = RelativeUrlT . const . return . expandRelative- plainUrl x = RelativeUrlT $ const $ return $ expandRelative $ UrlString x []--instance ( Monad m- , Monoid plain- , IsString plain ) => UrlReader plain (RelativeUrlT plain m) where- type Result (RelativeUrlT plain m) = m- runUrlReader = runRelativeUrlT--instance ( Monad m- , Monoid plain- , IsString plain ) => Url plain (GroundedUrlT plain m) where- url = GroundedUrlT . const . return . expandGrounded- plainUrl x = GroundedUrlT $ const $ return $ expandGrounded $ UrlString x []--instance ( Monad m- , Monoid plain- , IsString plain ) => UrlReader plain (GroundedUrlT plain m) where- type Result (GroundedUrlT plain m) = m- runUrlReader = runGroundedUrlT--instance ( Monad m- , Monoid plain- , IsString plain ) => Url plain (AbsoluteUrlT plain m) where- url = expandAbsolute- plainUrl x = expandAbsolute $ UrlString x []--instance ( Monad m- , Monoid plain- , IsString plain ) => UrlReader plain (AbsoluteUrlT plain m) where- type Result (AbsoluteUrlT plain m) = m- runUrlReader = runAbsoluteUrlT
− src/UrlPath/Types.hs
@@ -1,181 +0,0 @@-{-# LANGUAGE GADTs #-}-{-# LANGUAGE BangPatterns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE DeriveFunctor #-}--module UrlPath.Types where--import Data.String-import Data.Monoid-import Data.Functor.Identity-import Control.Applicative-import Control.Monad-import Control.Monad.Trans-import Control.Monad.Reader.Class---- | A Url string - a "target" and GET parameters. We require @IsString@--- and @Monoid@ so that construction can be convenient and generic, but --- rendering will require a monomorphic type.-data UrlString a where- UrlString :: ( IsString a- , Monoid a ) =>- a- -> [(a, a)]- -> UrlString a---- | We choose to not provide a @Show@ instance for @UrlString@ to evade the --- @String@ restriction.-showUrlString :: UrlString a- -> a-showUrlString (UrlString !t []) = t-showUrlString (UrlString !t ((!k,!v):xs)) =- t <> "?" <> k <> "=" <> v <>- foldl (\acc (x,y) -> acc <> "&" <> x <> "=" <> y) "" xs----- | Lifts a raw target path and a GET parameter pair into a @UrlString@.-(<?>) :: ( IsString a- , Monoid a ) =>- a -- ^ Target string- -> (a, a) -- ^ GET Parameter- -> UrlString a-(<?>) !t !kv = UrlString t [kv]--infixl 9 <?>---- | Adds another GET parameter pair to a @UrlString@.-(<&>) :: ( IsString a- , Monoid a ) =>- UrlString a -- ^ Old Url- -> (a, a) -- ^ Additional GET Parameter- -> UrlString a-(<&>) (UrlString !t !p) !kv = UrlString t $ p ++ [kv]--infixl 8 <&>----- | Render the Url String as relative-expandRelative :: ( IsString plain- , Monoid plain ) =>- UrlString plain- -> plain-expandRelative = showUrlString---- | Render the Url String as grounded-expandGrounded :: ( IsString plain- , Monoid plain ) =>- UrlString plain- -> plain-expandGrounded !x = "/" <> showUrlString x---- | Render the Url String as absolute - getting the root from a @MonadReader@ --- context. The @Monoid@ instance will be decided monomorphically, therefore a --- type signature will be needed when ran.-expandAbsolute :: ( MonadReader plain m- , IsString plain- , Monoid plain ) =>- UrlString plain- -> m plain-expandAbsolute !x = do- host <- ask- return $ host <> "/" <> showUrlString x---- | Render the Url String as absolute, but with your own configuration type.------ > data SiteConfig = SiteConfig { host :: T.Text--- > , cdnHost :: T.Text--- > }--- > deriving (Show, Eq)--- >--- > foo :: HtmlT (Reader SiteConfig) ()--- > foo = do--- > url <- lift $ expandAbsoluteWith ("foo.php" <?> ("bar","baz")) host--- > script_ [src_ url] ""--- >--- > bar :: LT.Text --- > bar = (runReader (runTextT foo)) $--- > SiteConfig "example.com" "cdn.example.com"-expandAbsoluteWith :: ( MonadReader a m- , IsString plain- , Monoid plain ) =>- UrlString plain- -> (a -> plain)- -> m plain-expandAbsoluteWith !x f = do- root <- liftM f ask- return $ root <> "/" <> showUrlString x--newtype RelativeUrlT h m b = RelativeUrlT { runRelativeUrlT :: h -> m b }- deriving Functor--instance Applicative f => Applicative (RelativeUrlT h f) where- (<*>) f x = RelativeUrlT $ \a ->- (<*>) (runRelativeUrlT f a) (runRelativeUrlT x a)--instance Monad m => Monad (RelativeUrlT h m) where- return x = RelativeUrlT $ \_ -> return x- m >>= f = RelativeUrlT $ \a ->- runRelativeUrlT m a >>= (\x -> runRelativeUrlT (f x) a)--instance MonadTrans (RelativeUrlT h) where- lift = RelativeUrlT . const--instance ( Monad m- , IsString h ) => MonadReader h (RelativeUrlT h m) where- ask = return ""--instance MonadIO m => MonadIO (RelativeUrlT h m) where- liftIO = lift . liftIO--type RelativeUrl h b = RelativeUrlT h Identity b--newtype GroundedUrlT h m b = GroundedUrlT { runGroundedUrlT :: h -> m b }- deriving Functor--instance Applicative f => Applicative (GroundedUrlT h f) where- (<*>) f x = GroundedUrlT $ \a ->- (<*>) (runGroundedUrlT f a) (runGroundedUrlT x a)--instance Monad m => Monad (GroundedUrlT h m) where- return x = GroundedUrlT $ \_ -> return x- m >>= f = GroundedUrlT $ \a ->- runGroundedUrlT m a >>= (\x -> runGroundedUrlT (f x) a)--instance MonadTrans (GroundedUrlT h) where- lift = GroundedUrlT . const--instance ( Monad m- , IsString h ) => MonadReader h (GroundedUrlT h m) where- ask = return "/"--instance MonadIO m => MonadIO (GroundedUrlT h m) where- liftIO = lift . liftIO--type GroundedUrl h b = GroundedUrlT h Identity b--newtype AbsoluteUrlT h m b = AbsoluteUrlT { runAbsoluteUrlT :: h -> m b }- deriving Functor--instance Applicative f => Applicative (AbsoluteUrlT h f) where- (<*>) f x = AbsoluteUrlT $ \a ->- (<*>) (runAbsoluteUrlT f a) (runAbsoluteUrlT x a)--instance Monad m => Monad (AbsoluteUrlT h m) where- return x = AbsoluteUrlT $ const $ return x- m >>= f = AbsoluteUrlT $ \a ->- runAbsoluteUrlT m a >>= (\x -> runAbsoluteUrlT (f x) a)--instance MonadTrans (AbsoluteUrlT h) where- lift = AbsoluteUrlT . const--instance ( Monad m- , IsString h ) => MonadReader h (AbsoluteUrlT h m) where- ask = AbsoluteUrlT return--instance MonadIO m => MonadIO (AbsoluteUrlT h m) where- liftIO = lift . liftIO--type AbsoluteUrl h b = AbsoluteUrlT h Identity b
urlpath.cabal view
@@ -1,18 +1,18 @@ Name: urlpath-Version: 0.2+Version: 1.0.0 Author: Athan Clark <athan.clark@gmail.com> Maintainer: Athan Clark <athan.clark@gmail.com> License: MIT License-File: LICENSE-Category: Web+Category: Web, Data Synopsis: Painfully simple URL writing combinators Description: Simple URL DSL for Haskell. .- This library tries to make it easier for people to write Url strings, + This library tries to make it easier for people to write Url strings, structurally. Packages like <https://hackage.haskell.org/package/yesod-routes Yesod Routes>- do a wonderful job at implementing string-free routing and - references, but sometimes we have to compromise. This tries to make that + do a wonderful job at implementing string-free routing and+ references, but sometimes we have to compromise. This tries to make that compromise less painful. . Use bare combinators to render your strings (kinda useless):@@ -28,9 +28,9 @@ > > ↪ "example.com/foo.php?key1=bar&key2=baz" .- @url@ puts the @UrlString@ in a MonadReader that we can use for applying our - host. We use different monads for different deployment schemes (currently we - have 3 - @RelativeUrl@, @GroundedUrl@, and @AbsoluteUrl@), which we can + @url@ puts the @UrlString@ in a MonadReader that we can use for applying our+ host. We use different monads for different deployment schemes (currently we+ have 3 - @RelativeUrl@, @GroundedUrl@, and @AbsoluteUrl@), which we can integrate in different libraries, like Lucid: . > (runAbsoluteUrl $ renderTextT $ do@@ -47,10 +47,10 @@ > rootConf > rootConf > run- > + > > where > rootConf = flip runAbsoluteT "http://example.com"- > + > > run :: ( MonadIO m > , MonadReader T.Text m > , Url T.Text m ) =>@@ -62,13 +62,13 @@ > λ> curl localhost:3000/ > ↪ "http://example.com/foo?bar=baz" .- Note that in the scotty example, we don't use one of our deployment schemes - - this is because the @scottyT@ function expects it's underlying monad to be an + Note that in the scotty example, we don't use one of our deployment schemes -+ this is because the @scottyT@ function expects it's underlying monad to be an instance of @MonadIO@, which we can only instantiate in our monad transformers. .- Please take mind - the string type underlying the Url rendering is generalized - to @Data.String.IsString@ for convenient use with @-XOverloadedStrings@. However, - due to that generality, we need to specify the monomorphic type (like + Please take mind - the string type underlying the Url rendering is generalized+ to @Data.String.IsString@ for convenient use with @-XOverloadedStrings@. However,+ due to that generality, we need to specify the monomorphic type (like @Data.Text.Text@ above). Cabal-Version: >= 1.10@@ -78,11 +78,12 @@ Default-Language: Haskell2010 HS-Source-Dirs: src GHC-Options: -Wall- Exposed-Modules: UrlPath- UrlPath.Types+ Exposed-Modules: Data.Url+ Data.Url.Types Build-Depends: base >= 4 && < 5 , mtl , transformers+ , monoid-subclasses Test-Suite spec Type: exitcode-stdio-1.0@@ -98,6 +99,17 @@ , mtl , text , transformers++benchmark bench+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ main-is: Main.hs+ build-depends: base+ , deepseq+ , criterion+ , text+ , urlpath >= 0.2+ ghc-options: -O2 Source-Repository head Type: git