load files quickly

ghcLoad.hs

{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import Control.Applicative
import Control.Concurrent
import Control.Monad
import Data.Time.Clock
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import System.Posix.Process
import Diagrams.Backend.Cairo.Internal
import Unsafe.Coerce

import GHC
import GHC.Paths
import MonadUtils

run m = run' (initGhc >> m)

run' m = runGhc (Just libdir) m

initGhc :: Ghc ()
initGhc = do
  dfs <- getSessionDynFlags
  setSessionDynFlags $ dfs { hscTarget = HscInterpreted }
  return ()

main = do
  run $ do
    renderDiagram "dia1.hs"
    sess <- getSession
    liftIO . forkProcess . run' $ do
      setSession sess
      renderDiagram "dia2.hs"
      renderDiagram "dia3.hs"
  threadDelay 2000000

renderDiagram :: FilePath ->  Ghc ()
renderDiagram file = measureTime ("rendering " ++ file) $ do
  setTargets =<< mapM (\x -> guessTarget x Nothing) [file]
  graph <- depanal [] False
  load LoadAllTargets
  setContext (map (IIModule . moduleName . ms_mod) graph)
  (dia :: Diagram Cairo R2) <- unsafeCoerce <$> compileExpr "dia"
  liftIO . fst $ renderDia Cairo (CairoOptions (file ++ ".png") (Width 500) PNG False) dia
  return ()

measureTime :: MonadIO m => String -> m a -> m a
measureTime txt m = do
  t0 <- liftIO getCurrentTime
  r  <- m
  t1 <- liftIO getCurrentTime
  liftIO $ putStrLn (txt ++ " " ++ show (diffUTCTime t1 t0))
  return r

hintLoad.hs

{-# LANGUAGE StandaloneDeriving, DeriveDataTypeable #-}

module Main where

import Control.Concurrent
import Control.Monad
import Data.Time.Clock
import Diagrams.Prelude
import Diagrams.Backend.Cairo
import Language.Haskell.Interpreter
import System.Posix.Process
import Diagrams.Backend.Cairo.Internal
import Data.Typeable

deriving instance Typeable Any

main = do
  runInterpreter (renderDiagram "dia1.hs")
  runInterpreter (renderDiagram "dia2.hs" >> renderDiagram "dia3.hs")
  forkProcess (void $ runInterpreter (renderDiagram "dia4.hs" >> renderDiagram "dia5.hs"))
  threadDelay 2000000
  return ()

renderDiagram :: FilePath ->  Interpreter ()
renderDiagram file = measureTime ("rendering " ++ file) $ do
  loadModules [file]
  ms <- getLoadedModules
  setTopLevelModules ms
  dia <- interpret "dia" (as :: Diagram Cairo R2)
  liftIO . fst $ renderDia Cairo (CairoOptions (file ++ ".png") (Width 500) PNG False) dia
  return ()

measureTime :: MonadIO m => String -> m a -> m a
measureTime txt m = do
  t0 <- liftIO getCurrentTime
  r  <- m
  t1 <- liftIO getCurrentTime
  liftIO $ putStrLn (txt ++ " " ++ show (diffUTCTime t1 t0))
  return r