GhcTestcase.hs

-- $ ghc -package ghc -package ghc-paths GhcTestcase.hs
module Main where

import GHC
import GHC.Paths (libdir)
import DynFlags
import CoreMonad
import Pretty
import PprTyThing
import Outputable
import Bag
import Data.List

main :: IO ()
main = do
  defaultErrorHandler defaultFatalMessager defaultFlushOut $
    runGhc (Just libdir) $
      doStuff "Main.hs" "Main"

doStuff :: String -> String -> Ghc ()
doStuff targetFile targetModule = do
    dflags' <- getSessionDynFlags
    setSessionDynFlags dflags' {
        ghcLink   = LinkInMemory
      , hscTarget = HscInterpreted
      }
    dflags <- getSessionDynFlags

    target <- guessTarget targetFile Nothing
    setTargets [target]

    _ <- load LoadAllTargets
    setContext [IIModule $ mkModuleName targetModule]

    mss <- getModuleGraph
    let Just ms = find (\m -> Just targetFile == ml_hs_file (ms_location m)) mss

    p <- parseModule ms
    tcm@TypecheckedModule{tm_typechecked_source = tcs} <- typecheckModule p

    let AbsBinds _ _ _ _ bs = head $ map unLoc $ bagToList tcs
        FunBind{ fun_matches = m } = head $ map unLoc $ bagToList bs
        ty = mg_res_ty m

    liftIO $ putStrLn $ "Type: " ++ showOneLine dflags (pprTypeForUser ty)

    return ()

showGhc x df = showSDoc df $ ppr x

showOneLine :: DynFlags -> SDoc -> String
showOneLine dflag =
    showDocWith dflag OneLineMode . withStyle dflag styleUnqualified

styleUnqualified :: PprStyle
styleUnqualified = mkUserStyle neverQualify AllTheWay

showDocWith dflags mode = Pretty.showDoc mode (pprCols dflags)

withStyle = withPprStyleDoc

Main.hs

module Main where

foo :: Num a => a
foo = 123