Use the GHC API to time the type checker

Compiler.hs

import Control.Arrow ((***))
import Control.Monad (replicateM_)
import Control.Monad.IO.Class
import Data.List (isPrefixOf)
import Data.Time.Clock
import DynFlags (defaultFatalMessager, defaultFlushOut, PkgConfRef(PkgConfFile))
import GHC
import GHC.Paths (libdir)
import System.FilePath (takeBaseName, splitExtension, addExtension)
import Text.Printf

data Timing = Timing { parseTime     :: Double
                     , typecheckTime :: Double
                     , desugarTime   :: Double }
              deriving Show

showTCTime :: Timing -> String
showTCTime = printf "%0.2f ms" . (*1000) . typecheckTime

main :: IO ()
main = do runTest "benchmarks/CompilerVinyl.hs" >>=
            print . (showTCTime***showTCTime)
          runTest "benchmarks/CompilerTree.hs" >>=
            print . (showTCTime *** showTCTime)
          runTest "benchmarks/CompilerTree2.hs" >>=
            print . (showTCTime *** showTCTime)

timeThis :: MonadIO m => m a -> m (a, Double)
timeThis m = do start <- liftIO getCurrentTime
                res <- m
                replicateM_ 9 m
                stop <- res `seq` liftIO getCurrentTime
                return $ (res, realToFrac (diffUTCTime stop start) * 0.1)

-- | Find the sandbox package db
findDB :: IO String
findDB = do
  lns <- readFile "cabal.sandbox.config"
  case filter (isPrefixOf "package-db:") (lines lns) of
    [dbline] -> return $ drop (length "package-db: ") dbline
    _ -> error "Error parsing cabal.sandbox.config"

-- | Times parsing, type checking, and desugaring for the given file.
runTypechecker :: FilePath -> Ghc Timing
runTypechecker targetFile = do
  target <- guessTarget targetFile Nothing
  setTargets [target]
  load LoadAllTargets
  modSum <- getModSummary $ mkModuleName (takeBaseName targetFile)
  (p,ptime) <- timeThis $ parseModule modSum
  (t,tctime) <- timeThis $ typecheckModule p
  (_d, dtime) <- timeThis $ desugarModule t
  -- l <- loadModule d
  -- n <- getNamesInScope
  -- c <- return (coreModule d)
  -- g <- getModuleGraph
  return $ Timing ptime tctime dtime

-- | Sets up a GHC session, type checks one module, then another one
-- /in the same session/. The second one's name is inferred from the
-- argument. If \"Foo.hs\" is the argument, then \"Foo.hs\" is loaded
-- (and timed) first, followed by \"FooUse.hs\" in the same
-- session. This lets you separate setup code from use code.
runTest :: FilePath -> IO (Timing, Timing)
runTest targetFile =
  defaultErrorHandler defaultFatalMessager defaultFlushOut $ do
    runGhc (Just libdir) $ do
      dflags <- getSessionDynFlags
      dbPath <- liftIO findDB
      let dflags' = dflags { extraPkgConfs = (++) [PkgConfFile dbPath] }
      setSessionDynFlags dflags'
      t1 <- runTypechecker targetFile
      let useFile = let (f,e) = splitExtension targetFile
                    in addExtension (f ++ "Use") e
      t2 <- runTypechecker useFile
      return (t1,t2)

{-

I have this stanza in the .cabal file for my test project

benchmark compile
  type: exitcode-stdio-1.0
  hs-source-dirs: benchmarks
  main-is: Compiler.hs
  build-depends: base >= 4.8 && < 5, time, ghc, filepath, ghc-paths,
                 transformers
  default-language: Haskell2010
  
  Note that all dependencies should be installed in the sandbox. Also,
  if there is a library in the test project, it must be *installed* in
  the sandbox for GHC to find it.
-}