route-generator-0.1: routeGenerator.hs

module Main where

import System.Environment (getArgs)
import System.IO (hPutStrLn, stderr)
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::Int) pieces

	piecesPattern pieces = intercalate ":" $ ("_":) $ fst $
		foldr (\p (ps,c) -> case p of
			Dynamic -> (("val" ++ show c):ps, c+1)
			Static _ -> ("_":ps, c)
		) (["_"],0::Int) 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 :: IO ()
main = do
	args <- getArgs
	case args of
		[input, mod] -> 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))"
			putStrLn ""
			emitRoutes routes
		_ ->
			hPutStrLn stderr "Usage: ./routeGenerator <input file> <implementation module>"