module Snap.Extension.Loader.Devel
( loadSnapTH
) where
import Control.Monad (liftM2)
import Data.List
import Data.Maybe (catMaybes)
import Data.Time.Clock (diffUTCTime, getCurrentTime)
import Language.Haskell.Interpreter hiding (lift, liftIO)
import Language.Haskell.Interpreter.Unsafe
import Language.Haskell.TH
import System.Environment (getArgs)
import Snap.Types
import Snap.Extension (runInitializerWithoutReloadAction)
import Snap.Extension.Loader.Devel.Signal
import Snap.Extension.Loader.Devel.Evaluator
import Snap.Extension.Loader.Devel.TreeWatcher
loadSnapTH :: Name -> Name -> [String] -> Q Exp
loadSnapTH initializer action additionalWatchDirs = do
args <- runIO getArgs
let initMod = nameModule initializer
initBase = nameBase initializer
actMod = nameModule action
actBase = nameBase action
opts = getHintOpts args
modules = catMaybes [initMod, actMod]
srcPaths = additionalWatchDirs ++ getSrcPaths args
[| let _ = runInitializerWithoutReloadAction $(varE initializer)
$(varE action)
in hintSnap opts modules srcPaths initBase actBase |]
getHintOpts :: [String] -> [String]
getHintOpts args = removeBad opts
where
bad = ["-threaded", "-O"]
removeBad = filter (\x -> not $ any (`isPrefixOf` x) bad)
hideAll = filter (== "-hide-all-packages") 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)
opts = hideAll ++ srcOpts ++ copy toCopy
getSrcPaths :: [String] -> [String]
getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg
where
srcArg x = "-i" `isPrefixOf` x && not ("-idist" `isPrefixOf` x)
hintSnap :: [String]
-> [String]
-> [String]
-> String
-> String
-> IO (Snap ())
hintSnap opts modules srcPaths initialization handler =
protectedHintEvaluator initialize test loader
where
action = intercalate " " [ "runInitializerWithoutReloadAction"
, initialization
, handler
]
interpreter = do
loadModules . nub $ modules
let imports = "Prelude" :
"Snap.Extension" :
"Snap.Types" :
modules
setImports . nub $ imports
interpret action (as :: HintLoadable)
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
then return True
else checkTreeStatus ts
format :: InterpreterError -> String
format (UnknownError e) = "Unknown interpreter error:\r\n\r\n" ++ e
format (NotAllowed e) = "Interpreter action not allowed:\r\n\r\n" ++ e
format (GhcException e) = "GHC error:\r\n\r\n" ++ e
format (WontCompile errs) = "Compile errors:\r\n\r\n" ++
(intercalate "\r\n" $ nub $ map errMsg errs)