From e95492a586b674aa22ef34566f8f55b74b131c14 Mon Sep 17 00:00:00 2001
From: Michael Snoyman <michael@snoyman.com>
Date: Mon, 2 Jul 2012 18:14:31 +0300
Subject: [PATCH] add-handler (#362)

---
 yesod/AddHandler.hs | 113 ++++++++++++++++++++++++++++++++++++++++++++
 yesod/main.hs       |   3 ++
 yesod/yesod.cabal   |   1 +
 3 files changed, 117 insertions(+)
 create mode 100644 yesod/AddHandler.hs

diff --git a/yesod/AddHandler.hs b/yesod/AddHandler.hs
new file mode 100644
index 00000000..accd9347
--- /dev/null
+++ b/yesod/AddHandler.hs
@@ -0,0 +1,113 @@
+module AddHandler (addHandler) where
+
+import Prelude hiding (readFile)
+import System.IO (hFlush, stdout)
+import Data.Char (isLower, toLower, isSpace)
+import Data.List (isPrefixOf, isSuffixOf)
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import System.Directory (getDirectoryContents)
+
+-- strict readFile
+readFile :: FilePath -> IO String
+readFile = fmap T.unpack . TIO.readFile
+
+addHandler :: IO ()
+addHandler = do
+    allFiles <- getDirectoryContents "."
+    cabal <-
+        case filter (".cabal" `isSuffixOf`) allFiles of
+            [x] -> return x
+            [] -> error "No cabal file found"
+            _ -> error "Too many cabal files found"
+
+    putStr "Name of route (without trailing R): "
+    hFlush stdout
+    name <- getLine
+    case name of
+        [] -> error "Please provide a name"
+        c:_
+            | isLower c -> error "Name must start with an upper case letter"
+            | otherwise -> return ()
+    putStr "Enter route pattern: "
+    hFlush stdout
+    pattern <- getLine
+    putStr "Enter space-separated list of methods: "
+    hFlush stdout
+    methods <- getLine
+
+    let modify fp f = readFile fp >>= writeFile fp . f
+
+    modify "Application.hs" $ fixApp name
+    modify cabal $ fixCabal name
+    modify "config/routes" $ fixRoutes name pattern methods
+    writeFile ("Handler/" ++ name ++ ".hs") $ mkHandler name pattern methods
+
+fixApp :: String -> String -> String
+fixApp name =
+    unlines . reverse . go . reverse . lines
+  where
+    l = "import Handler." ++ name
+
+    go [] = [l]
+    go (x:xs)
+        | "import Handler." `isPrefixOf` x = l : x : xs
+        | otherwise = x : go xs
+
+fixCabal :: String -> String -> String
+fixCabal name =
+    unlines . reverse . go . reverse . lines
+  where
+    l = "import Handler." ++ name
+
+    go [] = [l]
+    go (x:xs)
+        | "Handler." `isPrefixOf` x' = (spaces ++ "Handler." ++ name) : x : xs
+        | otherwise = x : go xs
+      where
+        (spaces, x') = span isSpace x
+
+fixRoutes :: String -> String -> String -> String -> String
+fixRoutes name pattern methods =
+    (++ l)
+  where
+    l = concat
+        [ pattern
+        , " "
+        , name
+        , "R "
+        , methods
+        , "\n"
+        ]
+
+mkHandler :: String -> String -> String -> String
+mkHandler name pattern methods = unlines
+    $ ("module Handler." ++ name ++ " where")
+    : ""
+    : "import Import"
+    : concatMap go (words methods)
+  where
+    go method =
+        [ ""
+        , concat $ func : " :: " : map toArrow types ++ ["Handler RepHtml"]
+        , concat
+            [ func
+            , " = error \"Not yet implemented: "
+            , func
+            , "\""
+            ]
+        ]
+      where
+        func = concat [map toLower method, name, "R"]
+
+    types = getTypes pattern
+
+    toArrow t = concat [t, " -> "]
+
+    getTypes "" = []
+    getTypes ('/':rest) = getTypes rest
+    getTypes ('#':rest) =
+        typ : getTypes rest'
+      where
+        (typ, rest') = break (== '/') rest
+    getTypes rest = getTypes $ dropWhile (/= '/') rest
diff --git a/yesod/main.hs b/yesod/main.hs
index cd961ef7..6b5c136c 100755
--- a/yesod/main.hs
+++ b/yesod/main.hs
@@ -11,6 +11,7 @@ import Control.Monad (unless)
 import Build (touch)
 #endif
 import Devel (devel)
+import AddHandler (addHandler)
 
 windowsWarning :: String
 #ifdef WINDOWS
@@ -46,6 +47,7 @@ main = do
             rawSystem' cmd ["test"]
         ["version"] -> putStrLn $ "yesod-core version:" ++ yesodVersion
         "configure":rest -> rawSystem cmd ("configure":rest) >>= exitWith
+        ["add-handler"] -> addHandler
         _ -> do
             putStrLn "Usage: yesod <command>"
             putStrLn "Available commands:"
@@ -59,6 +61,7 @@ main = do
             putStrLn "                    use --dev devel to build with cabal-dev"
             putStrLn "    test         Build and run the integration tests"
             putStrLn "                    use --dev devel to build with cabal-dev"
+            putStrLn "    add-handler  Add a new handler and module to your project"
             putStrLn "    version      Print the version of Yesod"
 
 -- | Like @rawSystem@, but exits if it receives a non-success result.
diff --git a/yesod/yesod.cabal b/yesod/yesod.cabal
index cab6f065..41eff819 100644
--- a/yesod/yesod.cabal
+++ b/yesod/yesod.cabal
@@ -111,6 +111,7 @@ executable             yesod
                        Scaffolding.Scaffolder
                        Devel
                        Build
+                       AddHandler
 
 source-repository head
   type:     git