-
Notifications
You must be signed in to change notification settings - Fork 370
/
AddHandler.hs
113 lines (98 loc) · 3 KB
/
AddHandler.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
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 (ex: /entry/#EntryId): "
hFlush stdout
pattern <- getLine
putStr "Enter space-separated list of methods (ex: GET POST): "
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