web-routes-th 0.21.1 → 0.22.0
raw patch · 2 files changed
+115/−14 lines, 2 filesdep +split
Dependencies added: split
Files
- Web/Routes/TH.hs +113/−13
- web-routes-th.cabal +2/−1
Web/Routes/TH.hs view
@@ -1,23 +1,58 @@ {-# LANGUAGE CPP, TemplateHaskell #-} {- OPTIONS_GHC -optP-include -optPdist/build/autogen/cabal_macros.h -}-module Web.Routes.TH where+module Web.Routes.TH+ ( derivePathInfo+ , derivePathInfo'+ , standard+ , mkRoute+ ) where -import Control.Monad (ap, replicateM)-import Data.List (intercalate)-import Data.Text (pack, unpack)+import Control.Applicative ((<$>))+import Control.Monad (ap, replicateM)+import Data.Char (isUpper, toLower, toUpper)+import Data.List (intercalate, foldl')+import Data.List.Split (split, dropInitBlank, keepDelimsL, whenElt)+import Data.Text (pack, unpack) import Language.Haskell.TH+import Language.Haskell.TH.Syntax (nameBase) import Text.ParserCombinators.Parsec ((<|>),many1) import Web.Routes.PathInfo +#include "/home/stepcut/n-heptane/projects/haskell/web-routes/web-routes-th/dist/build/autogen/cabal_macros.h"++-- | use Template Haskell to create 'PathInfo' instances for a type.+--+-- > $(derivePathInfo ''SiteURL)+--+-- Uses the 'standard' formatter by default.+derivePathInfo :: Name+ -> Q [Dec]+derivePathInfo = derivePathInfo' standard+ -- FIXME: handle when called with a type (not data, newtype)-derivePathInfo :: Name -> Q [Dec]-derivePathInfo name++-- | use Template Haskell to create 'PathInfo' instances for a type.+--+-- This variant allows the user to supply a function that transforms+-- the constructor name to a prettier rendering. It is important that+-- the transformation function generates a unique output for each+-- input. For example, simply converting the string to all lower case+-- is not acceptable, because then 'FooBar' and 'Foobar' would be+-- indistinguishable.+--+-- > $(derivePathInfo' standard ''SiteURL)+--+-- see also: 'standard'+derivePathInfo' :: (String -> String)+ -> Name+ -> Q [Dec]+derivePathInfo' formatter name = do c <- parseInfo name case c of Tagged cons cx keys -> do let context = [ mkCtx ''PathInfo [varT key] | key <- keys ] ++ map return cx i <- instanceD (sequence context) (mkType ''PathInfo [mkType name (map varT keys)])- [ toPathSegmentsFn cons + [ toPathSegmentsFn cons , fromPathSegmentsFn cons ] return [i]@@ -27,14 +62,13 @@ #else mkCtx = mkType #endif- toPathSegmentsFn :: [(Name, Int)] -> DecQ- toPathSegmentsFn cons + toPathSegmentsFn cons = do inp <- newName "inp" let body = caseE (varE inp) $ [ do args <- replicateM nArgs (newName "arg") let matchCon = conP conName (map varP args)- conStr = (nameBase conName)+ conStr = formatter (nameBase conName) match matchCon (normalB (toURLWork conStr args)) [] | (conName, nArgs) <- cons ] toURLWork :: String -> [Name] -> ExpQ@@ -44,11 +78,11 @@ fromPathSegmentsFn :: [(Name,Int)] -> DecQ fromPathSegmentsFn cons = do let body = (foldl1 (\a b -> appE (appE [| (<|>) |] a) b)- [ parseCon conName nArgs + [ parseCon conName nArgs | (conName, nArgs) <- cons]) parseCon :: Name -> Int -> ExpQ- parseCon conName nArgs = foldl1 (\a b -> appE (appE [| ap |] a) b) - ([| segment (pack $(stringE (nameBase conName))) >> return $(conE conName) |]+ parseCon conName nArgs = foldl1 (\a b -> appE (appE [| ap |] a) b)+ ([| segment (pack $(stringE (formatter $ nameBase conName))) >> return $(conE conName) |] : (replicate nArgs [| fromPathSegments |])) funD 'fromPathSegments [clause [] (normalB body) []] @@ -74,3 +108,69 @@ #else conv = id #endif++-- | the standard formatter+--+-- Converts @CamelCase@ to @camel-case@.+--+-- see also: 'derivePathInfo' and 'derivePathInfo''+standard :: String -> String+standard =+ intercalate "-" . map (map toLower) . split splitter+ where+ splitter = dropInitBlank . keepDelimsL . whenElt $ isUpper++mkRoute :: Name -> Q [Dec]+mkRoute url =+ do (Tagged cons _ _) <- parseInfo url+ fn <- funD (mkName "route") $+ map (\(con, numArgs) ->+ do -- methods <- parseMethods con+ -- runIO $ print methods+ args <- replicateM numArgs (newName "arg")+ clause [conP con $ map varP args] (normalB $ foldl' appE (varE (mkName (headLower (nameBase con)))) (map varE args)) []+ ) cons+ return [fn]+ where+ headLower :: String -> String+ headLower (c:cs) = toLower c : cs++-- work in progress++parseMethods :: Name -> Q [Name]+parseMethods con =+ do info <- reify con+ case info of+ (DataConI _ ty _ _) ->+ do runIO $ print ty+ runIO $ print $ lastTerm ty+ return $ extractMethods (lastTerm ty)++extractMethods :: Type -> [Name]+extractMethods ty =+ case ty of+ (AppT (ConT con) (ConT method)) ->+ [method]+ (AppT (ConT con) methods) ->+ extractMethods' methods+ where+ extractMethods' :: Type -> [Name]+ extractMethods' t = map (\(ConT n) -> n) (leafs t)++-- | return the 'Type' after the right-most @->@. Or the original 'Type' if there are no @->@.+lastTerm :: Type -> Type+lastTerm t@(AppT l r)+ | hasArrowT l = lastTerm r+ | otherwise = t+lastTerm t = t++-- | tests if a 'Type' contains an 'ArrowT' somewhere+hasArrowT :: Type -> Bool+hasArrowT ArrowT = True+hasArrowT (AppT l r) = hasArrowT l || hasArrowT r+hasArrowT _ = False++leafs :: Type -> [Type]+leafs (AppT l@(AppT _ _) r) = leafs l ++ leafs r+leafs (AppT _ r) = leafs r+leafs t = [t]
web-routes-th.cabal view
@@ -1,5 +1,5 @@ Name: web-routes-th-Version: 0.21.1+Version: 0.22.0 License: BSD3 License-File: LICENSE Author: jeremy@seereason.com@@ -15,6 +15,7 @@ parsec >= 2 && < 4, template-haskell, text,+ split, web-routes >= 0.26 Exposed-Modules: Web.Routes.TH