{-# LANGUAGE TupleSections #-}
-- | Use "runhaskell Setup.hs test" or "cabal test" to run these tests.
module Main where
import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Utils
import Language.Haskell.GHC.ExactPrint.Types
import GHC.Paths ( libdir )
import qualified DynFlags as GHC
import qualified FastString as GHC
import qualified GHC as GHC
import qualified HscTypes as GHC
import qualified MonadUtils as GHC
import qualified OccName as GHC
import qualified Outputable as GHC
import qualified RdrName as GHC
import qualified StringBuffer as GHC
import qualified Data.Generics as SYB
import qualified GHC.SYB.Utils as SYB
import Data.IORef
import Control.Exception
import Control.Monad
import System.Directory
import System.FilePath
import System.IO
import System.Exit
import qualified Data.Map as Map
import Test.HUnit
import Control.Applicative
import Data.List (partition)
-- ---------------------------------------------------------------------
ghead :: String -> [a] -> a
ghead s [] = error ("Empty list at: " ++ s)
ghead s (x:xs) = x
main :: IO ()
main = do
cnts <- runTestTT tests
putStrLn $ show cnts
if errors cnts > 0 || failures cnts > 0
then exitFailure
else return () -- exitSuccess
-- tests = TestCase (do r <- manipulateAstTest "examples/LetStmt.hs" "Layout.LetStmt"
-- assertBool "test" r )
tests :: Test
tests = TestList
[
mkTestMod "LetStmt.hs" "Layout.LetStmt"
, mkTestMod "LetExpr.hs" "LetExpr"
, mkTestMod "ExprPragmas.hs" "ExprPragmas"
, mkTestMod "ListComprehensions.hs" "Main"
, mkTestMod "MonadComprehensions.hs" "Main"
, mkTestMod "FunDeps.hs" "Main"
, mkTestMod "ImplicitParams.hs" "Main"
, mkTestMod "RecursiveDo.hs" "Main"
, mkTestMod "TypeFamilies.hs" "Main"
, mkTestMod "MultiParamTypeClasses.hs" "Main"
, mkTestMod "DataFamilies.hs" "DataFamilies"
, mkTestMod "Deriving.hs" "Main"
, mkTestMod "Default.hs" "Main"
, mkTestMod "ForeignDecl.hs" "ForeignDecl"
, mkTestMod "Warning.hs" "Warning"
, mkTestMod "Annotations.hs" "Annotations"
, mkTestMod "DocDecls.hs" "DocDecls"
, mkTestModTH "QuasiQuote.hs" "QuasiQuote"
, mkTestMod "Roles.hs" "Roles"
, mkTestMod "Splice.hs" "Splice"
, mkTestMod "ImportsSemi.hs" "ImportsSemi"
, mkTestMod "Stmts.hs" "Stmts"
, mkTestMod "Mixed.hs" "Main"
, mkTestMod "Arrow.hs" "Arrow"
, mkTestMod "PatSynBind.hs" "Main"
, mkTestMod "HsDo.hs" "HsDo"
, mkTestMod "ForAll.hs" "ForAll"
, mkTestMod "PArr.hs" "PArr"
, mkTestMod "ViewPatterns.hs" "Main"
, mkTestMod "BangPatterns.hs" "Main"
, mkTestMod "Associated.hs" "Main"
, mkTestMod "Move1.hs" "Move1"
, mkTestMod "Rules.hs" "Rules"
, mkTestMod "TypeOperators.hs" "Main"
, mkTestMod "NullaryTypeClasses.hs" "Main"
, mkTestMod "FunctionalDeps.hs" "Main"
, mkTestMod "DerivingOC.hs" "Main"
, mkTestMod "GenericDeriving.hs" "Main"
, mkTestMod "OverloadedStrings.hs" "Main"
, mkTestMod "RankNTypes.hs" "Main"
, mkTestMod "Existential.hs" "Main"
, mkTestMod "ScopedTypeVariables.hs" "Main"
, mkTestMod "Arrows.hs" "Main"
, mkTestMod "TH.hs" "Main"
, mkTestMod "StaticPointers.hs" "Main"
, mkTestMod "DataDecl.hs" "Main"
, mkTestMod "Guards.hs" "Main"
, mkTestMod "RebindableSyntax.hs" "Main"
, mkTestMod "RdrNames.hs" "RdrNames"
, mkTestMod "Vect.hs" "Vect"
, mkTestMod "Tuple.hs" "Main"
, mkTestMod "ExtraConstraints1.hs" "ExtraConstraints1"
, mkTestMod "AddAndOr3.hs" "AddAndOr3"
, mkTestMod "Ann01.hs" "Ann01"
, mkTestMod "StrictLet.hs" "Main"
, mkTestMod "Cg008.hs" "Cg008"
, mkTestMod "T2388.hs" "T2388"
, mkTestMod "T3132.hs" "T3132"
, mkTestMod "Stream.hs" "Stream"
, mkTestMod "Trit.hs" "Trit"
, mkTestMod "DataDecl.hs" "Main"
, mkTestMod "Zipper.hs" "Zipper"
, mkTestMod "Sigs.hs" "Sigs"
, mkTestMod "Utils2.hs" "Utils2"
, mkTestMod "EmptyMostlyInst.hs" "EmptyMostlyInst"
, mkTestMod "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis"
, mkTestMod "Dead1.hs" "Dead1"
, mkTestMod "EmptyMostly.hs" "EmptyMostly"
, mkTestMod "FromUtils.hs" "Main"
, mkTestMod "DocDecls.hs" "DocDecls"
, mkTestMod "RecordUpdate.hs" "Main"
-- , mkTestMod "Unicode.hs" "Main"
, mkTestMod "B.hs" "Main"
, mkTestMod "LayoutWhere.hs" "Main"
, mkTestMod "LayoutLet.hs" "Main"
, mkTestMod "LayoutLet2.hs" "LayoutLet2"
, mkTestMod "LayoutLet3.hs" "LayoutLet3"
, mkTestMod "LayoutLet4.hs" "LayoutLet4"
, mkTestMod "LayoutIn1.hs" "LayoutIn1"
, mkTestMod "LayoutIn3.hs" "LayoutIn3"
, mkTestMod "LayoutIn3a.hs" "LayoutIn3a"
, mkTestMod "LayoutIn3b.hs" "LayoutIn3b"
, mkTestMod "LayoutIn4.hs" "LayoutIn4"
, mkTestMod "Deprecation.hs" "Deprecation"
, mkTestMod "Infix.hs" "Main"
, mkTestMod "BCase.hs" "Main"
, mkTestMod "AltsSemis.hs" "Main"
, mkTestMod "LetExprSemi.hs" "LetExprSemi"
, mkTestMod "WhereIn4.hs" "WhereIn4"
, mkTestMod "LocToName.hs" "LocToName"
, mkTestMod "IfThenElse1.hs" "Main"
, mkTestMod "IfThenElse2.hs" "Main"
, mkTestMod "IfThenElse3.hs" "Main"
, mkTestModChange changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2"
, mkTestModChange changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3"
, mkTestModChange changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4"
, mkTestModChange changeRename1 "Rename1.hs" "Main"
, mkTestModChange changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1"
, mkTestModChange changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3"
, mkTestModChange changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a"
, mkTestModChange changeLayoutIn3 "LayoutIn3b.hs" "LayoutIn3b"
, mkTestModChange changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4"
, mkTestModChange changeLocToName "LocToName.hs" "LocToName"
]
mkTestMain :: FilePath -> Test
mkTestMain fileName = TestCase (do r <- manipulateAstTest fileName "Main"
assertBool fileName r )
mkTestMod :: FilePath -> String -> Test
mkTestMod fileName modName
= TestCase (do r <- manipulateAstTest fileName modName
assertBool fileName r )
mkTestModChange :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> Test
mkTestModChange change fileName modName
= TestCase (do r <- manipulateAstTestWithMod change fileName modName
assertBool fileName r )
mkTestModTH :: FilePath -> String -> Test
mkTestModTH fileName modName
= TestCase (do r <- manipulateAstTestTH fileName modName
assertBool fileName r )
-- ---------------------------------------------------------------------
formatTT :: ([([Char], Bool)], [([Char], Bool)]) -> IO ()
formatTT (ts, fs) = do
when (not . null $ tail ts) (do
putStrLn "Pass"
mapM_ (putStrLn . fst) (tail ts)
)
when (not . null $ fs) (do
putStrLn "Fail"
mapM_ (putStrLn . fst) fs)
tt :: IO ()
tt = formatTT =<< partition snd <$> sequence [ return ("", True)
{-
, manipulateAstTestWFname "LetExpr.hs" "LetExpr"
-}
-- , manipulateAstTestWFname "ExprPragmas.hs" "ExprPragmas"
{-
, manipulateAstTestWFname "ListComprehensions.hs" "Main"
, manipulateAstTestWFname "MonadComprehensions.hs" "Main"
, manipulateAstTestWFname "FunDeps.hs" "Main"
, manipulateAstTestWFname "RecursiveDo.hs" "Main"
, manipulateAstTestWFname "TypeFamilies.hs" "Main"
, manipulateAstTestWFname "MultiParamTypeClasses.hs" "Main"
, manipulateAstTestWFname "DataFamilies.hs" "DataFamilies"
, manipulateAstTestWFname "Deriving.hs" "Main"
, manipulateAstTestWFname "Default.hs" "Main"
, manipulateAstTestWFname "ForeignDecl.hs" "ForeignDecl"
, manipulateAstTestWFname "Warning.hs" "Warning"
-}
-- , manipulateAstTestWFname "Annotations.hs" "Annotations"
{-
, manipulateAstTestWFnameTH "QuasiQuote.hs" "QuasiQuote"
, manipulateAstTestWFname "Roles.hs" "Roles"
, manipulateAstTestWFname "Splice.hs" "Splice"
, manipulateAstTestWFname "ImportsSemi.hs" "ImportsSemi"
, manipulateAstTestWFname "Stmts.hs" "Stmts"
-}
-- , manipulateAstTestWFname "Mixed.hs" "Main"
{-
, manipulateAstTestWFname "Arrow.hs" "Arrow"
, manipulateAstTestWFname "PatSynBind.hs" "Main"
-}
-- , manipulateAstTestWFname "HsDo.hs" "HsDo"
{-
, manipulateAstTestWFname "ForAll.hs" "ForAll"
, manipulateAstTestWFname "BangPatterns.hs" "Main"
, manipulateAstTestWFname "Associated.hs" "Main"
-}
-- , manipulateAstTestWFname "Move1.hs" "Move1"
{-
, manipulateAstTestWFname "TypeOperators.hs" "Main"
, manipulateAstTestWFname "NullaryTypeClasses.hs" "Main"
, manipulateAstTestWFname "FunctionalDeps.hs" "Main"
, manipulateAstTestWFname "DerivingOC.hs" "Main"
, manipulateAstTestWFname "GenericDeriving.hs" "Main"
, manipulateAstTestWFname "OverloadedStrings.hs" "Main"
, manipulateAstTestWFname "RankNTypes.hs" "Main"
-}
-- , manipulateAstTestWFname "Existential.hs" "Main"
{-
, manipulateAstTestWFname "ScopedTypeVariables.hs" "Main"
, manipulateAstTestWFname "Arrows.hs" "Main"
, manipulateAstTestWFname "TH.hs" "Main"
, manipulateAstTestWFname "StaticPointers.hs" "Main"
, manipulateAstTestWFname "DataDecl.hs" "Main"
, manipulateAstTestWFname "Guards.hs" "Main"
, manipulateAstTestWFname "RdrNames.hs" "RdrNames"
-}
-- , manipulateAstTestWFname "Vect.hs" "Vect"
{-
, manipulateAstTestWFname "Tuple.hs" "Main"
, manipulateAstTestWFname "ExtraConstraints1.hs" "ExtraConstraints1"
, manipulateAstTestWFname "AddAndOr3.hs" "AddAndOr3"
-}
-- , manipulateAstTestWFname "Ann01.hs" "Ann01"
-- , manipulateAstTestWFname "StrictLet.hs" "Main"
{-
, manipulateAstTestWFname "Cg008.hs" "Cg008"
, manipulateAstTestWFname "T2388.hs" "T2388"
, manipulateAstTestWFname "T3132.hs" "T3132"
, manipulateAstTestWFname "Stream.hs" "Stream"
, manipulateAstTestWFname "Trit.hs" "Trit"
, manipulateAstTestWFname "DataDecl.hs" "Main"
, manipulateAstTestWFname "Zipper.hs" "Zipper"
-}
-- , manipulateAstTestWFname "Sigs.hs" "Sigs"
-- , manipulateAstTestWFname "Utils2.hs" "Utils2"
{-
, manipulateAstTestWFname "EmptyMostlyInst.hs" "EmptyMostlyInst"
, manipulateAstTestWFname "EmptyMostlyNoSemis.hs" "EmptyMostlyNoSemis"
, manipulateAstTestWFname "EmptyMostly.hs" "EmptyMostly"
, manipulateAstTestWFname "FromUtils.hs" "Main"
, manipulateAstTestWFname "DocDecls.hs" "DocDecls"
, manipulateAstTestWFname "RecordUpdate.hs" "Main"
-- manipulateAstTestWFname "Unicode.hs" "Main"
, manipulateAstTestWFname "B.hs" "Main"
, manipulateAstTestWFname "LayoutWhere.hs" "Main"
-}
-- , manipulateAstTestWFname "Deprecation.hs" "Deprecation"
{-
, manipulateAstTestWFname "Infix.hs" "Main"
, manipulateAstTestWFname "BCase.hs" "Main"
, manipulateAstTestWFname "LetExprSemi.hs" "LetExprSemi"
, manipulateAstTestWFname "LetExpr2.hs" "Main"
, manipulateAstTestWFname "LetStmt.hs" "Layout.LetStmt"
, manipulateAstTestWFname "LayoutLet.hs" "Main"
-}
-- , manipulateAstTestWFname "ImplicitParams.hs" "Main"
{-
, manipulateAstTestWFname "RebindableSyntax.hs" "Main"
, manipulateAstTestWithMod changeLayoutLet3 "LayoutLet4.hs" "LayoutLet4"
, manipulateAstTestWithMod changeLayoutLet5 "LayoutLet5.hs" "LayoutLet5"
, manipulateAstTestWFname "EmptyMostly2.hs" "EmptyMostly2"
, manipulateAstTestWFname "WhereIn4.hs" "WhereIn4"
, manipulateAstTestWFname "AltsSemis.hs" "Main"
, manipulateAstTestWFname "PArr.hs" "PArr"
-}
-- , manipulateAstTestWFname "Dead1.hs" "Dead1"
{-
, manipulateAstTestWFname "DocDecls.hs" "DocDecls"
, manipulateAstTestWFname "ViewPatterns.hs" "Main"
, manipulateAstTestWFname "FooExpected.hs" "Main"
, manipulateAstTestWithMod changeLayoutLet2 "LayoutLet2.hs" "LayoutLet2"
, manipulateAstTestWFname "LayoutIn1.hs" "LayoutIn1"
, manipulateAstTestWithMod changeLayoutIn1 "LayoutIn1.hs" "LayoutIn1"
, manipulateAstTestWFname "LocToName.hs" "LocToName"
, manipulateAstTestWithMod changeLayoutIn4 "LayoutIn4.hs" "LayoutIn4"
, manipulateAstTestWithMod changeLocToName "LocToName.hs" "LocToName"
, manipulateAstTestWithMod changeLayoutLet3 "LayoutLet3.hs" "LayoutLet3"
, manipulateAstTestWithMod changeRename1 "Rename1.hs" "Main"
, manipulateAstTestWFname "Rename1.hs" "Main"
-}
-- , manipulateAstTestWFname "Rules.hs" "Rules"
-- , manipulateAstTestWFname "LayoutLet2.hs" "LayoutLet2"
-- , manipulateAstTestWFname "LayoutIn3.hs" "LayoutIn3"
-- , manipulateAstTestWFname "LayoutIn3a.hs" "LayoutIn3a"
, manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3a.hs" "LayoutIn3a"
-- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3b.hs" "LayoutIn3b"
-- , manipulateAstTestWFnameMod changeLayoutIn3 "LayoutIn3.hs" "LayoutIn3"
-- , manipulateAstTestWFname "LayoutLet2.hs" "LayoutLet2"
{-
, manipulateAstTestWFname "ParensAroundContext.hs" "ParensAroundContext"
, manipulateAstTestWithMod changeWhereIn4 "WhereIn4.hs" "WhereIn4"
, manipulateAstTestWFname "Cpp.hs" "Main"
, manipulateAstTestWFname "Lhs.lhs" "Main"
, manipulateAstTestWFname "Foo.hs" "Main"
-}
]
-- ---------------------------------------------------------------------
changeLayoutLet2 :: GHC.ParsedSource -> GHC.ParsedSource
changeLayoutLet2 parsed = rename "xxxlonger" [((7,5),(7,8)),((8,24),(8,27))] parsed
changeLocToName :: GHC.ParsedSource -> GHC.ParsedSource
changeLocToName parsed = rename "LocToName.newPoint" [((20,1),(20,11)),((20,28),(20,38)),((24,1),(24,11))] parsed
changeLayoutIn3 :: GHC.ParsedSource -> GHC.ParsedSource
changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed
-- changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38))] parsed
changeLayoutIn4 :: GHC.ParsedSource -> GHC.ParsedSource
changeLayoutIn4 parsed = rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed
changeLayoutIn1 :: GHC.ParsedSource -> GHC.ParsedSource
changeLayoutIn1 parsed = rename "square" [((7,17),(7,19)),((7,24),(7,26))] parsed
changeRename1 :: GHC.ParsedSource -> GHC.ParsedSource
changeRename1 parsed = rename "bar2" [((3,1),(3,4))] parsed
changeLayoutLet3 :: GHC.ParsedSource -> GHC.ParsedSource
changeLayoutLet3 parsed = rename "xxxlonger" [((7,5),(7,8)),((9,14),(9,17))] parsed
changeLayoutLet5 :: GHC.ParsedSource -> GHC.ParsedSource
changeLayoutLet5 parsed = rename "x" [((7,5),(7,8)),((9,14),(9,17))] parsed
rename :: (SYB.Data a) => String -> [Span] -> a -> a
rename newNameStr spans a
= SYB.everywhere ( SYB.mkT replaceRdr
`SYB.extT` replaceHsVar
`SYB.extT` replacePat
) a
where
newName = GHC.mkRdrUnqual (GHC.mkVarOcc newNameStr)
cond :: GHC.SrcSpan -> Bool
cond ln = any (\ss -> ss2span ln == ss) spans
replaceRdr :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName
replaceRdr (GHC.L ln _)
| cond ln = GHC.L ln newName
replaceRdr x = x
replaceHsVar :: GHC.LHsExpr GHC.RdrName -> GHC.LHsExpr GHC.RdrName
replaceHsVar (GHC.L ln (GHC.HsVar _))
| cond ln = GHC.L ln (GHC.HsVar newName)
replaceHsVar x = x
replacePat (GHC.L ln (GHC.VarPat _))
| cond ln = GHC.L ln (GHC.VarPat newName)
replacePat x = x
-- ---------------------------------------------------------------------
changeWhereIn4 :: GHC.ParsedSource -> GHC.ParsedSource
changeWhereIn4 parsed
= SYB.everywhere (SYB.mkT replace) parsed
where
replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName
replace (GHC.L ln _n)
| ss2span ln == ((12,16),(12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2"))
replace x = x
-- ---------------------------------------------------------------------
-- | Where all the tests are to be found
examplesDir :: FilePath
examplesDir = "tests" </> "examples"
examplesDir2 :: FilePath
examplesDir2 = "examples"
manipulateAstTestWithMod :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> IO Bool
manipulateAstTestWithMod change file modname = manipulateAstTest' (Just change) False file modname
manipulateAstTestWFnameMod :: (GHC.ParsedSource -> GHC.ParsedSource) -> FilePath -> String -> IO (FilePath,Bool)
manipulateAstTestWFnameMod change fileName modname
= do r <- manipulateAstTestWithMod change fileName modname
return (fileName,r)
manipulateAstTest :: FilePath -> String -> IO Bool
manipulateAstTest file modname = manipulateAstTest' Nothing False file modname
manipulateAstTestWFname :: FilePath -> String -> IO (FilePath, Bool)
manipulateAstTestWFname file modname = (file,) <$> manipulateAstTest file modname
manipulateAstTestTH :: FilePath -> String -> IO Bool
manipulateAstTestTH file modname = manipulateAstTest' Nothing True file modname
manipulateAstTest' :: Maybe (GHC.ParsedSource -> GHC.ParsedSource) -> Bool -> FilePath -> String -> IO Bool
manipulateAstTest' mchange useTH file' modname = do
let testpath = "./tests/examples/"
file = testpath </> file'
out = file <.> "out"
expected = file <.> "expected"
contents <- case mchange of
Nothing -> readUTF8File file
Just _ -> readUTF8File expected
(ghcAnns,t) <- parsedFileGhc file modname useTH
let
parsed = GHC.pm_parsed_source $ GHC.tm_parsed_module t
parsedAST = SYB.showData SYB.Parser 0 parsed
-- parsedAST = showGhc parsed
-- `debug` ("getAnn:=" ++ (show (getAnnotationValue (snd ann) (GHC.getLoc parsed) :: Maybe AnnHsModule)))
-- try to pretty-print; summarize the test result
ann = relativiseApiAnns parsed ghcAnns
`debug` ("ghcAnns:" ++ showGhc ghcAnns)
parsed' = case mchange of
Nothing -> parsed
Just change -> change parsed
printed = exactPrintWithAnns parsed' ann -- `debug` ("ann=" ++ (show $ map (\(s,a) -> (ss2span s, a)) $ Map.toList ann))
result =
if printed == contents
then "Match\n"
else printed ++ "\n==============\n"
++ "lengths:" ++ show (length printed,length contents) ++ "\n"
++ parsedAST
++ "\n========================\n"
++ showAnnData ann 0 parsed'
writeFile out $ result
-- putStrLn $ "Test:parsed=" ++ parsedAST
-- putStrLn $ "Test:ann :" ++ showGhc ann
-- putStrLn $ "Test:ghcAnns :" ++ showGhc ghcAnns
-- putStrLn $ "Test:showdata:" ++ showAnnData ann 0 parsed
-- putStrLn $ "Test:showdata:parsed'" ++ SYB.showData SYB.Parser 0 parsed'
-- putStrLn $ "Test:showdata:parsed'" ++ showAnnData ann 0 parsed'
return ("Match\n" == result)
-- ---------------------------------------------------------------------
-- |Result of parsing a Haskell source file. It is simply the
-- TypeCheckedModule produced by GHC.
type ParseResult = GHC.TypecheckedModule
parsedFileGhc :: String -> String -> Bool -> IO (GHC.ApiAnns,ParseResult)
parsedFileGhc fileName modname useTH = do
-- putStrLn $ "parsedFileGhc:" ++ show fileName
GHC.defaultErrorHandler GHC.defaultFatalMessager GHC.defaultFlushOut $ do
GHC.runGhc (Just libdir) $ do
dflags <- GHC.getSessionDynFlags
let dflags'' = dflags { GHC.importPaths = ["./tests/examples/","../tests/examples/",
"./src/","../src/"] }
tgt = if useTH then GHC.HscInterpreted
else GHC.HscNothing -- allows FFI
dflags''' = dflags'' { GHC.hscTarget = tgt,
GHC.ghcLink = GHC.LinkInMemory
, GHC.packageFlags = [GHC.ExposePackage (GHC.PackageArg "ghc") (GHC.ModRenaming False [])]
}
dflags4 = if False -- useHaddock
then GHC.gopt_set (GHC.gopt_set dflags''' GHC.Opt_Haddock)
GHC.Opt_KeepRawTokenStream
else GHC.gopt_set dflags'''
GHC.Opt_KeepRawTokenStream
-- else GHC.gopt_set (GHC.gopt_unset dflags''' GHC.Opt_Haddock)
-- GHC.Opt_KeepRawTokenStream
(dflags5,_args,_warns) <- GHC.parseDynamicFlagsCmdLine dflags4 [GHC.noLoc "-package ghc"]
-- GHC.liftIO $ putStrLn $ "dflags set:(args,warns)" ++ show (map GHC.unLoc args,map GHC.unLoc warns)
void $ GHC.setSessionDynFlags dflags5
-- GHC.liftIO $ putStrLn $ "dflags set"
target <- GHC.guessTarget fileName Nothing
GHC.setTargets [target]
-- GHC.liftIO $ putStrLn $ "target set:" ++ showGhc (GHC.targetId target)
void $ GHC.load GHC.LoadAllTargets -- Loads and compiles, much as calling make
-- GHC.liftIO $ putStrLn $ "targets loaded"
-- g <- GHC.getModuleGraph
-- let showStuff ms = show (GHC.moduleNameString $ GHC.moduleName $ GHC.ms_mod ms,GHC.ms_location ms)
-- GHC.liftIO $ putStrLn $ "module graph:" ++ (intercalate "," (map showStuff g))
modSum <- GHC.getModSummary $ GHC.mkModuleName modname
-- GHC.liftIO $ putStrLn $ "got modSum"
-- let modSum = head g
{-
(sourceFile, source, flags) <- getModuleSourceAndFlags (GHC.ms_mod modSum)
strSrcBuf <- getPreprocessedSrc sourceFile
GHC.liftIO $ putStrLn $ "preprocessedSrc====\n" ++ strSrcBuf ++ "\n================\n"
-}
p <- GHC.parseModule modSum
-- GHC.liftIO $ putStrLn $ "got parsedModule"
t <- GHC.typecheckModule p
-- GHC.liftIO $ putStrLn $ "typechecked"
-- toks <- GHC.getRichTokenStream (GHC.ms_mod modSum)
-- GHC.liftIO $ putStrLn $ "toks" ++ show toks
let anns = GHC.pm_annotations p
-- GHC.liftIO $ putStrLn $ "anns"
return (anns,t)
readUTF8File :: FilePath -> IO String
readUTF8File fp = openFile fp ReadMode >>= \h -> do
hSetEncoding h utf8
hGetContents h
-- ---------------------------------------------------------------------
pwd :: IO FilePath
pwd = getCurrentDirectory
cd :: FilePath -> IO ()
cd = setCurrentDirectory
-- ---------------------------------------------------------------------
mkSs :: (Int,Int) -> (Int,Int) -> GHC.SrcSpan
mkSs (sr,sc) (er,ec)
= GHC.mkSrcSpan (GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") sr sc)
(GHC.mkSrcLoc (GHC.mkFastString "examples/PatBind.hs") er ec)
-- ---------------------------------------------------------------------
-- | The preprocessed files are placed in a temporary directory, with
-- a temporary name, and extension .hscpp. Each of these files has
-- three lines at the top identifying the original origin of the
-- files, which is ignored by the later stages of compilation except
-- to contextualise error messages.
getPreprocessedSrc ::
-- GHC.GhcMonad m => FilePath -> m GHC.StringBuffer
GHC.GhcMonad m => FilePath -> m String
getPreprocessedSrc srcFile = do
df <- GHC.getSessionDynFlags
d <- GHC.liftIO $ getTempDir df
fileList <- GHC.liftIO $ getDirectoryContents d
let suffix = "hscpp"
let cppFiles = filter (\f -> getSuffix f == suffix) fileList
origNames <- GHC.liftIO $ mapM getOriginalFile $ map (\f -> d </> f) cppFiles
let tmpFile = ghead "getPreprocessedSrc" $ filter (\(o,_) -> o == srcFile) origNames
-- buf <- GHC.liftIO $ GHC.hGetStringBuffer $ snd tmpFile
-- return buf
GHC.liftIO $ readUTF8File (snd tmpFile)
-- ---------------------------------------------------------------------
getSuffix :: FilePath -> String
getSuffix fname = reverse $ fst $ break (== '.') $ reverse fname
-- | A GHC preprocessed file has the following comments at the top
-- @
-- # 1 "./test/testdata/BCpp.hs"
-- # 1 "<command-line>"
-- # 1 "./test/testdata/BCpp.hs"
-- @
-- This function reads the first line of the file and returns the
-- string in it.
-- NOTE: no error checking, will blow up if it fails
getOriginalFile :: FilePath -> IO (FilePath,FilePath)
getOriginalFile fname = do
fcontents <- readFile fname
let firstLine = ghead "getOriginalFile" $ lines fcontents
let (_,originalFname) = break (== '"') firstLine
return $ (tail $ init $ originalFname,fname)
-- ---------------------------------------------------------------------
-- Copied from the GHC source, since not exported
getModuleSourceAndFlags :: GHC.GhcMonad m => GHC.Module -> m (String, GHC.StringBuffer, GHC.DynFlags)
getModuleSourceAndFlags modu = do
m <- GHC.getModSummary (GHC.moduleName modu)
case GHC.ml_hs_file $ GHC.ms_location m of
Nothing ->
do dflags <- GHC.getDynFlags
GHC.liftIO $ throwIO $ GHC.mkApiErr dflags (GHC.text "No source available for module " GHC.<+> GHC.ppr modu)
Just sourceFile -> do
source <- GHC.liftIO $ GHC.hGetStringBuffer sourceFile
return (sourceFile, source, GHC.ms_hspp_opts m)
-- return our temporary directory within tmp_dir, creating one if we
-- don't have one yet
getTempDir :: GHC.DynFlags -> IO FilePath
getTempDir dflags
= do let ref = GHC.dirsToClean dflags
tmp_dir = GHC.tmpDir dflags
mapping <- readIORef ref
case Map.lookup tmp_dir mapping of
Nothing -> error "should already be a tmpDir"
Just d -> return d