Skip to content
Browse files

More source style cleanup.

  • Loading branch information...
1 parent 0d75768 commit 424e3560af8ddc6c83c3e55d7be57efea37fca59 @gregorycollins gregorycollins committed Dec 11, 2011
View
21 project_template/default/src/Application.hs
@@ -1,29 +1,30 @@
{-# LANGUAGE TemplateHaskell #-}
-{-
-
-This module defines our application's state type and an alias for its handler
-monad.
-
--}
-
+------------------------------------------------------------------------------
+-- | This module defines our application's state type and an alias for its
+-- handler monad.
+--
module Application where
+------------------------------------------------------------------------------
import Data.Lens.Template
import Data.Time.Clock
-
import Snap.Snaplet
import Snap.Snaplet.Heist
+------------------------------------------------------------------------------
data App = App
{ _heist :: Snaplet (Heist App)
, _startTime :: UTCTime
}
-type AppHandler = Handler App App
-
makeLens ''App
instance HasHeist App where
heistLens = subSnaplet heist
+
+------------------------------------------------------------------------------
+type AppHandler = Handler App App
+
+
View
115 project_template/default/src/Main.hs
@@ -1,18 +1,15 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
module Main where
+------------------------------------------------------------------------------
import Control.Exception (SomeException, try)
-
import qualified Data.Text as T
-
import Snap.Http.Server
import Snap.Snaplet
import Snap.Core
-
import System.IO
-
import Site
#ifdef DEVELOPMENT
@@ -22,51 +19,46 @@ import Snap.Loader.Prod
#endif
-{-|
-
-This is the entry point for this web server application. It supports
-easily switching between interpreting source and running statically
-compiled code.
-
-In either mode, the generated program should be run from the root of
-the project tree. When it is run, it locates its templates, static
-content, and source files in development mode, relative to the current
-working directory.
-
-When compiled with the development flag, only changes to the
-libraries, your cabal file, or this file should require a recompile to
-be picked up. Everything else is interpreted at runtime. There are a
-few consequences of this.
-
-First, this is much slower. Running the interpreter takes a
-significant chunk of time (a couple tenths of a second on the author's
-machine, at this time), regardless of the simplicity of the loaded
-code. In order to recompile and re-load server state as infrequently
-as possible, the source directories are watched for updates, as are
-any extra directories specified below.
-
-Second, the generated server binary is MUCH larger, since it links in
-the GHC API (via the hint library).
-
-Third, and the reason you would ever want to actually compile with
-development mode, is that it enables a faster development cycle. You
-can simply edit a file, save your changes, and hit reload to see your
-changes reflected immediately.
-
-When this is compiled without the development flag, all the actions
-are statically compiled in. This results in faster execution, a
-smaller binary size, and having to recompile the server for any code
-change.
-
--}
+------------------------------------------------------------------------------
+-- | This is the entry point for this web server application. It supports
+-- easily switching between interpreting source and running statically compiled
+-- code.
+--
+-- In either mode, the generated program should be run from the root of the
+-- project tree. When it is run, it locates its templates, static content, and
+-- source files in development mode, relative to the current working directory.
+--
+-- When compiled with the development flag, only changes to the libraries, your
+-- cabal file, or this file should require a recompile to be picked up.
+-- Everything else is interpreted at runtime. There are a few consequences of
+-- this.
+--
+-- First, this is much slower. Running the interpreter takes a significant
+-- chunk of time (a couple tenths of a second on the author's machine, at this
+-- time), regardless of the simplicity of the loaded code. In order to
+-- recompile and re-load server state as infrequently as possible, the source
+-- directories are watched for updates, as are any extra directories specified
+-- below.
+--
+-- Second, the generated server binary is MUCH larger, since it links in the
+-- GHC API (via the hint library).
+--
+-- Third, and the reason you would ever want to actually compile with
+-- development mode, is that it enables a faster development cycle. You can
+-- simply edit a file, save your changes, and hit reload to see your changes
+-- reflected immediately.
+--
+-- When this is compiled without the development flag, all the actions are
+-- statically compiled in. This results in faster execution, a smaller binary
+-- size, and having to recompile the server for any code change.
+--
main :: IO ()
main = do
- -- depending on the version of loadSnapTH in scope, this either
- -- enables dynamic reloading, or compiles it without. The last
- -- argument to loadSnapTH is a list of additional directories to
- -- watch for changes to trigger reloads in development mode. It
- -- doesn't need to include source directories, those are picked up
- -- automatically by the splice.
+ -- Depending on the version of loadSnapTH in scope, this either enables
+ -- dynamic reloading, or compiles it without. The last argument to
+ -- loadSnapTH is a list of additional directories to watch for changes to
+ -- trigger reloads in development mode. It doesn't need to include source
+ -- directories, those are picked up automatically by the splice.
(conf, site, cleanup) <- $(loadSnapTH [| getConf |]
'getActions
["resources/templates"])
@@ -75,12 +67,12 @@ main = do
cleanup
--- | This action loads the config used by this application. The
--- loaded config is returned as the first element of the tuple
--- produced by the loadSnapTH Splice. The type is not solidly fixed,
--- though it must be an IO action that produces the same type as
--- 'getActions' takes. It also must be an instance of Typeable. If
--- the type of this is changed, a full recompile will be needed to
+------------------------------------------------------------------------------
+-- | This action loads the config used by this application. The loaded config
+-- is returned as the first element of the tuple produced by the loadSnapTH
+-- Splice. The type is not solidly fixed, though it must be an IO action that
+-- produces the same type as 'getActions' takes. It also must be an instance of
+-- Typeable. If the type of this is changed, a full recompile will be needed to
-- pick up the change, even in development mode.
--
-- This action is only run once, regardless of whether development or
@@ -89,16 +81,15 @@ getConf :: IO (Config Snap ())
getConf = commandLineConfig defaultConfig
--- | This function generates the the site handler and cleanup action
--- from the configuration. In production mode, this action is only
--- run once. In development mode, this action is run whenever the
--- application is reloaded.
+------------------------------------------------------------------------------
+-- | This function generates the the site handler and cleanup action from the
+-- configuration. In production mode, this action is only run once. In
+-- development mode, this action is run whenever the application is reloaded.
--
-- Development mode also makes sure that the cleanup actions are run
--- appropriately before shutdown. The cleanup action returned from
--- loadSnapTH should still be used after the server has stopped
--- handling requests, as the cleanup actions are only automatically
--- run when a reload is triggered.
+-- appropriately before shutdown. The cleanup action returned from loadSnapTH
+-- should still be used after the server has stopped handling requests, as the
+-- cleanup actions are only automatically run when a reload is triggered.
--
-- This sample doesn't actually use the config passed in, but more
-- sophisticated code might.
View
16 project_template/default/src/Site.hs
@@ -1,17 +1,15 @@
{-# LANGUAGE OverloadedStrings #-}
-{-|
-
-This is where all the routes and handlers are defined for your site. The
-'app' function is the initializer that combines everything together and
-is exported by this module.
-
--}
-
+------------------------------------------------------------------------------
+-- | This module is where all the routes and handlers are defined for your
+-- site. The 'app' function is the initializer that combines everything
+-- together and is exported by this module.
+--
module Site
( app
) where
+------------------------------------------------------------------------------
import Control.Applicative
import Control.Monad.Trans
import Control.Monad.State
@@ -26,7 +24,7 @@ import Snap.Snaplet.Heist
import Snap.Util.FileServe
import Text.Templating.Heist
import Text.XmlHtml hiding (render)
-
+------------------------------------------------------------------------------
import Application
View
3 src/Control/Access/RoleBased/Checker.hs
@@ -3,6 +3,7 @@
module Control.Access.RoleBased.Checker where
+------------------------------------------------------------------------------
import Control.Monad
import Control.Monad.Logic
import Control.Monad.Reader
@@ -11,7 +12,7 @@ import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.Maybe (fromMaybe, isJust)
import Data.Text (Text)
-
+------------------------------------------------------------------------------
import Control.Access.RoleBased.Internal.RoleMap (RoleMap)
import qualified Control.Access.RoleBased.Internal.RoleMap as RM
import Control.Access.RoleBased.Internal.Types
View
8 src/Control/Access/RoleBased/Internal/Role.hs
@@ -1,5 +1,6 @@
module Control.Access.RoleBased.Internal.Role where
+------------------------------------------------------------------------------
import Control.Monad.ST
import Data.Hashable
import Data.HashMap.Strict (HashMap)
@@ -18,10 +19,12 @@ data RoleValue = RoleBool Bool
deriving (Ord, Eq, Show)
+------------------------------------------------------------------------------
instance IsString RoleValue where
fromString = RoleText . fromString
+------------------------------------------------------------------------------
instance Hashable RoleValue where
hashWithSalt salt (RoleBool e) = hashWithSalt salt e `combine` 7
hashWithSalt salt (RoleText t) = hashWithSalt salt t `combine` 196613
@@ -38,6 +41,7 @@ data Role = Role {
deriving (Eq, Show)
+------------------------------------------------------------------------------
instance IsString Role where
fromString s = Role (fromString s) M.empty
@@ -51,7 +55,7 @@ toSortedList m = runST $ do
return $ V.toList v'
-
+------------------------------------------------------------------------------
instance Hashable Role where
hashWithSalt salt (Role nm dat) =
h $ hashWithSalt salt nm
@@ -67,13 +71,15 @@ data RoleValueMeta = RoleBoolMeta
| RoleDoubleMeta
+------------------------------------------------------------------------------
data RoleDataDefinition = RoleDataDefinition {
_roleDataName :: Text
, _roleValueMeta :: RoleValueMeta
, _roleDataDescription :: Text
}
+------------------------------------------------------------------------------
data RoleMetadata = RoleMetadata {
_roleMetadataName :: Text
, _roleDescription :: Text
View
4 src/Control/Access/RoleBased/Internal/RoleMap.hs
@@ -1,16 +1,18 @@
module Control.Access.RoleBased.Internal.RoleMap where
+------------------------------------------------------------------------------
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.HashSet (HashSet)
import qualified Data.HashSet as S
import Data.List (find, foldl')
import Data.Text (Text)
-
+------------------------------------------------------------------------------
import Control.Access.RoleBased.Role
import Control.Access.RoleBased.Internal.Types
+------------------------------------------------------------------------------
newtype RoleMap = RoleMap (HashMap Text (HashSet Role))
View
8 src/Control/Access/RoleBased/Internal/Rule.hs
@@ -1,18 +1,24 @@
module Control.Access.RoleBased.Internal.Rule where
+------------------------------------------------------------------------------
import Data.HashMap.Strict (HashMap)
import qualified Data.HashMap.Strict as M
import Data.List (foldl')
import Data.Monoid
import Data.Text (Text)
-
+------------------------------------------------------------------------------
import Control.Access.RoleBased.Internal.Role
+
------------------------------------------------------------------------------
data Rule = Rule Text (Role -> [Role])
+
+------------------------------------------------------------------------------
newtype RuleSet = RuleSet (HashMap Text (Role -> [Role]))
+
+------------------------------------------------------------------------------
instance Monoid RuleSet where
mempty = RuleSet M.empty
(RuleSet m1) `mappend` (RuleSet m2) = RuleSet $ M.foldlWithKey' ins m2 m1
View
3 src/Control/Access/RoleBased/Internal/Types.hs
@@ -9,10 +9,11 @@ module Control.Access.RoleBased.Internal.Types
, RuleChecker(..)
) where
+------------------------------------------------------------------------------
import Control.Applicative
import Control.Monad.Reader
import Control.Monad.Logic
-
+------------------------------------------------------------------------------
import Control.Access.RoleBased.Internal.Role
import Control.Access.RoleBased.Internal.Rule
View
1 src/Control/Access/RoleBased/Role.hs
@@ -1,5 +1,6 @@
module Control.Access.RoleBased.Role where
+------------------------------------------------------------------------------
import qualified Data.HashMap.Strict as M
import Control.Access.RoleBased.Internal.Types
import Data.Text (Text)
View
148 src/Snap/Loader/Devel.hs
@@ -1,5 +1,7 @@
+{-# LANGUAGE CPP #-}
{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE CPP #-}
+
+------------------------------------------------------------------------------
-- | This module includes the machinery necessary to use hint to load
-- action code dynamically. It includes a Template Haskell function
-- to gather the necessary compile-time information about code
@@ -9,22 +11,18 @@ module Snap.Loader.Devel
( loadSnapTH
) where
+------------------------------------------------------------------------------
#ifdef HINT_ENABLED
import Control.Monad (liftM2)
-
import Data.Char (isAlphaNum)
import Data.List
import Data.Maybe (maybeToList)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Data.Typeable
-
import Language.Haskell.Interpreter hiding (lift, liftIO, typeOf)
import Language.Haskell.Interpreter.Unsafe
-
import Language.Haskell.TH
-
import System.Environment (getArgs)
-
import Snap.Core
import Snap.Loader.Devel.Signal
import Snap.Loader.Devel.Evaluator
@@ -33,49 +31,48 @@ import Snap.Loader.Devel.TreeWatcher
import Language.Haskell.TH
#endif
+
------------------------------------------------------------------------------
--- | This function derives all the information necessary to use the
--- interpreter from the compile-time environment, and compiles it in
--- to the generated code.
+-- | This function derives all the information necessary to use the interpreter
+-- from the compile-time environment, and compiles it in to the generated code.
--
-- This could be considered a TH wrapper around a function
--
-- > loadSnap :: Typeable a => IO a -> (a -> IO (Snap (), IO ()))
-- > -> [String] -> IO (a, Snap (), IO ())
--
--- with a magical implementation. The [String] argument is a list of
--- directories to watch for updates to trigger a reloading.
--- Directories containing code should be automatically picked up by
--- this splice.
+-- with a magical implementation. The [String] argument is a list of
+-- directories to watch for updates to trigger a reloading. Directories
+-- containing code should be automatically picked up by this splice.
--
--- The generated splice executes the initialiser once, sets up the
--- interpreter for the load function, and returns the initializer's
--- result along with the interpreter's proxy handler and cleanup
--- actions. The behavior of the proxy actions will change to reflect
--- changes in the watched files, reinterpreting the load function as
--- needed and applying it to the initializer result.
+-- The generated splice executes the initialiser once, sets up the interpreter
+-- for the load function, and returns the initializer's result along with the
+-- interpreter's proxy handler and cleanup actions. The behavior of the proxy
+-- actions will change to reflect changes in the watched files, reinterpreting
+-- the load function as needed and applying it to the initializer result.
--
--- This will handle reloading the application successfully in most
--- cases. The cases in which it is certain to fail are those
--- involving changing the types of the initializer or the load
--- function, or changing the compiler options required, such as by
--- changing/adding dependencies in the project's .cabal file. In
--- those cases, a full recompile will be needed.
-loadSnapTH :: Q Exp -- ^ the initializer expression
- -> Name -- ^ the name of the load function
- -> [String] -- ^ a list of directories to watch in addition
- -- to those containing code
+-- This will handle reloading the application successfully in most cases. The
+-- cases in which it is certain to fail are those involving changing the types
+-- of the initializer or the load function, or changing the compiler options
+-- required, such as by changing/adding dependencies in the project's .cabal
+-- file. In those cases, a full recompile will be needed.
+--
+loadSnapTH :: Q Exp -- ^ the initializer expression
+ -> Name -- ^ the name of the load function
+ -> [String] -- ^ a list of directories to watch in addition
+ -- to those containing code
-> Q Exp
#ifndef HINT_ENABLED
-loadSnapTH _ _ _ = fail $ "Snap was built without hint support. Hint " ++
- "support is necessary for development mode. " ++
- "Please reinstall snap with hint support.\n\n " ++
- " cabal install snap -fhint\n\n"
+loadSnapTH _ _ _ = fail $
+ concat [ "Snap was built without hint support. Hint "
+ , "support is necessary for development mode. "
+ , "Please reinstall snap with hint support.\n\n "
+ , " cabal install snap -fhint\n\n" ]
#else
loadSnapTH initializer action additionalWatchDirs = do
args <- runIO getArgs
- let opts = getHintOpts args
+ let opts = getHintOpts args
srcPaths = additionalWatchDirs ++ getSrcPaths args
-- The first line is an extra type check to ensure the arguments
@@ -97,19 +94,30 @@ loadSnapTH initializer action additionalWatchDirs = do
getHintOpts :: [String] -> [String]
getHintOpts args = removeBad opts
where
- bad = ["-threaded", "-O"]
+ --------------------------------------------------------------------------
+ bad = ["-threaded", "-O"]
+
+ --------------------------------------------------------------------------
removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)
- hideAll = filter (== "-hide-all-packages") args
+ --------------------------------------------------------------------------
+ hideAll = filter (== "-hide-all-packages") args
- srcOpts = filter (\x -> "-i" `isPrefixOf` x
- && not ("-idist" `isPrefixOf` x)) args
+ --------------------------------------------------------------------------
+ srcOpts = filter (\x -> "-i" `isPrefixOf` x
+ && not ("-idist" `isPrefixOf` x))
+ args
- toCopy = filter (not . isSuffixOf ".hs") $
- dropWhile (not . ("-package" `isPrefixOf`)) args
- copy = map (intercalate " ") . groupBy (\_ s -> not $ "-" `isPrefixOf` s)
+ --------------------------------------------------------------------------
+ toCopy = filter (not . isSuffixOf ".hs") $
+ dropWhile (not . ("-package" `isPrefixOf`)) args
- opts = hideAll ++ srcOpts ++ copy toCopy
+ --------------------------------------------------------------------------
+ copy = map (intercalate " ")
+ . groupBy (\_ s -> not $ "-" `isPrefixOf` s)
+
+ --------------------------------------------------------------------------
+ opts = concat [hideAll, srcOpts, copy toCopy]
------------------------------------------------------------------------------
@@ -121,57 +129,71 @@ getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg
------------------------------------------------------------------------------
--- | This function creates the Snap handler that actually is
--- responsible for doing the dynamic loading of actions via hint,
--- given all of the configuration information that the interpreter
--- needs. It also ensures safe concurrent access to the interpreter,
--- and caches the interpreter results for a short time before allowing
--- it to run again.
+-- | This function creates the Snap handler that actually is responsible for
+-- doing the dynamic loading of actions via hint, given all of the
+-- configuration information that the interpreter needs. It also ensures safe
+-- concurrent access to the interpreter, and caches the interpreter results for
+-- a short time before allowing it to run again.
+--
+-- Generally, this won't be called manually. Instead, loadSnapTH will generate
+-- a call to it at compile-time, calculating all the arguments from its
+-- environment.
--
--- Generally, this won't be called manually. Instead, loadSnapTH will
--- generate a call to it at compile-time, calculating all the
--- arguments from its environment.
hintSnap :: Typeable a
- => [String] -- ^ A list of command-line options for the interpreter
- -> [String] -- ^ A list of modules that need to be
- -- interpreted. This should contain only the
- -- modules which contain the initialization,
- -- cleanup, and handler actions. Everything else
- -- they require will be loaded transitively.
- -> [String] -- ^ A list of paths to watch for updates
- -> String -- ^ The name of the function to load
- -> a -- ^ The value to apply the loaded function to
+ => [String]
+ -- ^ A list of command-line options for the interpreter
+ -> [String]
+ -- ^ A list of modules that need to be interpreted. This should
+ -- contain only the modules which contain the initialization,
+ -- cleanup, and handler actions. Everything else they require will
+ -- be loaded transitively.
+ -> [String]
+ -- ^ A list of paths to watch for updates
+ -> String
+ -- ^ The name of the function to load
+ -> a
+ -- ^ The value to apply the loaded function to
-> IO (Snap (), IO ())
hintSnap opts modules srcPaths action value =
protectedHintEvaluator initialize test loader
+
where
+ --------------------------------------------------------------------------
witness x = undefined $ x `asTypeOf` value :: HintLoadable
- -- This is somewhat fragile, and probably can be cleaned up with a
- -- future version of Typeable. For the moment, and
- -- backwards-compatibility, this is the approach being taken.
+ --------------------------------------------------------------------------
+ -- This is somewhat fragile, and probably can be cleaned up with a future
+ -- version of Typeable. For the moment, and backwards-compatibility, this
+ -- is the approach being taken.
witnessModules = map (reverse . drop 1 . dropWhile (/= '.') . reverse) .
filter (elem '.') . groupBy typePart . show . typeOf $
witness
+ --------------------------------------------------------------------------
typePart x y = (isAlphaNum x && isAlphaNum y) || x == '.' || y == '.'
+ --------------------------------------------------------------------------
interpreter = do
loadModules . nub $ modules
setImports . nub $ "Prelude" : witnessModules ++ modules
f <- interpret action witness
return $ f value
+ --------------------------------------------------------------------------
loadInterpreter = unsafeRunInterpreterWithArgs opts interpreter
+ --------------------------------------------------------------------------
formatOnError (Left err) = error $ format err
formatOnError (Right a) = a
+ --------------------------------------------------------------------------
loader = formatOnError `fmap` protectHandlers loadInterpreter
+ --------------------------------------------------------------------------
initialize = liftM2 (,) getCurrentTime $ getTreeStatus srcPaths
+ --------------------------------------------------------------------------
test (prevTime, ts) = do
now <- getCurrentTime
if diffUTCTime now prevTime < 3
View
54 src/Snap/Loader/Devel/Evaluator.hs
@@ -5,16 +5,13 @@ module Snap.Loader.Devel.Evaluator
, protectedHintEvaluator
) where
-
+------------------------------------------------------------------------------
import Control.Exception
import Control.Monad (when)
import Control.Monad.Trans (liftIO)
-
import Control.Concurrent (ThreadId, forkIO, myThreadId)
import Control.Concurrent.MVar
-
import Prelude hiding (catch, init, any)
-
import Snap.Core (Snap)
@@ -24,43 +21,41 @@ type HintLoadable = IO (Snap (), IO ())
------------------------------------------------------------------------------
--- | Convert an action to generate 'HintLoadable's into Snap and IO
--- actions that handle periodic reloading. The resulting action will
--- share initialized state until the next execution of the input
--- action. At this time, the cleanup action will be executed.
+-- | Convert an action to generate 'HintLoadable's into Snap and IO actions
+-- that handle periodic reloading. The resulting action will share initialized
+-- state until the next execution of the input action. At this time, the
+-- cleanup action will be executed.
--
--- The first two arguments control when recompiles are done. The
--- first argument is an action that is executed when compilation
--- starts. The second is a function from the result of the first
--- action to an action that determines whether the value from the
--- previous compilation is still good. This abstracts out the
--- strategy for determining when a cached result is no longer valid.
+-- The first two arguments control when recompiles are done. The first argument
+-- is an action that is executed when compilation starts. The second is a
+-- function from the result of the first action to an action that determines
+-- whether the value from the previous compilation is still good. This
+-- abstracts out the strategy for determining when a cached result is no longer
+-- valid.
--
--- If an exception is raised during the processing of the action, it
--- will be thrown to all waiting threads, and for all requests made
--- before the recompile condition is reached.
+-- If an exception is raised during the processing of the action, it will be
+-- thrown to all waiting threads, and for all requests made before the
+-- recompile condition is reached.
protectedHintEvaluator :: forall a.
IO a
-> (a -> IO Bool)
-> IO HintLoadable
-> IO (Snap (), IO ())
protectedHintEvaluator start test getInternals = do
- -- The list of requesters waiting for a result. Contains the
- -- ThreadId in case of exceptions, and an empty MVar awaiting a
- -- successful result.
+ -- The list of requesters waiting for a result. Contains the ThreadId in
+ -- case of exceptions, and an empty MVar awaiting a successful result.
readerContainer <- newReaderContainer
- -- Contains the previous result and initialization value, and the
- -- time it was stored, if a previous result has been computed.
- -- The result stored is either the actual result and
- -- initialization result, or the exception thrown by the
- -- calculation.
+ -- Contains the previous result and initialization value, and the time it
+ -- was stored, if a previous result has been computed. The result stored is
+ -- either the actual result and initialization result, or the exception
+ -- thrown by the calculation.
resultContainer <- newResultContainer
- -- The model used for the above MVars in the returned action is
- -- "keep them full, unless updating them." In every case, when
- -- one of those MVars is emptied, the next action is to fill that
- -- same MVar. This makes deadlocking on MVar wait impossible.
+ -- The model used for the above MVars in the returned action is "keep them
+ -- full, unless updating them." In every case, when one of those MVars is
+ -- emptied, the next action is to fill that same MVar. This makes
+ -- deadlocking on MVar wait impossible.
let snap = do
let waitForNewResult :: IO (Snap ())
waitForNewResult = do
@@ -132,6 +127,7 @@ protectedHintEvaluator start test getInternals = do
cleanup contents
return (snap, clean)
+
where
newReaderContainer :: IO (MVar [(ThreadId, MVar (Snap ()))])
newReaderContainer = newMVar []
View
26 src/Snap/Loader/Devel/Signal.hs
@@ -1,43 +1,57 @@
{-# LANGUAGE CPP #-}
module Snap.Loader.Devel.Signal (protectHandlers) where
+------------------------------------------------------------------------------
import Control.Exception (bracket)
+
#ifdef mingw32_HOST_OS
-import GHC.ConsoleHandler as C
+ -------------
+ -- windows --
+ -------------
+------------------------------------------------------------------------------
+import GHC.ConsoleHandler as C
saveHandlers :: IO C.Handler
saveHandlers = C.installHandler Ignore
-
restoreHandlers :: C.Handler -> IO C.Handler
restoreHandlers = C.installHandler
+------------------------------------------------------------------------------
#else
+
+ -----------
+ -- posix --
+ -----------
+------------------------------------------------------------------------------
import qualified System.Posix.Signals as S
helper :: S.Handler -> S.Signal -> IO S.Handler
helper handler signal = S.installHandler signal handler Nothing
-
signals :: [S.Signal]
signals = [ S.sigQUIT
, S.sigINT
, S.sigHUP
, S.sigTERM
]
-
saveHandlers :: IO [S.Handler]
saveHandlers = mapM (helper S.Ignore) signals
-
restoreHandlers :: [S.Handler] -> IO [S.Handler]
restoreHandlers h = sequence $ zipWith helper h signals
-
+------------------------------------------------------------------------------
#endif
+
+ ----------
+ -- both --
+ ----------
+------------------------------------------------------------------------------
protectHandlers :: IO a -> IO a
protectHandlers a = bracket saveHandlers restoreHandlers $ const a
+------------------------------------------------------------------------------
View
11 src/Snap/Loader/Devel/TreeWatcher.hs
@@ -1,14 +1,13 @@
module Snap.Loader.Devel.TreeWatcher
- ( TreeStatus
- , getTreeStatus
- , checkTreeStatus
- ) where
+ ( TreeStatus
+ , getTreeStatus
+ , checkTreeStatus
+ ) where
+------------------------------------------------------------------------------
import Control.Applicative
-
import System.Directory
import System.Directory.Tree
-
import System.Time
View
2 src/Snap/Loader/Prod.hs
@@ -1,8 +1,10 @@
{-# LANGUAGE TemplateHaskell #-}
+
module Snap.Loader.Prod
( loadSnapTH
) where
+------------------------------------------------------------------------------
import Language.Haskell.TH
View
27 src/Snap/Starter.hs
@@ -13,8 +13,7 @@ import System.Exit
import System.Console.GetOpt
import System.FilePath
------------------------------------------------------------------------------
-
-import Snap.StarterTH
+import Snap.StarterTH
------------------------------------------------------------------------------
@@ -23,6 +22,7 @@ buildData "tDirBareBones" "barebones"
buildData "tDirDefault" "default"
buildData "tDirTutorial" "tutorial"
+
------------------------------------------------------------------------------
usage :: String
usage = unlines
@@ -59,59 +59,72 @@ initUsage = unlines
]
+------------------------------------------------------------------------------
printUsage :: [String] -> IO ()
printUsage ("init":_) = putStrLn initUsage
printUsage _ = putStrLn usage
+
------------------------------------------------------------------------------
-- Only one option for now
data Option = Help
deriving (Show, Eq)
+------------------------------------------------------------------------------
setup :: String -> ([FilePath], [(String, String)]) -> IO ()
setup projName tDir = do
mapM createDirectory (fst tDir)
mapM_ write (snd tDir)
where
+ --------------------------------------------------------------------------
write (f,c) =
if isSuffixOf "foo.cabal" f
then writeFile (projName ++ ".cabal") (insertProjName $ T.pack c)
else writeFile f c
+
+ --------------------------------------------------------------------------
isNameChar c = isAlphaNum c || c == '-'
+
+ --------------------------------------------------------------------------
insertProjName c = T.unpack $ T.replace
(T.pack "projname")
(T.pack $ filter isNameChar projName) c
+
------------------------------------------------------------------------------
initProject :: [String] -> IO ()
initProject args = do
case getOpt Permute options args of
(flags, other, [])
- | Help `elem` flags -> do printUsage other
- exitFailure
- | otherwise -> go other
+ | Help `elem` flags -> printUsage other >> exitFailure
+ | otherwise -> go other
+
(_, other, errs) -> do putStrLn $ concat errs
printUsage other
exitFailure
where
+ --------------------------------------------------------------------------
options =
[ Option ['h'] ["help"] (NoArg Help)
"Print this message"
]
+ --------------------------------------------------------------------------
go ("init":rest) = init' rest
go _ = do
putStrLn "Error: Invalid action!"
putStrLn usage
exitFailure
+ --------------------------------------------------------------------------
init' args' = do
cur <- getCurrentDirectory
- let dirs = splitDirectories cur
+ let dirs = splitDirectories cur
projName = last dirs
- setup' = setup projName
+ setup' = setup projName
+
case args' of
[] -> setup' tDirDefault
["barebones"] -> setup' tDirBareBones
View
16 src/Snap/StarterTH.hs
@@ -14,11 +14,12 @@ import System.FilePath
------------------------------------------------------------------------------
-- Convenience types
type FileData = (String, String)
-type DirData = FilePath
+type DirData = FilePath
------------------------------------------------------------------------------
--- Gets all the directorys in a DirTree
+-- Gets all the directories in a DirTree
+--
getDirs :: [FilePath] -> DirTree a -> [FilePath]
getDirs prefix (Dir n c) = (intercalate "/" (reverse (n:prefix))) :
concatMap (getDirs (n:prefix)) c
@@ -29,6 +30,7 @@ getDirs _ (Failed _ _) = []
------------------------------------------------------------------------------
-- Reads a directory and returns a tuple of the list of all directories
-- encountered and a list of filenames and content strings.
+--
readTree :: FilePath -> IO ([DirData], [FileData])
readTree dir = do
d <- readDirectory $ dir </> "."
@@ -39,7 +41,8 @@ readTree dir = do
------------------------------------------------------------------------------
--- Calls readTree and returns it's value in a quasiquote.
+-- Calls readTree and returns its value in a quasiquote.
+--
dirQ :: FilePath -> Q Exp
dirQ tplDir = do
d <- runIO . readTree $ "project_template" </> tplDir
@@ -49,10 +52,11 @@ dirQ tplDir = do
------------------------------------------------------------------------------
-- Creates a declaration assigning the specified name the value returned by
-- dirQ.
+--
buildData :: String -> FilePath -> Q [Dec]
buildData dirName tplDir = do
- let dir = mkName dirName
-
+ let dir = mkName dirName
typeSig <- SigD dir `fmap` [t| ([String], [(String, String)]) |]
- v <- valD (varP dir) (normalB $ dirQ tplDir) []
+ v <- valD (varP dir) (normalB $ dirQ tplDir) []
+
return [typeSig, v]

0 comments on commit 424e356

Please sign in to comment.
Something went wrong with that request. Please try again.