From 424e3560af8ddc6c83c3e55d7be57efea37fca59 Mon Sep 17 00:00:00 2001 From: Gregory Collins Date: Sun, 11 Dec 2011 18:53:41 +0100 Subject: [PATCH] More source style cleanup. --- project_template/default/src/Application.hs | 21 +-- project_template/default/src/Main.hs | 115 +++++++------- project_template/default/src/Site.hs | 16 +- src/Control/Access/RoleBased/Checker.hs | 3 +- src/Control/Access/RoleBased/Internal/Role.hs | 8 +- .../Access/RoleBased/Internal/RoleMap.hs | 4 +- src/Control/Access/RoleBased/Internal/Rule.hs | 8 +- .../Access/RoleBased/Internal/Types.hs | 3 +- src/Control/Access/RoleBased/Role.hs | 1 + src/Snap/Loader/Devel.hs | 148 ++++++++++-------- src/Snap/Loader/Devel/Evaluator.hs | 54 +++---- src/Snap/Loader/Devel/Signal.hs | 26 ++- src/Snap/Loader/Devel/TreeWatcher.hs | 11 +- src/Snap/Loader/Prod.hs | 2 + src/Snap/Starter.hs | 27 +++- src/Snap/StarterTH.hs | 16 +- 16 files changed, 260 insertions(+), 203 deletions(-) diff --git a/project_template/default/src/Application.hs b/project_template/default/src/Application.hs index 051b7845..8e576a5c 100644 --- a/project_template/default/src/Application.hs +++ b/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 + + diff --git a/project_template/default/src/Main.hs b/project_template/default/src/Main.hs index 9bd6ca23..15808b2a 100644 --- a/project_template/default/src/Main.hs +++ b/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. diff --git a/project_template/default/src/Site.hs b/project_template/default/src/Site.hs index 5d619903..f8326afe 100644 --- a/project_template/default/src/Site.hs +++ b/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 diff --git a/src/Control/Access/RoleBased/Checker.hs b/src/Control/Access/RoleBased/Checker.hs index 3122ad83..269aef2c 100644 --- a/src/Control/Access/RoleBased/Checker.hs +++ b/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 diff --git a/src/Control/Access/RoleBased/Internal/Role.hs b/src/Control/Access/RoleBased/Internal/Role.hs index 8fcd6015..b001067c 100644 --- a/src/Control/Access/RoleBased/Internal/Role.hs +++ b/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,6 +71,7 @@ data RoleValueMeta = RoleBoolMeta | RoleDoubleMeta +------------------------------------------------------------------------------ data RoleDataDefinition = RoleDataDefinition { _roleDataName :: Text , _roleValueMeta :: RoleValueMeta @@ -74,6 +79,7 @@ data RoleDataDefinition = RoleDataDefinition { } +------------------------------------------------------------------------------ data RoleMetadata = RoleMetadata { _roleMetadataName :: Text , _roleDescription :: Text diff --git a/src/Control/Access/RoleBased/Internal/RoleMap.hs b/src/Control/Access/RoleBased/Internal/RoleMap.hs index e9cb1193..67cc33aa 100644 --- a/src/Control/Access/RoleBased/Internal/RoleMap.hs +++ b/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)) diff --git a/src/Control/Access/RoleBased/Internal/Rule.hs b/src/Control/Access/RoleBased/Internal/Rule.hs index 689c0cf6..71bf1dc5 100644 --- a/src/Control/Access/RoleBased/Internal/Rule.hs +++ b/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 diff --git a/src/Control/Access/RoleBased/Internal/Types.hs b/src/Control/Access/RoleBased/Internal/Types.hs index d5223237..062fb178 100644 --- a/src/Control/Access/RoleBased/Internal/Types.hs +++ b/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 diff --git a/src/Control/Access/RoleBased/Role.hs b/src/Control/Access/RoleBased/Role.hs index 203de3c6..571a6cf8 100644 --- a/src/Control/Access/RoleBased/Role.hs +++ b/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) diff --git a/src/Snap/Loader/Devel.hs b/src/Snap/Loader/Devel.hs index e3c86828..2272d297 100644 --- a/src/Snap/Loader/Devel.hs +++ b/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,41 +129,50 @@ 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 @@ -163,15 +180,20 @@ hintSnap opts modules srcPaths action value = 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 diff --git a/src/Snap/Loader/Devel/Evaluator.hs b/src/Snap/Loader/Devel/Evaluator.hs index a7e4e3d7..b5375db8 100644 --- a/src/Snap/Loader/Devel/Evaluator.hs +++ b/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 [] diff --git a/src/Snap/Loader/Devel/Signal.hs b/src/Snap/Loader/Devel/Signal.hs index b622273f..18cf9397 100644 --- a/src/Snap/Loader/Devel/Signal.hs +++ b/src/Snap/Loader/Devel/Signal.hs @@ -1,27 +1,37 @@ {-# 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 @@ -29,15 +39,19 @@ signals = [ S.sigQUIT , 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 +------------------------------------------------------------------------------ diff --git a/src/Snap/Loader/Devel/TreeWatcher.hs b/src/Snap/Loader/Devel/TreeWatcher.hs index 4059ae8e..5d661c00 100644 --- a/src/Snap/Loader/Devel/TreeWatcher.hs +++ b/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 diff --git a/src/Snap/Loader/Prod.hs b/src/Snap/Loader/Prod.hs index cb2f9678..ad81f4a5 100644 --- a/src/Snap/Loader/Prod.hs +++ b/src/Snap/Loader/Prod.hs @@ -1,8 +1,10 @@ {-# LANGUAGE TemplateHaskell #-} + module Snap.Loader.Prod ( loadSnapTH ) where +------------------------------------------------------------------------------ import Language.Haskell.TH diff --git a/src/Snap/Starter.hs b/src/Snap/Starter.hs index c98158ca..1092994a 100644 --- a/src/Snap/Starter.hs +++ b/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 diff --git a/src/Snap/StarterTH.hs b/src/Snap/StarterTH.hs index 09900db8..8dbd3c35 100644 --- a/src/Snap/StarterTH.hs +++ b/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]