route-generator 0.2 → 0.3
raw patch · 3 files changed
+100/−22 lines, 3 files
Files
- README +1/−1
- route-generator.cabal +2/−2
- routeGenerator.hs +97/−19
README view
@@ -13,7 +13,7 @@ > GET /post/: => showPost > PUT /* => updateSomething -> ./routeGenerator routes.txt SomeModule+> ./routeGenerator -r -m SomeModule routes.txt Will generate routes that map the correct HTTP verb (which you should pass as a prepended "path segment" to your Dispatch) and path to
route-generator.cabal view
@@ -1,5 +1,5 @@ name: route-generator-version: 0.2+version: 0.3 cabal-version: >= 1.8 license: OtherLicense license-file: COPYING@@ -29,7 +29,7 @@ > GET /post/: => showPost > PUT /* => updateSomething .- > ./routeGenerator routes.txt SomeModule+ > ./routeGenerator -r -m SomeModule routes.txt . Will generate routes that map the correct HTTP verb (which you should pass as a prepended "path segment" to your Dispatch) and path to
routeGenerator.hs view
@@ -1,6 +1,9 @@ module Main where -import System.Environment (getArgs)+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)@@ -14,6 +17,23 @@ import Data.Attoparsec.Text import Control.Applicative +data Flag = Help | PathHelpers | Routes | NArgs Int | Mod 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 ['m'] ["module"] (ReqArg Mod "MODULE") "Implementation module to import.",+ Option ['n'] ["nArgs"] (ReqArg (NArgs . read) "NARGS") "Number of arguments the `route` function takes.",+ 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] <input-file>") flags+ data Route = Route { method :: Text, pieces :: [Piece],@@ -26,6 +46,39 @@ 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,[])++emitPathHelpers :: [Route] -> Int -> IO ()+emitPathHelpers rs nArgs = mapM_ emitPathHelper rs+ where+ emitPathHelper r = do+ let args = argList "arg" (length $ filter isDynamic (pieces r))+ T.putStr (target r)+ putStr "Path "+ putStr (unwords args)+ putStr " = URI \"\" Nothing ('/' : intercalate \"/\" ["+ putStr $ intercalate ", " $ snd $ foldr (\p (n,xs) -> case p of+ Dynamic -> (n-1, ("unpack $ toPathPiece arg" ++ show n):xs)+ Static s -> (n, show s : xs)+ ) (length args, []) (pieces r)+ 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 "\ttypeRestrict _ "+ putStr (unwords $ argList "undef" nArgs)+ putStr " = "+ T.putStr (target r)+ putStr " "+ putStrLn $ unwords $ argList "undef" nArgs ++ args+ putStrLn ""+ emitRoutes :: [Route] -> Int -> IO () emitRoutes rs nArgs = do -- We want to be polymorphic in the parameter to route, so just let@@ -37,9 +90,7 @@ putStrLn $ intercalate ",\n" $ map showRoute rs putStrLn "\t]" where- args = args' nArgs- args' 0 = []- args' n = ("arg" ++ show n) : args' (n-1)+ args = argList "arg" nArgs showRoute r = "\t\tRoute {\n" ++ "\t\t\trhPieces = " ++@@ -52,7 +103,7 @@ "\t\t\trhDispatch = (\\(" ++ piecesPattern (pieces r) ++- ") -> (return $ " +++ ") -> return (" ++ T.unpack (target r) ++ " " ++ unwords args ++ ")" ++@@ -99,21 +150,48 @@ main :: IO () main = do- args <- getArgs- main' args+ (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+ _ -> main' (head args) flags where- main' [input, mod, nArgs] = do+ main' input flags = do Right routes <- fmap (parseOnly parser) $ T.readFile input - putStrLn "module Routes where"- putStrLn ""- putStrLn $ "import " ++ mod- putStrLn "import Control.Monad (ap)"- putStrLn "import Data.Text (pack)"- putStrLn "import Web.PathPieces (fromPathPiece)"- putStrLn "import Yesod.Routes.Dispatch (Route(..), Piece(Static, Dynamic))"+ when (Routes `elem` flags) $ do+ putStrLn "module Routes 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)"+ putStrLn "import Yesod.Routes.Dispatch (Route(..), Piece(Static, Dynamic))"++ when (PathHelpers `elem` flags) $ do+ putStrLn "import Data.List (intercalate)"+ putStrLn "import Network.URI (URI(..))"+ putStrLn "import Data.Text (unpack)"+ putStrLn "import Web.PathPieces (toPathPiece)"+ putStrLn ""- emitRoutes routes (read nArgs)- main' [input, mod] = main' [input, mod, "0"]- main' _ =- hPutStrLn stderr "Usage: ./routeGenerator <input file> <implementation module> [<number of extra args>]"++ let nArgs = getNArgs flags+ when (PathHelpers `elem` flags) (emitPathHelpers routes nArgs)+ when (Routes `elem` flags) (emitRoutes routes nArgs)++ getNArgs = foldr (\flag n -> case (n,flag) of+ (0, NArgs n) -> n+ _ -> n+ ) 0