Browse files

initial commit

  • Loading branch information...
0 parents commit a7013ba97ac9cad1cffe4a3a7c2c56479d157547 @singpolyma committed Aug 9, 2012
Showing with 105 additions and 0 deletions.
  1. +105 −0 routeGenerator.hs
105 routeGenerator.hs
@@ -0,0 +1,105 @@
+module Main where
+
+import System.Environment (getArgs)
+import Data.List (intercalate)
+import Data.Char (isUpper, isSpace)
+import Data.Maybe (catMaybes, isJust)
+import Yesod.Routes.Dispatch (Piece(Static, Dynamic))
+
+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 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) ++ ")"
+
+emitRoutes :: [Route] -> IO ()
+emitRoutes rs = do
+ -- We want to be polymorphic in the parameter to route, so just let
+ -- the inference engine do it all
+ -- putStrLn "routes :: [Route a]"
+ putStrLn "routes = ["
+ putStrLn $ intercalate ",\n" $ map showRoute rs
+ putStrLn "\t]"
+ where
+ 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) ++
+ ") -> (return " ++
+ T.unpack (target r) ++
+ ")" ++
+ piecesAp (pieces r) ++
+ ")\n" ++
+
+ "\t\t}"
+
+ piecesAp pieces = concat $ fst $ foldr (\p (ps,c) -> case p of
+ Dynamic -> ((" `ap` (fromPathPiece val" ++ show c ++ ")"):ps, c+1)
+ Static _ -> (ps, c)
+ ) ([],0) pieces
+
+ piecesPattern pieces = intercalate ":" $ ("_":) $ fst $
+ foldr (\p (ps,c) -> case p of
+ Dynamic -> (("val" ++ show c):ps, c+1)
+ Static _ -> ("_":ps, c)
+ ) (["_"],0) pieces
+
+parser :: Parser [Route]
+parser = many1 $ do
+ skipSpace
+ m <- method
+ skipSpace
+ p <- pieces
+ multi <- fmap isJust $ option Nothing (fmap Just (char '*'))
+ skipSpace
+ _ <- char '='
+ _ <- char '>'
+ skipSpace
+ t <- target
+ skipWhile (\x -> isSpace x && not (isEndOfLine x))
+ endOfLine
+ return $ Route m p multi t
+ where
+ 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
+
+main = do
+ [input, mod] <- getArgs
+ 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))"
+ putStrLn ""
+ emitRoutes routes

0 comments on commit a7013ba

Please sign in to comment.