web-routes-th (empty) → 0.20

raw patch · 3 files changed

+95/−0 lines, 3 filesdep +basedep +parsecdep +template-haskellsetup-changed

Dependencies added: base, parsec, template-haskell, web-routes

Files

• Setup.hs +2/−0
• Web/Routes/TH.hs +75/−0
• web-routes-th.cabal +18/−0

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

@@ -0,0 +1,75 @@+{-# LANGUAGE CPP, TemplateHaskell #-}+{- OPTIONS_GHC -optP-include -optPdist/build/autogen/cabal_macros.h -}+module Web.Routes.TH where++import Control.Monad (ap, replicateM)+import Data.List (intercalate)+import Language.Haskell.TH+import Text.ParserCombinators.Parsec ((<|>),many1)+import Web.Routes.PathInfo++-- FIXME: handle when called with a type (not data, newtype)+derivePathInfo :: Name -> Q [Dec]+derivePathInfo 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 +                       , fromPathSegmentsFn cons+                       ]+                  return [i]+    where+#if MIN_VERSION_template_haskell(2,4,0)+      mkCtx = classP+#else+      mkCtx = mkType+#endif++      toPathSegmentsFn :: [(Name, Int)] -> DecQ+      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)+                                 match matchCon (normalB (toURLWork conStr args)) []+                                  |  (conName, nArgs) <- cons ]+                   toURLWork :: String -> [Name] -> ExpQ+                   toURLWork conStr args+                       = foldr1 (\a b -> appE (appE [| (++) |] a) b) ([| [conStr] |] : [ [| toPathSegments $(varE arg) |] | arg <- args ])+               funD 'toPathSegments [clause [varP inp] (normalB body)  []]+      fromPathSegmentsFn :: [(Name,Int)] -> DecQ+      fromPathSegmentsFn cons+          = do let body = (foldl1 (\a b -> appE (appE [| (<|>) |] a) b)+                            [ parseCon conName nArgs +                            | (conName, nArgs) <- cons])+                   parseCon :: Name -> Int -> ExpQ+                   parseCon conName nArgs = foldl1 (\a b -> appE (appE [| ap |] a) b) +                                                   ([| segment $(stringE (nameBase conName)) >> return $(conE conName) |]+                                                   : (replicate nArgs [| fromPathSegments |]))+               funD 'fromPathSegments [clause [] (normalB body) []]++mkType :: Name -> [TypeQ] -> TypeQ+mkType con = foldl appT (conT con)++data Class = Tagged [(Name, Int)] Cxt [Name]++parseInfo :: Name -> Q Class+parseInfo name+    = do info <- reify name+         case info of+           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

@@ -0,0 +1,18 @@+Name:             web-routes-th+Version:          0.20+License:          BSD3+Author:           jeremy@seereason.com+Maintainer:       partners@seereason.com+Bug-Reports:      http://bugzilla.seereason.com/+Category:         Web, Language+Synopsis:         Support for deriving PathInfo using Template Haskell+Cabal-Version:    >= 1.6+Build-type:       Simple++Library+        Build-Depends:    base >= 4 && < 5, parsec >= 2 && <3, template-haskell, web-routes >= 0.19+        Exposed-Modules:  Web.Routes.TH++source-repository head+    type:     darcs+    location: http://src.seereason.com/web-routes/