Skip to content
Browse files

Full TH support.

  • Loading branch information...
1 parent 12e8f3f commit bd3d35c3d2a65706129d1b5a4e38e08fe2efff64 @MedeaMelana committed Nov 26, 2010
Showing with 53 additions and 40 deletions.
  1. +8 −19 Example.hs
  2. +4 −1 Makefile
  3. +39 −18 Web/Zwaluw/TH.hs
  4. +2 −2 Zwaluw.cabal
View
27 Example.hs
@@ -15,31 +15,20 @@ data Sitemap
= Home
| UserOverview
| UserDetail Int
- | Range Int Int
+ | Article Int String
deriving (Eq, Show)
$(deriveRouters ''Sitemap)
--- Constructor routers. Soon to be generated by Template Haskell.
-
-home :: Router r (Sitemap :- r)
-home = constr0 Home $ \a -> do Home <- a; return ()
-
-userOverview :: Router r (Sitemap :- r)
-userOverview = constr0 UserOverview $ \a -> do UserOverview <- a; return ()
-
-userDetail :: Router (Int :- r) (Sitemap :- r)
-userDetail = constr1 UserDetail $ \a -> do UserDetail i <- a; return i
-
-range :: Router (Int :- Int :- r) (Sitemap :- r)
-range = constr2 Range $ \a -> do Range l u <- a; return (l, u)
-
-- The router. Specifies how to parse a URL into a Sitemap and back.
sitemap :: Router r (Sitemap :- r)
sitemap = id /
- ( home
- <> "users" . (userOverview <> userDetail / int)
- <> "range" . range / int / int
- )
+ ( rHome
+ <> "users" . users
+ <> rArticle . ("article" / int . "-" . part)
+ )
+ where
+ users = rUserOverview
+ <> rUserDetail / int
View
5 Makefile
@@ -1,5 +1,5 @@
default:
- ghci -XOverloadedStrings -ddump-splices Example
+ ghci -XOverloadedStrings Example
clean:
cabal clean
@@ -10,5 +10,8 @@ configure:
docs: configure
cabal haddock
+install:
+ cabal install
+
opendocs: docs
open dist/doc/html/Zwaluw/index.html
View
57 Web/Zwaluw/TH.hs
@@ -8,18 +8,6 @@ import Language.Haskell.TH
import Language.Haskell.TH.Syntax
import Control.Monad
-arg :: (ty -> r -> s) -> (a -> ty) -> (a :- r) -> s
-arg c f (x :- r) = c (f x) r
-
--- TyConI
--- (DataD [] Main.Sitemap []
--- [NormalC Main.Home []
--- ,NormalC Main.UserOverview []
--- ,NormalC Main.UserDetail [(NotStrict,ConT GHC.Types.Int)]
--- ,NormalC Main.Article [(NotStrict,ConT GHC.Types.Int),(NotStrict,ConT GHC.Base.String)]
--- ] [])
-
--- TyConI (NewtypeD [] Main.WrapSitemap [] (NormalC Main.WrapSitemap [(NotStrict,ConT Main.Sitemap)]) [])
-- Derive routers for all constructors in a datatype.
deriveRouters :: Name -> Q [Dec]
@@ -33,17 +21,24 @@ deriveRouters name = do
_ ->
fail $ show name ++ " is not a datatype."
+
-- Derive a router for a single constructor.
deriveRouter :: Con -> Q [Dec]
deriveRouter con =
case con of
- NormalC name tys -> do
- exp <- [| pure $(deriveConstructor name (length tys)) $(deriveDestructor con) |]
- return [FunD (mkRouterName name) [Clause [] (NormalB exp) []]]
- -- RecC conName tys -> return []
+ NormalC name tys -> go name (map snd tys)
+ RecC name tys -> go name (map (\(_,_,ty) -> ty) tys)
_ -> do
runIO $ putStrLn $ "Skipping unsupported constructor " ++ show (conName con)
return []
+ where
+ go name tys = do
+ let name' = mkRouterName name
+ runIO $ putStrLn $ "Introducing router " ++ nameBase name' ++ "."
+ exp <- [| pure $(deriveConstructor name (length tys))
+ $(deriveDestructor name tys) |]
+ return [FunD name' [Clause [] (NormalB exp) []]]
+
-- Derive the contructor part of a router.
deriveConstructor :: Name -> Int -> Q Exp
@@ -53,14 +48,40 @@ deriveConstructor name arity = [| $(mk arity) $(conE name) |]
mk 0 = [| (:-) |]
mk n = [| arg $(mk (n - 1)) |]
+arg :: (ty -> r -> s) -> (a -> ty) -> (a :- r) -> s
+arg c f (x :- r) = c (f x) r
+
+
-- Derive the destructor part of a router.
-deriveDestructor :: Con -> Q Exp
-deriveDestructor con = [| undefined |]
+deriveDestructor :: Name -> [Type] -> Q Exp
+deriveDestructor name tys = do
+ -- Introduce some names
+ x <- newName "x"
+ r <- newName "r"
+ fieldNames <- replicateM (length tys) (newName "a")
+
+ -- Figure out the names of some constructors
+ nothing <- [| Nothing |]
+ ConE just <- [| Just |]
+ ConE cons <- [| (:-) |]
+
+ let conPat = ConP name (map VarP fieldNames)
+ let okBody = ConE just `AppE`
+ foldr
+ (\h t -> ConE cons `AppE` VarE h `AppE` t)
+ (VarE r)
+ fieldNames
+ let okCase = Match (ConP cons [conPat, VarP r]) (NormalB okBody) []
+ let failCase = Match WildP (NormalB nothing) []
+
+ return $ LamE [VarP x] (CaseE (VarE x) [okCase, failCase])
+
-- Derive the name of a router based on the name of the constructor in question.
mkRouterName :: Name -> Name
mkRouterName name = mkName ("r" ++ nameBase name)
+
-- Retrieve the name of a constructor.
conName :: Con -> Name
conName con =
View
4 Zwaluw.cabal
@@ -20,5 +20,5 @@ Build-type: Simple
Library
- Exposed-Modules: Web.Zwaluw
- Build-Depends: base >= 4 && < 5
+ Exposed-Modules: Web.Zwaluw, Web.Zwaluw.TH
+ Build-Depends: base >= 4 && < 5, template-haskell >= 2.4 && < 2.5

0 comments on commit bd3d35c

Please sign in to comment.
Something went wrong with that request. Please try again.