{-# LANGUAGE OverloadedStrings #-}{-# LANGUAGE TemplateHaskell #-}-- | 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-- location, compiler arguments, etc, and bind that information into-- the calls to the dynamic loader.moduleSnap.Extension.Loader.Devel(loadSnapTH,loadSnapTH')whereimportControl.Monad(liftM2)importData.ListimportData.Maybe(catMaybes)importData.Time.Clock(diffUTCTime,getCurrentTime)importLanguage.Haskell.Interpreterhiding(lift,liftIO)importLanguage.Haskell.Interpreter.UnsafeimportLanguage.Haskell.THimportSystem.Environment(getArgs)------------------------------------------------------------------------------importSnap.TypesimportSnap.Extension.Loader.Devel.SignalimportSnap.Extension.Loader.Devel.EvaluatorimportSnap.Extension.Loader.Devel.TreeWatcher-------------------------------------------------------------------------------- | 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 :: Initializer s -> SnapExtend s () -> [String] -> IO (Snap ())---- with a magical implementation.---- The upshot is that you shouldn't need to recompile your server-- during development unless your .cabal file changes, or the code-- that uses this splice changes.loadSnapTH::Name->Name->[String]->QExploadSnapTHinitializeractionadditionalWatchDirs=loadSnapTH'modulesimportsadditionalWatchDirsloadStrwhereinitMod=nameModuleinitializerinitBase=nameBaseinitializeractMod=nameModuleactionactBase=nameBaseactionmodules=catMaybes[initMod,actMod]imports=["Snap.Extension"]loadStr=intercalate" "["runInitializerWithoutReloadAction",initBase,actBase]-------------------------------------------------------------------------------- | This is the backing implementation for 'loadSnapTH'. This-- interface can be used when the types involved don't include a-- SnapExtend and an Initializer.loadSnapTH'::[String]-- ^ the list of modules to interpret->[String]-- ^ the list of modules to import in addition-- to those being interpreted->[String]-- ^ additional directories to watch for-- changes to trigger to recompile/reload->String-- ^ the expression to interpret in the-- context of the loaded modules and imports.-- It should have the type 'HintLoadable'->QExploadSnapTH'modulesimportsadditionalWatchDirsloadStr=doargs<-runIOgetArgsletopts=getHintOptsargssrcPaths=additionalWatchDirs++getSrcPathsargs[|hintSnapoptsmodulesimportssrcPathsloadStr|]-------------------------------------------------------------------------------- | Convert the command-line arguments passed in to options for the-- hint interpreter. This is somewhat brittle code, based on a few-- experimental datapoints regarding the structure of the command-line-- arguments cabal produces.getHintOpts::[String]->[String]getHintOptsargs=removeBadoptswherebad=["-threaded","-O"]removeBad=filter(\x->not$any(`isPrefixOf`x)bad)hideAll=filter(=="-hide-all-packages")argssrcOpts=filter(\x->"-i"`isPrefixOf`x&&not("-idist"`isPrefixOf`x))argstoCopy=filter(not.isSuffixOf".hs")$dropWhile(not.("-package"`isPrefixOf`))argscopy=map(intercalate" ").groupBy(\_s->not$"-"`isPrefixOf`s)opts=hideAll++srcOpts++copytoCopy-------------------------------------------------------------------------------- | This function extracts the source paths from the compilation argsgetSrcPaths::[String]->[String]getSrcPaths=filter(not.null).map(drop2).filtersrcArgwheresrcArgx="-i"`isPrefixOf`x&&not("-idist"`isPrefixOf`x)-------------------------------------------------------------------------------- | 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.hintSnap::[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 modules that need to be be-- imported, in addition to the ones that need to-- be interpreted. This only needs to contain-- modules that aren't being interpreted, such as-- those from other libraries, that are used in-- the expression passed in.->[String]-- ^ A list of paths to watch for updates->String-- ^ The string to execute->IO(Snap(),IO())hintSnapoptsmodulesimportssrcPathsaction=protectedHintEvaluatorinitializetestloaderwhereinterpreter=doloadModules.nub$modulessetImports.nub$"Prelude":"Snap.Types":imports++modulesinterpretaction(as::HintLoadable)loadInterpreter=unsafeRunInterpreterWithArgsoptsinterpreterformatOnError(Lefterr)=error$formaterrformatOnError(Righta)=aloader=formatOnError`fmap`protectHandlersloadInterpreterinitialize=liftM2(,)getCurrentTime$getTreeStatussrcPathstest(prevTime,ts)=donow<-getCurrentTimeifdiffUTCTimenowprevTime<3thenreturnTrueelsecheckTreeStatusts-------------------------------------------------------------------------------- | Convert an InterpreterError to a String for presentationformat::InterpreterError->Stringformat(UnknownErrore)="Unknown interpreter error:\r\n\r\n"++eformat(NotAllowede)="Interpreter action not allowed:\r\n\r\n"++eformat(GhcExceptione)="GHC error:\r\n\r\n"++eformat(WontCompileerrs)="Compile errors:\r\n\r\n"++(intercalate"\r\n"$nub$maperrMsgerrs)