GhcTestcase.hs

-- $ ghc -package ghc -package ghc-paths GhcTestcase.hs
{-# LANGUAGE ScopedTypeVariables #-}
module Main where

import GHC
import GHC.Paths (libdir)
import DynFlags
import CoreMonad
import Pretty
import PprTyThing
import Outputable
import Bag
import Var
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

    liftIO $ putStrLn $ showGhc dflags tcs

    let abs@(AbsBinds tvs evs eps evbs bs) = head $ map unLoc $ bagToList tcs
        PatBind{ pat_rhs_ty=ty } = (map unLoc $ bagToList bs) !! 0
        ts = [ varType poly
             | ABE poly mono _ _ <- eps
             , ty == varType mono
             ]

--        ty:_ = map (varType . abe_poly) eps


    liftIO $ putStrLn $ showGhc dflags eps
    liftIO $ putStrLn $ showGhc dflags bs
    liftIO $ putStrLn $ showGhc dflags [ varType mono | ABE poly mono _ _ <- eps ]
    liftIO $ putStrLn $ showGhc dflags [ ty ]

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

    return ()

showGhc df x = 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

{-# LANGUAGE NoMonomorphismRestriction, ExtendedDefaultRules, RankNTypes, ImpredicativeTypes #-}
module Main where

main = undefined

foo = (undefined :: [Ty a])

type Ty a = forall a. Show a => a -> String