GhcApiAstTraversals: APISybTesting.hs

{-# LANGUAGE RankNTypes #-}

{-# OPTIONS_GHC -package ghc #-}
module APISybTesting where

import System.IO
import Data.Maybe
import Data.Generics

-- import qualified GHC.Paths
import DynFlags
import GHC
import Outputable

import Instances
import Utils
import Data.List

compileToCoreFlag = False

libdir  = "c:/fptools/ghc" -- GHC.Paths.libdir
source  = "TestModule.hs"
modName = "TestModule"

getTyClDs :: Data a => a -> [TyClDecl RdrName]
getTyClDs = everythingStaged Parser (++) [] ((const []) `extQ` getTyClD)
  where getTyClD d = [ x | x@(ClassDecl{}) <- [d] ]
                  ++ [ x | x@(TyFamily{}) <- [d] ] 

main = defaultErrorHandler defaultDynFlags $ do
  s           <- newSession (Just libdir)
  flags       <- getSessionDynFlags s
  (flags,_,_) <- parseDynamicFlags flags ["-package ghc"]
  GHC.defaultCleanupHandler flags $ do
    setSessionDynFlags s flags{ hscTarget=HscInterpreted }
    addTarget s =<< guessTarget source Nothing
    load s LoadAllTargets
    unqual  <- getPrintUnqual s
    mcm <- checkModule s (mkModuleName modName) compileToCoreFlag
    maybe
      (putStrLn $ "checkModule "++modName++" failed")
      (doSomething unqual)
      mcm
  where doSomething unqual cm = do
          let parsed      = parsedSource cm
              renamed     = renamedSource cm
              typechecked = typecheckedSource cm
              transformed = everywhere id parsed
              shown stage what  = (text . showData stage 0) what
              prettied          = ppr transformed
              queried           = getTyClDs parsed
          putStrLn "------------------------- pretty-printed transformed"
          printForUser stdout unqual prettied
          putStrLn "------------------------- queried parsed"
          mapM_ (printDump . ppr) queried
          putStrLn "------------------------- shown transformed"
          printForUser stdout unqual (shown Parser transformed)
          putStrLn "------------------------- shown renamed"
          maybe (putStrLn "no renamed source") 
                (printForUser stdout unqual . shown Renamer) renamed
          putStrLn "------------------------- shown type-checked"
          maybe (putStrLn "no typechecked source")
                (printForUser stdout unqual . shown TypeChecker) typechecked