{-# LANGUAGE CPP             #-}
{-# 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.
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
import           Snap.Loader.Devel.TreeWatcher
#else
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 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.
--
-- 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
           -> Q Exp
#ifndef HINT_ENABLED
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
        srcPaths = additionalWatchDirs ++ getSrcPaths args

    -- The first line is an extra type check to ensure the arguments
    -- provided have the the correct types
    [| do let _ = $initializer >>= $(varE action)
          v <- $initializer
          (handler, cleanup) <- hintSnap opts actMods srcPaths loadStr v
          return (v, handler, cleanup) |]
  where
    actMods = maybeToList $ nameModule action
    loadStr = nameBase action


------------------------------------------------------------------------------
-- | 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]
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      = concat [hideAll, srcOpts, copy toCopy]


------------------------------------------------------------------------------
-- | This function extracts the source paths from the compilation args
getSrcPaths :: [String] -> [String]
getSrcPaths = filter (not . null) . map (drop 2) . filter srcArg
  where
    srcArg x = "-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 :: 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
         -> 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.
    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
            then return True
            else checkTreeStatus ts


------------------------------------------------------------------------------
-- | Convert an InterpreterError to a String for presentation
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)

#endif