Example calling GHC parser, see parse.hs

Example.hs

module Example where

data Nat where
  Zero :: Nat
  Succ :: Nat -> Nat

append :: [a] -> [a] -> [a]
append  []    ys = ys
append (x:xs) ys = x : (xs `append` ys)

output_of_Example_hs.txt

after init
after guess-target: main:Example.hs
after add-target
after load
after get-mod-summary
after parse-module
after typecheck-module


--------- import      ---------
[import (implicit) Prelude]

--------- renamed     ---------
append :: [a_ae8X] -> [a_ae8X] -> [a_ae8X]
append [] ys_ae8Y = ys_ae8Y
append (x_ae8Z : xs_ae90) ys_aeol
  = x_ae8Z : (xs_ae90 `append` ys_aeol)

data Nat
  where
    Zero :: Nat
    Succ :: Nat -> Nat

--------- typechecked ---------
{$tcNat
   = TyCon
       6774794289921473930#Word64 954926092812452586#Word64 $trModule
       (TrNameS "Nat"#) 0# krep$*,
 $tc'Zero
   = TyCon
       2223736912507801561#Word64 1102229298213618911#Word64 $trModule
       (TrNameS "'Zero"#) 0# $krep_aer7,
 $tc'Succ
   = TyCon
       3532505836852418069#Word64 6633241622569351272#Word64 $trModule
       (TrNameS "'Succ"#) 0# $krep_aer8,
 $krep_aer8 [InlPrag=[~]] = KindRepFun $krep_aer7 $krep_aer7,
 $krep_aer7 [InlPrag=[~]] = KindRepTyConApp $tcNat [],
 $trModule = Module (TrNameS "main"#) (TrNameS "Example"#),
 append_aeqH [] ys_ae8Y = ys_ae8Y
 append_aeqH (x_ae8Z : xs_ae90) ys_aeol
   = x_ae8Z : (xs_ae90 `append` ys_aeol)}

parse.hs

import GHC
import GHC.Utils.Outputable (Outputable, SDoc, runSDoc, defaultSDocContext, ppr)
import GHC.Utils.Ppr (Doc)

import Control.Monad.IO.Class
import Data.String (fromString)
import System.FilePath (takeBaseName)
import System.Process (readProcess)
import System.Environment (getArgs)

runSDoc' :: SDoc -> Doc
runSDoc' = (`runSDoc` defaultSDocContext)

ppr' :: Outputable o => o -> Doc
ppr' = runSDoc' . ppr

runpp :: Outputable o => o -> String
runpp = show . runSDoc' . ppr

trace :: String -> Ghc ()
trace = liftIO . putStrLn

getLibPath :: IO FilePath
getLibPath = init <$> readProcess "ghc" ["--print-libdir"] ""

parse :: FilePath -> IO TypecheckedModule
parse hsfile = do
  libpath <- getLibPath
  let mn = takeBaseName hsfile
  parse' (Just libpath) hsfile mn

parse' :: Maybe FilePath -> FilePath -> String -> IO TypecheckedModule
parse' libpath hsfile mn = runGhc libpath $ do
  GHC.initGhcMonad libpath
  df <- GHC.getSessionDynFlags
  GHC.setSessionDynFlags
     df { importPaths = [ "./" ] }
  trace "after init"
  target <- GHC.guessTarget hsfile Nothing Nothing
  trace $ "after guess-target: " ++ show (ppr' target)
  GHC.addTarget target
  trace "after add-target"
  Succeeded <- GHC.load LoadAllTargets
  trace "after load"
  ms <- GHC.getModSummary (ModuleName $ fromString mn)
  trace "after get-mod-summary"
  pm <- GHC.parseModule ms
  trace "after parse-module"
  tm <- GHC.typecheckModule pm
  trace "after typecheck-module"
  pure tm

pprTM :: TypecheckedModule -> String
pprTM tm =
  maybe mempty ppren (tm_renamed_source tm) <>
  "\n\n--------- typechecked ---------\n"   <>
  runpp (tm_typechecked_source tm)
  where
    ppren (src, imp, _, _) =
      "\n\n--------- import      ---------\n"  <>
      runpp imp <>
      "\n\n--------- renamed     ---------\n"  <>
      runpp src

main :: IO ()
main = do
  args <- getArgs
  case args of
    []   -> putStrLn "Usage: parse HS_FILENAME"
    x:_  -> putStrLn . pprTM =<< parse x