1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
|
{-# LANGUAGE CPP, TemplateHaskell #-}
module Web.Routes.TH
( derivePathInfo
, derivePathInfo'
, standard
, mkRoute
) where
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
-- | 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)
-- | 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 = pure $ [ AppT (ConT ''PathInfo) (VarT key) | key <- keys ] ++ cx
i <- instanceD context (mkType ''PathInfo [mkType name (map varT keys)])
[ toPathSegmentsFn cons
, fromPathSegmentsFn cons
]
return [i]
where
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 = formatter (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) ([| [pack 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 (pack $(stringE (formatter $ 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
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,17,0)
conv (PlainTV nm _) = nm
conv (KindedTV nm _ _) = nm
#else
conv (PlainTV nm) = nm
conv (KindedTV nm _) = nm
#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]
|
