route-generator 0.3.1 → 0.4

raw patch · 2 files changed

+29/−16 lines, 2 filesdep +network

Dependencies added: network

Files

• route-generator.cabal +3/−2
• routeGenerator.hs +26/−14

@@ -1,5 +1,5 @@ name:            route-generator-version:         0.3.1+version:         0.4 cabal-version:   >= 1.8 license:         OtherLicense license-file:    COPYING@@ -55,7 +55,8 @@                 base == 4.*,                 text >= 0.7,                 attoparsec >= 0.10.0.0,-                yesod-routes+                yesod-routes,+                network  source-repository head         type:     git

@@ -9,6 +9,7 @@ import Data.Char (isUpper, isSpace) import Data.Maybe (catMaybes, isJust) import Yesod.Routes.Dispatch (Piece(Static, Dynamic))+import Network.URI (escapeURIString, isReserved, isUnescapedInURI)  import Data.Text (Text) import qualified Data.Text as T@@ -54,20 +55,28 @@ 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 -> IO () emitPathHelpers rs nArgs = mapM_ emitPathHelper rs 	where+	doEscapeURI = escapeURIString (\c -> not (isReserved c || not (isUnescapedInURI c))) . T.unpack+	escapeURI = "(escapeURIString (\\c -> not (isReserved c || not (isUnescapedInURI c))) . unpack)" 	emitPathHelper r = do-		let args = argList "arg" (length $ filter isDynamic (pieces r))+		let args = argList "arg" (length (filter isDynamic (pieces r)) + multiArg r) 		T.putStr (target r) 		putStr "Path " 		putStr (unwords args)-		putStr " = URI \"\" Nothing ('/' : intercalate \"/\" ["+		putStr " = URI \"\" Nothing ('/' : intercalate \"/\" ([" 		putStr $ intercalate ", " $ snd $ foldr (\p (n,xs) -> case p of-				Dynamic -> (n-1, ("escapeURIString (\\c -> not (isReserved c || not (isUnescapedInURI c)) ) $ unpack $ toPathPiece arg" ++ show n):xs)-				Static s -> (n, show s : xs)-			) (length args, []) (pieces r)-		putStrLn "]) \"\" \"\""+				Dynamic -> (n-1, (escapeURI ++ " $ 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 ++ " (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"@@ -102,26 +111,26 @@ 		",\n" ++  		"\t\t\trhDispatch = (\\(" ++-		piecesPattern (pieces r) +++		piecesPattern (pieces r) (multi r) ++ 		") -> return (" ++ 		T.unpack (target r) ++ 		" " ++ unwords args ++ 		")" ++-		piecesAp (pieces r) +++		piecesAp (pieces r) (multi r) ++ 		")\n" ++  		"\t\t}" -	piecesAp pieces = concat $ fst $ foldr (\p (ps,c) -> case p of+	piecesAp pieces multi = concat $ fst $ foldr (\p (ps,c) -> case p of 			Dynamic -> ((" `ap` (fromPathPiece val" ++ show c ++ ")"):ps, c+1) 			Static _ -> (ps, c)-		) ([],0::Int) pieces+		) (if multi then [" `ap` (fromPathMultiPiece m)"] else [],0::Int) pieces -	piecesPattern pieces = intercalate ":" $ ("_":) $ fst $+	piecesPattern pieces multi = intercalate ":" $ ("_":) $ fst $ 		foldr (\p (ps,c) -> case p of 			Dynamic -> (("val" ++ show c):ps, c+1) 			Static _ -> ("_":ps, c)-		) (["_"],0::Int) pieces+		) (if multi then ["m"] else ["_"],0::Int) pieces  parser :: Parser [Route] parser = many1 $ do@@ -165,6 +174,9 @@ 		Right routes <- fmap (parseOnly parser) $ T.readFile input  		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 Routes where" 			putStrLn "" @@ -176,14 +188,14 @@ 		when (Routes `elem` flags) $ do 			putStrLn "import Control.Monad (ap)" 			putStrLn "import Data.Text (pack)"-			putStrLn "import Web.PathPieces (fromPathPiece)"+			putStrLn "import Web.PathPieces (fromPathPiece, fromPathMultiPiece)" 			putStrLn "import Yesod.Routes.Dispatch (Route(..), Piece(Static, Dynamic))"  		when (PathHelpers `elem` flags) $ do 			putStrLn "import Data.List (intercalate)" 			putStrLn "import Network.URI (URI(..), escapeURIString, isReserved, isUnescapedInURI)" 			putStrLn "import Data.Text (unpack)"-			putStrLn "import Web.PathPieces (toPathPiece)"+			putStrLn "import Web.PathPieces (toPathPiece, toPathMultiPiece)"  		putStrLn ""