diff --git a/URLT.cabal b/URLT.cabal --- a/URLT.cabal +++ b/URLT.cabal @@ -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/ diff --git a/URLT/Happstack.hs b/URLT/Happstack.hs --- a/URLT/Happstack.hs +++ b/URLT/Happstack.hs @@ -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 diff --git a/URLT/Regular.hs b/URLT/Regular.hs new file mode 100644 --- /dev/null +++ b/URLT/Regular.hs @@ -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 diff --git a/URLT/TH.hs b/URLT/TH.hs --- a/URLT/TH.hs +++ b/URLT/TH.hs @@ -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