-
Notifications
You must be signed in to change notification settings - Fork 1
/
routeGenerator.hs
235 lines (203 loc) · 7.83 KB
/
routeGenerator.hs
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
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
module Main where
import Control.Monad (when)
import System.Environment (getArgs, getProgName)
import System.Exit (exitFailure)
import System.Console.GetOpt (getOpt, usageInfo, ArgOrder(..), OptDescr(..), ArgDescr(..))
import System.IO (hPutStrLn, stderr)
import Data.List (intercalate)
import Data.Char (isUpper, isSpace)
import Data.Maybe (catMaybes, isJust, fromMaybe)
import Yesod.Routes.Dispatch (Piece(Static, Dynamic))
import Network.URI (escapeURIString, isReserved, isUnescapedInURI)
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Attoparsec.Text
import Control.Applicative
data Flag = Help | CPP | PathHelpers | Routes | NArgs Int | Mod String | OutputName String deriving (Show, Read, Eq)
flags :: [OptDescr Flag]
flags = [
Option ['r'] ["routes"] (NoArg Routes) "Generate routes.",
Option ['p'] ["pathHelpers"] (NoArg PathHelpers) "Generate actionPath helper functions.",
Option ['c'] ["cpp"] (NoArg CPP) "Use CPP",
Option ['m'] ["module"] (ReqArg Mod "MODULE") "Implementation module to import.",
Option ['n'] ["nArgs"] (ReqArg (NArgs . read) "NARGS") "Number of arguments the `route` function takes.",
Option ['o'] ["outputName"] (ReqArg OutputName "NAME") "Name of the output module (defaults to Routes).",
Option ['h'] ["help"] (NoArg Help) "Show this help text."
]
usage :: [String] -> IO ()
usage errors = do
mapM_ (hPutStrLn stderr) errors
name <- getProgName
hPutStrLn stderr $ usageInfo (name ++ " -r -p [-m MODULE] [-n NARGS] [-o NAME] <input-file>") flags
data Route = Route {
method :: Text,
pieces :: [Piece],
multi :: Bool,
target :: Text
}
deriving (Show)
instance Show Piece where
show Dynamic = "Dynamic"
show (Static s) = "Static (pack " ++ show (T.unpack s) ++ ")"
isDynamic :: Piece -> Bool
isDynamic Dynamic = True
isDynamic _ = False
argList :: String -> Int -> [String]
argList s n = snd $ until ((<1) . fst)
(\(n,xs) -> (n-1, (s ++ show n):xs)) (n,[])
multiArg :: Route -> Int
multiArg (Route {multi = True}) = 1
multiArg _ = 0
emitPathHelpers :: [Route] -> Int -> Bool -> IO ()
emitPathHelpers rs nArgs cpp = mapM_ emitPathHelper rs
where
doEscapeURI = escapeURIString (\c -> not (isReserved c || not (isUnescapedInURI c))) . T.unpack
escapeURI = "(Network.URI.escapeURIString (\\c -> not (Network.URI.isReserved c || not (Network.URI.isUnescapedInURI c))) . Data.Text.unpack)"
emitPathHelper r = do
when cpp $ do
putStr "#ifndef NO_"
T.putStrLn (target r)
let args = argList "arg" (length (filter isDynamic (pieces r)) + multiArg r)
T.putStr (target r)
putStr "Path "
putStr (unwords args)
putStr " = Network.URI.Partial.fromURI $ Network.URI.URI \"\" Nothing (Data.List.intercalate \"/\" (["
putStr $ intercalate ", " $ snd $ foldr (\p (n,xs) -> case p of
Dynamic -> (n-1, (escapeURI ++ " $ Web.PathPieces.toPathPiece arg" ++ show n):xs)
Static s -> (n, show (doEscapeURI s) : xs)
) (length args - multiArg r, []) (pieces r)
putStr "]"
when (multi r) (putStr $ " ++ map " ++ escapeURI ++ " (Web.PathPieces.toPathMultiPiece arg" ++ show (length args) ++ ")")
putStrLn ")) \"\" \"\""
-- The where clause forces the typechecker to infer that our arguments
-- are of the same type as the arguments of the action we map to.
putStrLn "\twhere"
putStr "\t_typeRestrict _ "
putStr (unwords $ argList "undef" nArgs)
putStr " = "
T.putStr (target r)
putStr " "
putStrLn $ unwords $ argList "undef" nArgs ++ args
when cpp $ putStrLn "#endif"
putStrLn ""
emitRoutes :: [Route] -> Int -> IO ()
emitRoutes rs nArgs = do
-- We want to be polymorphic in the parameter to route, so just let
-- the inference engine do it all
-- putStrLn "routes :: [Route a]"
putStr "routes "
putStr $ unwords args
putStrLn " = ["
putStrLn $ intercalate ",\n" $ map showRoute rs
putStrLn "\t]"
where
args = argList "arg" nArgs
showRoute r =
"\t\tRoute {\n" ++
"\t\t\trhPieces = " ++
show (Static (method r) : pieces r) ++
",\n" ++
"\t\t\trhHasMulti = " ++
show (multi r) ++
",\n" ++
"\t\t\trhDispatch = (\\(" ++
piecesPattern (pieces r) (multi r) ++
") -> return (" ++
T.unpack (target r) ++
" " ++ unwords args ++
")" ++
piecesAp (pieces r) (multi r) ++
")\n" ++
"\t\t}"
piecesAp pieces multi = concat $ fst $ foldr (\p (ps,c) -> case p of
Dynamic -> ((" `ap` (fromPathPiece val" ++ show c ++ ")"):ps, c+1)
Static _ -> (ps, c)
) (if multi then [" `ap` (fromPathMultiPiece m)"] else [],0::Int) pieces
piecesPattern pieces multi = intercalate ":" $ ("_":) $ fst $
foldr (\p (ps,c) -> case p of
Dynamic -> (("val" ++ show c):ps, c+1)
Static _ -> ("_":ps, c)
) (if multi then ["m"] else ["_"],0::Int) pieces
parser :: Parser [Route]
parser = many1 $ do
skipSpace'
m <- method <?> "http method"
skipSpace'
p <- pieces <?> "path"
multi <- fmap isJust $ option Nothing (fmap Just (char '*'))
skipSpace'
_ <- (char '=' >> char '>') <?> "=>"
skipSpace'
t <- target <?> "action"
skipSpace'
skipMany1 endOfLine <?> "newline"
return $ Route m p multi t
where
skipSpace' = skipWhile (\x -> isSpace x && not (isEndOfLine x))
target = takeWhile1 (not . isSpace)
method = takeWhile1 isUpper
pieces = fmap catMaybes $ many1 $ do
_ <- char '/'
option Nothing (fmap Just piece)
piece = dynamic <|> static
static = fmap Static (takeWhile1 (\x -> x /= '/' && x /= '*' && not (isSpace x)))
dynamic = char ':' >> return Dynamic
myparse :: Parser a -> Text -> Either String a
myparse parser = format . parse (parser <* endOfInput)
where
format (Fail t [] "endOfInput") | T.last t /= '\n' =
Left ("Unexpected end of input. Perhaps you are missing a newline? (" ++ show t ++ ")")
format (Fail t [] msg) = Left (msg ++ " (" ++ show t ++ ")")
format (Fail t (ctx:_) msg) =
Left ("Error parsing " ++ ctx ++ ": " ++ msg ++ " (" ++ show t ++ ")")
format (Partial k) = format (k T.empty)
format (Done _ x) = Right x
main :: IO ()
main = do
(flags, args, errors) <- fmap (getOpt RequireOrder flags) getArgs
case (args, errors) of
_ | Help `elem` flags -> usage errors
(_, _:_) -> usage errors >> exitFailure
_ | length args /= 1 -> usage errors >> exitFailure
_ | (Routes `notElem` flags) && (PathHelpers `notElem` flags) -> do
hPutStrLn stderr "Must pass -r or -p"
usage errors >> exitFailure
_ -> myparse parser <$> T.readFile (head args) >>= main' flags
main' :: [Flag] -> Either String [Route] -> IO ()
main' _ (Left err) = do
hPutStrLn stderr "Error in route syntax"
hPutStrLn stderr err
main' flags (Right routes) = do
when (Routes `elem` flags) $ do
-- GHC pragma turns off warnings we know about
-- Should be ignored by other compilers, so is safe
putStrLn "{-# OPTIONS_GHC -fno-warn-missing-signatures #-}"
putStrLn $ "module " ++ fromFlags "Routes" getOutputName ++ " where"
putStrLn ""
mapM_ (\flag -> case flag of
Mod m -> putStrLn $ "import " ++ m
_ -> return ()
) flags
when (Routes `elem` flags) $ do
putStrLn "import Control.Monad (ap)"
putStrLn "import Data.Text (pack)"
putStrLn "import Web.PathPieces (fromPathPiece, fromPathMultiPiece)"
putStrLn "import Yesod.Routes.Dispatch (Route(..), Piece(Static, Dynamic))"
-- Fully qualified to help when using with CPP
when (PathHelpers `elem` flags) $ do
putStrLn "import qualified Data.List (intercalate)"
putStrLn "import qualified Network.URI (URI(..), escapeURIString, isReserved, isUnescapedInURI)"
putStrLn "import qualified Data.Text (unpack)"
putStrLn "import qualified Web.PathPieces (toPathPiece, toPathMultiPiece)"
putStrLn "import qualified Network.URI.Partial"
putStrLn ""
let nArgs = fromFlags 0 getNArg
when (PathHelpers `elem` flags) (emitPathHelpers routes nArgs (CPP`elem`flags))
when (Routes `elem` flags) (emitRoutes routes nArgs)
where
fromFlags def sel = foldr (\f d -> fromMaybe d (sel f)) def flags
getOutputName (OutputName n) = Just n
getOutputName _ = Nothing
getNArg (NArgs n) = Just n
getNArg _ = Nothing