URLT 0.10 → 0.14
raw patch · 4 files changed
+95/−17 lines, 4 filesdep +regulardep ~QuickCheck
Dependencies added: regular
Dependency ranges changed: QuickCheck
Files
- URLT.cabal +14/−10
- URLT/Happstack.hs +2/−2
- URLT/Regular.hs +61/−0
- URLT/TH.hs +18/−5
URLT.cabal view
@@ -1,19 +1,23 @@ Name: URLT-Version: 0.10+Version: 0.14 License: BSD3 License-File: debian/copyright Author: jeremy@seereason.com Maintainer: partners@seereason.com-+Bug-Reports: http://bugzilla.seereason.com/+Category: Web, Language Synopsis: Library for maintaining correctness of URLs within an application. Description: A collection of types and functions that ensure that URLs generated by an application are valid. Need more properties here.--Exposed-Modules: URLT, URLT.Base, URLT.HandleT, URLT.Happstack, URLT.QuickCheck, URLT.TH, URLT.XMLGenT- -Build-Depends: base >= 4 && < 5, mtl, Consumer, template-haskell, happstack-server, QuickCheck, hsx, hsp, applicative-extras+Cabal-Version: >= 1.6+Build-type: Simple -Build-Type: Simple-Category: Web, Language+Library+ Build-Depends: base >= 4 && < 5, mtl, Consumer, template-haskell, happstack-server, QuickCheck >= 2 && < 3, hsx, hsp, applicative-extras, regular+ Exposed-Modules: URLT, URLT.Base, URLT.HandleT, URLT.Happstack, URLT.QuickCheck, URLT.TH, URLT.Regular, URLT.XMLGenT+ Extensions: TemplateHaskell,+ FlexibleContexts,+ CPP -Extensions: TemplateHaskell,- FlexibleContexts+source-repository head+ type: darcs+ location: http://src.seereason.com/urlt/
URLT/Happstack.hs view
@@ -22,7 +22,7 @@ finishWith = lift . finishWith -- FIXME: the prefix can only be a single directory right now-implSite :: (ToMessage a) => String -> String -> Site link Link (ServerPartT IO) a -> ServerPartT IO Response+implSite :: (Monad m) => String -> String -> Site link Link (ServerPartT m) a -> ServerPartT m a implSite domain prefix siteSpec = dir (filter (/= '/') prefix) $ withRequest $ \rq ->@@ -31,5 +31,5 @@ do r <- runServerPartT (runSite (domain ++ prefix) siteSpec link) (rq { rqPaths = [] }) case r of (Failure _) -> mzero- (Success v) -> return (toResponse v)+ (Success v) -> return v
+ URLT/Regular.hs view
@@ -0,0 +1,61 @@+{-# LANGUAGE TypeOperators, ScopedTypeVariables #-}+module URLT.Regular where++import Control.Applicative+import Control.Applicative.Error (Failing(Failure, Success))+import Control.Monad.Consumer (Consumer(Consumer), next, runConsumer)+import Control.Monad(MonadPlus(mzero, mplus), ap)+import Data.Char (toLower)+import Generics.Regular+import URLT.TH (AsURL(fromURLC, toURLS))++class GToURL f where+ gtoURLS :: f a -> ShowS+ gfromURLC :: Consumer String (Failing (f a))+ +instance AsURL a => GToURL (K a) where + gtoURLS (K a) = toURLS a+ gfromURLC = fmap (fmap K) $ fromURLC + +instance (GToURL f, GToURL g) => GToURL (f :+: g) where+ gtoURLS (L x) = gtoURLS x+ gtoURLS (R y) = gtoURLS y+ gfromURLC = let urlLeft = fmap (fmap L) $ gfromURLC+ urlRight = fmap (fmap R) $ gfromURLC+ in urlLeft `combine` urlRight+ where+ combine :: Consumer String (Failing a) -> Consumer String (Failing a) -> Consumer String (Failing a)+ combine (Consumer f) (Consumer g) =+ Consumer $ \c ->+ case f c of+ r@(Success a, _) -> r+ (Failure errs1, _) ->+ case g c of+ r@(Success a, _) -> r+ (Failure errs2, _) -> (Failure (errs1 ++ errs2), c)++instance GToURL U where+ gtoURLS U = id+ gfromURLC =+ do m <- next+ case m of+ Nothing -> return (Success U)+ (Just str) -> return (Failure ["Excepted end of input, but got: " ++ str])++instance GToURL f => GToURL (S s f) where+ gtoURLS (S x) = gtoURLS x+ gfromURLC = fmap (fmap S) gfromURLC+ +instance forall c f. (Constructor c, GToURL f) => GToURL (C c f) where+ gtoURLS c@(C x) = showString (lower $ conName c) . showString "/" . gtoURLS x+ gfromURLC = let constr = undefined :: C c f r+ name = conName constr+ in do mx <- next+ case mx of + Nothing -> return (Failure ["Excepted '" ++ lower name ++ "' but got end of input."])+ (Just x) ->+ if (lower x == lower name)+ then fmap (fmap C) $ gfromURLC+ else return (Failure ["Excepted '" ++ lower name ++ "' but got '" ++ lower x ++ "'"])++lower = map toLower
URLT/TH.hs view
@@ -1,4 +1,5 @@-{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE CPP, TemplateHaskell #-}+{-# OPTIONS_GHC -optP-include -optPdist/build/autogen/cabal_macros.h #-} module URLT.TH where import Control.Applicative (Applicative((<*>)))@@ -27,13 +28,19 @@ = do c <- parseInfo name case c of Tagged cons cx keys ->- do let context = [ mkType ''AsURL [varT key] | key <- keys ] ++ map return cx+ do let context = [ mkCtx ''AsURL [varT key] | key <- keys ] ++ map return cx i <- instanceD (sequence context) (mkType ''AsURL [mkType name (map varT keys)]) [ toURLFn cons , fromURLCFn cons ] return [i] where+#if MIN_VERSION_template_haskell(2,4,0)+ mkCtx = classP+#else+ mkCtx = mkType+#endif+ toURLFn :: [(Name, Int)] -> DecQ toURLFn cons = do inp <- newName "inp"@@ -75,6 +82,7 @@ mkType :: Name -> [TypeQ] -> TypeQ mkType con = foldl appT (conT con) + data Class = Tagged [(Name, Int)] Cxt [Name] @@ -82,11 +90,16 @@ parseInfo name = do info <- reify name case info of- TyConI (DataD cx _ keys cs _) -> return $ Tagged (map conInfo cs) cx keys- TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx keys+ TyConI (DataD cx _ keys cs _) -> return $ Tagged (map conInfo cs) cx $ map conv keys+ TyConI (NewtypeD cx _ keys con _)-> return $ Tagged [conInfo con] cx $ map conv keys _ -> error "Invalid input" where conInfo (NormalC n args) = (n, length args) conInfo (RecC n args) = (n, length args) conInfo (InfixC _ n _) = (n, 2) conInfo (ForallC _ _ con) = conInfo con-+#if MIN_VERSION_template_haskell(2,4,0)+ conv (PlainTV nm) = nm+ conv (KindedTV nm _) = nm+#else+ conv = id+#endif