git.iko.soy/typeable/wai
on master help sign in
Merge remote branch 'gregwebs/master'
ec29f3fMichael Snoyman
Network/Wai/Handler/DevelServer.hs+42−30
compare with master
unifiedsplit
@@ -1,7 +1,7 @@
1{-# LANGUAGE DeriveDataTypeable #-}
1{-# LANGUAGE DeriveDataTypeable #-}
2{-# LANGUAGE FlexibleContexts #-}
2{-# LANGUAGE FlexibleContexts #-}
3{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE OverloadedStrings #-}
4−module Network.Wai.Handler.DevelServer (run) where
4+module Network.Wai.Handler.DevelServer (run, runNoWatch) where
5
5
6import Language.Haskell.Interpreter
6import Language.Haskell.Interpreter
7import Network.Wai
7import Network.Wai
@@ -32,6 +32,14 @@ import Data.List (nub)
32
32
33type FunctionName = String
33type FunctionName = String
34
34
35+runNoWatch :: Port -> ModuleName -> FunctionName -> [FilePath] -> IO ()
36+runNoWatch port modu func dirs = do
37+ queue <- C.newChan
38+ mqueue <- M.newMVar queue
39+ startApp queue $ loadingApp Nothing
40+ reload modu func mqueue dirs Nothing
41+ run' port mqueue
42+
35run :: Port -> ModuleName -> FunctionName -> [FilePath] -> IO ()
43run :: Port -> ModuleName -> FunctionName -> [FilePath] -> IO ()
36run port modu func dirs = do
44run port modu func dirs = do
37 queue <- C.newChan
45 queue <- C.newChan
@@ -58,13 +66,14 @@ startApp queue withApp = do
58 $ "Exception thrown while running application\n\n" ++ show e
66 $ "Exception thrown while running application\n\n" ++ show e
59 void x = x >> return ()
67 void x = x >> return ()
60
68
69+getTimes = E.handle (constSE $ return []) . mapM getModificationTime
70+constSE :: x -> SomeException -> x
71+constSE = const
72+
61fillApp :: String -> String -> M.MVar Queue -> [FilePath] -> IO ()
73fillApp :: String -> String -> M.MVar Queue -> [FilePath] -> IO ()
62fillApp modu func mqueue dirs =
74fillApp modu func mqueue dirs =
63 go Nothing []
75 go Nothing []
64 where
76 where
65− constSE :: x -> SomeException -> x
66− constSE = const
67− getTimes = E.handle (constSE $ return []) . mapM getModificationTime
68 go prevError prevFiles = do
77 go prevError prevFiles = do
69 toReload <-
78 toReload <-
70 if null prevFiles
79 if null prevFiles
@@ -74,35 +83,38 @@ fillApp modu func mqueue dirs =
74 return $ times /= map snd prevFiles
83 return $ times /= map snd prevFiles
75 (newError, newFiles) <-
84 (newError, newFiles) <-
76 if toReload
85 if toReload
77− then reload prevError
86+ then reload modu func mqueue dirs prevError
78 else return (prevError, prevFiles)
87 else return (prevError, prevFiles)
79 threadDelay 1000000
88 threadDelay 1000000
80 go newError newFiles
89 go newError newFiles
90+
91+-- reload :: String -> String -> M.MVar Queue -> [FilePath] -> Maybe SomeException -> IO (Maybe SomeException, [ClockTime])
81− reload prevError = do
92+reload modu func mqueue dirs prevError = do
82− case prevError of
93+ case prevError of
83− Nothing -> putStrLn "Attempting to interpret your app..."
94+ Nothing -> putStrLn "Attempting to interpret your app..."
84− _ -> return ()
95+ _ -> return ()
85− loadingApp' prevError mqueue
96+ loadingApp' prevError mqueue
86− res <- theapp modu func
97+ res <- theapp modu func
87− case res of
98+ case res of
88− Left err -> do
99+ Left err -> do
89− if show (Just err) /= show prevError
100+ if show (Just err) /= show prevError
90− then putStrLn $ "Compile failed: " ++ showInterpError err
101+ then putStrLn $ "Compile failed: " ++ showInterpError err
91− else return ()
102+ else return ()
92− loadingApp' (Just $ toException err) mqueue
103+ loadingApp' (Just $ toException err) mqueue
93− return (Just $ toException err, [])
104+ return (Just $ toException err, [])
94− Right (app, files') -> E.handle onInitErr $ do
105+ Right (app, files') -> E.handle onInitErr $ do
95− files'' <- mapM fileList dirs
106+ files'' <- mapM fileList dirs
96− let files = concat $ files' : files''
107+ let files = concat $ files' : files''
97− putStrLn "Interpreting success, new app loaded"
108+ putStrLn "Interpreting success, new app loaded"
98− E.handle onInitErr $ do
109+ E.handle onInitErr $ do
99− swapApp app mqueue
110+ swapApp app mqueue
100− times <- getTimes files
111+ times <- getTimes files
101− return (Nothing, zip files times)
112+ return (Nothing, zip files times)
113+ where
102− onInitErr e = do
114+ onInitErr e = do
103− putStrLn $ "Error initializing application: " ++ show e
115+ putStrLn $ "Error initializing application: " ++ show e
104− loadingApp' (Just e) mqueue
116+ loadingApp' (Just e) mqueue
105− return (Just e, [])
117+ return (Just e, [])
106
118
107showInterpError :: InterpreterError -> String
119showInterpError :: InterpreterError -> String
108showInterpError (WontCompile errs) =
120showInterpError (WontCompile errs) =
wai-handler-devel-unwatched.hsnew file+31
@@ -0,0 +1,31 @@
1+{-# LANGUAGE DeriveDataTypeable #-}
2+import Network.Wai.Handler.DevelServer (runNoWatch)
3+import System.Console.CmdArgs
4+import Control.Concurrent (forkIO)
5+
6+data Devel = Devel
7+ { port :: Int
8+ , moduleName :: String
9+ , function :: String
10+ , yesod :: Bool
11+ }
12+ deriving (Show, Data, Typeable)
13+
14+main :: IO ()
15+main = do
16+ Devel p m f y <- cmdArgs Devel
17+ { port = 3000 &= argPos 0 &= typ "PORT"
18+ , moduleName = "" &= argPos 1 &= typ "MODULE"
19+ , function = "" &= argPos 2 &= typ "FUNCTION"
20+ , yesod = False &= help "Monitor typical Yesod folders (hamlet, etc)"
21+ } &= summary "WAI development web server"
22+ _ <- forkIO $ runNoWatch p m f $ folders y
23+ go
24+ where
25+ folders False = []
26+ folders True = ["hamlet", "cassius", "julius"]
27+ go = do
28+ x <- getLine
29+ case x of
30+ 'q':_ -> putStrLn "Quitting, goodbye!"
31+ _ -> go
wai-handler-devel.cabal+5
@@ -36,3 +36,8 @@ Executable wai-handler-devel
36 Build-Depends: cmdargs >= 0.4 && < 0.7
36 Build-Depends: cmdargs >= 0.4 && < 0.7
37 ghc-options: -Wall -O2 -threaded
37 ghc-options: -Wall -O2 -threaded
38 main-is: wai-handler-devel.hs
38 main-is: wai-handler-devel.hs
39+
40+Executable wai-handler-devel-unwatched
41+ Build-Depends: cmdargs >= 0.4 && < 0.7
42+ ghc-options: -Wall -O2 -threaded
43+ main-is: wai-handler-devel-unwatched.hs