NoAnnotations.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Test.NoAnnotations where

-- import Control.Monad.State
import Data.Algorithm.Diff
import Data.Algorithm.DiffOutput
import Data.Data (Data, toConstr, showConstr, cast)
import Data.Generics (extQ, ext1Q, ext2Q, gmapQ)
import Data.List
-- import Data.Ord (comparing)
import qualified Data.ByteString as B

import Language.Haskell.GHC.ExactPrint
import Language.Haskell.GHC.ExactPrint.Parsers
import Language.Haskell.GHC.ExactPrint.Types
import Language.Haskell.GHC.ExactPrint.Utils

#if __GLASGOW_HASKELL__ >= 900
import qualified Control.Monad.IO.Class as GHC
import qualified GHC            as GHC hiding (parseModule)
import qualified GHC.Data.Bag          as GHC
import qualified GHC.Data.FastString   as GHC
-- import qualified GHC.Data.StringBuffer as GHC
-- import qualified GHC.Driver.Phases     as GHC
-- import qualified GHC.Driver.Pipeline   as GHC
-- import qualified GHC.Driver.Session    as GHC
-- import qualified GHC.Driver.Types      as GHC
-- import qualified GHC.Fingerprint.Type  as GHC
-- import qualified GHC.Utils.Fingerprint as GHC
-- import qualified GHC.Parser.Lexer      as GHC
-- import qualified GHC.Settings          as GHC
import qualified GHC.Types.SrcLoc      as GHC
-- import qualified GHC.Utils.Error       as GHC
import qualified GHC.Utils.Outputable  as GHC
import qualified GHC.Types.Name.Occurrence as OccName (occNameString)
import qualified GHC.Types.Var         as GHC
import qualified GHC.Types.Name.Set    as GHC
#else
import qualified ApiAnnotation as GHC
import qualified Bag           as GHC
import qualified FastString    as GHC
import qualified GHC           as GHC hiding (parseModule)
import qualified MonadUtils    as GHC
import qualified NameSet       as GHC
import qualified Outputable    as GHC
import qualified SrcLoc        as GHC
import qualified Var           as GHC

import qualified OccName(occNameString)
#endif




import System.Directory
import System.FilePath

#if __GLASGOW_HASKELL__ < 900
import qualified Data.Map as Map
#endif

import Test.Common

import Test.HUnit

{-# ANN module "HLint: ignore Eta reduce" #-}

-- ---------------------------------------------------------------------

noAnnotationTests :: Test
noAnnotationTests = TestLabel "no annotation tests" $ TestList
  [
    TestLabel "no annotations"
       (TestList noAnnTests)
  ]

noAnnTests :: [Test]
noAnnTests = [

        ]

-- ---------------------------------------------------------------------

mkPrettyRoundtrip :: FilePath -> FilePath -> Test
mkPrettyRoundtrip dir fp = mkParsingTest prettyRoundtripTest dir fp

prettyRoundtripTest :: FilePath -> IO Report
prettyRoundtripTest origFile = do
      res <- parseModuleApiAnnsWithCpp defaultCppOptions origFile
      case res of
#if __GLASGOW_HASKELL__ > 808
        Left m -> return . Left $ ParseFailure (showErrorMessages m)
#else
        Left (_ss, m) -> return . Left $ ParseFailure m
#endif
        Right (apianns, injectedComments, _dflags, parsed)  -> do
          res2 <- GHC.liftIO (runPrettyRoundTrip origFile apianns parsed injectedComments)
          case res2 of
#if __GLASGOW_HASKELL__ > 808
            Left m -> return . Left $ ParseFailure (showErrorMessages m)
#else
            Left (_ss, m) -> return . Left $ ParseFailure m
#endif
            Right (_anns', parsed') -> do
              let
                originalStructure  = astStructure parsed []
                roundtripStructure = astStructure parsed' []
                (status,debugTxt') = if roundtripStructure == originalStructure
                  then (Success, "ok")
                  else (RoundTripFailure,diffText originalStructure roundtripStructure
                         ++ sep ++ originalStructure ++ sep ++ roundtripStructure)
                cppStatus = Nothing
                inconsistent = Nothing
                !annsOrig = relativiseApiAnnsWithComments injectedComments parsed apianns
                debugTxt = intercalate sep [ debugTxt'
                                           , originalStructure
                                           , roundtripStructure
                                           , showAnnData annsOrig 0 parsed
                                           ]
                sep = "\n=====================================\n"
              return $ Right Report {debugTxt,status,cppStatus,inconsistent}

-- ---------------------------------------------------------------------

runPrettyRoundTrip :: FilePath -> GHC.ApiAnns -> GHC.ParsedSource
                   -> [Comment]
                   -> IO (ParseResult GHC.ParsedSource)
runPrettyRoundTrip origFile !anns !parsedOrig _cs = do
  let !newAnns = addAnnotationsForPretty [] parsedOrig mempty
#if __GLASGOW_HASKELL__ >= 900
  let comments = map tokComment $ GHC.sortRealLocated (GHC.apiAnnRogueComments anns)
#else
  let comments = case Map.lookup GHC.noSrcSpan (snd anns) of
        Nothing -> []
        Just cl -> map tokComment $ GHC.sortLocated cl
#endif
  let pragmas = filter (\(Comment c _ _) -> isPrefixOf "{-#" c ) comments
  let pragmaStr = intercalate "\n" $ map commentContents pragmas

  let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig newAnns
  -- let !printed = pragmaStr ++ "\n" ++ (showSDoc_ $ GHC.ppr parsedOrig)

  parseString origFile printed newAnns parsedOrig


parseString :: FilePath -> String -> Anns -> GHC.ParsedSource
            -> IO (ParseResult GHC.ParsedSource)
parseString origFile src newAnns origParsed = do
  tmpDir <- getTemporaryDirectory
  let workDir = tmpDir </> "ghc-exactprint" </> "noannotations"
  -- putStrLn $ "workDir=" ++ workDir
  createDirectoryIfMissing True workDir
  let fileName = workDir </> takeFileName origFile
  writeFile (workDir </> takeFileName origFile <.> ".anns")
      (showAnnData  newAnns 0 origParsed)
  writeFile fileName src
  parseModule fileName

-- ---------------------------------------------------------------------

diffText :: String -> String -> String
diffText f1 f2 = diff
  where
    d = getGroupedDiff (lines f1) (lines f2)
    diff = ppDiff d

-- ---------------------------------------------------------------------

-- |Convert an AST with comments into a string representing the structure only
-- (i.e. ignoring locations), to be used for comparisons between the original
-- AST and the one after pretty-print roundtripping.
-- Based on @showAnnData@
astStructure :: GHC.ParsedSource -> [Comment] -> String
astStructure parsed _cs = r
  where
    r = showAstData 0 parsed



-- | Show a GHC AST with interleaved Annotation information.
showAstData :: Data a => Int -> a -> String
showAstData n =
  generic -- `ext1Q` located
          `ext1Q` list
          `extQ` string `extQ` fastString `extQ` srcSpan
          `extQ` bytestring
          `extQ` name `extQ` occName `extQ` moduleName `extQ` var `extQ` dataCon
          `extQ` overLit
          `extQ` bagName `extQ` bagRdrName `extQ` bagVar `extQ` nameSet
#if __GLASGOW_HASKELL__ >= 900
          `extQ` layoutInfo
#endif
          `extQ` fixity
          `ext2Q` located
  where generic :: Data a => a -> String
        generic t = indent n ++ "(" ++ showConstr (toConstr t)
                 ++ space (unwords (gmapQ (showAstData (n+1)) t)) ++ ")"
        space "" = ""
        space s  = ' ':s
        indent i = "\n" ++ replicate i ' '
        string     = show :: String -> String
        fastString = ("{FastString: "++) . (++"}") . show :: GHC.FastString -> String
        bytestring = show :: B.ByteString -> String
        list l     = indent n ++ "["
                              ++ intercalate "," (map (showAstData (n+1)) l) ++ "]"

        name       = ("{Name: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Name -> String
        occName    = ("{OccName: "++) . (++"}") .  OccName.occNameString
        moduleName = ("{ModuleName: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.ModuleName -> String

        srcSpan :: GHC.SrcSpan -> String
        srcSpan _ss = "{ "++ "ss" ++"}"

        var        = ("{Var: "++) . (++"}") . showSDocDebug_ . GHC.ppr :: GHC.Var -> String
        dataCon    = ("{DataCon: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.DataCon -> String

        overLit :: GHC.HsOverLit GhcPs -> String
        overLit    = ("{HsOverLit:"++) . (++"}") . showSDoc_ . GHC.ppr

        bagRdrName:: GHC.Bag (GHC.Located (GHC.HsBind GhcPs)) -> String
        bagRdrName = ("{Bag(Located (HsBind RdrName)): "++) . (++"}") . list . GHC.bagToList
        bagName   :: GHC.Bag (GHC.Located (GHC.HsBind GhcRn)) -> String
        bagName    = ("{Bag(Located (HsBind Name)): "++) . (++"}") . list . GHC.bagToList
        bagVar    :: GHC.Bag (GHC.Located (GHC.HsBind GhcTc)) -> String
        bagVar     = ("{Bag(Located (HsBind Var)): "++) . (++"}") . list . GHC.bagToList

#if __GLASGOW_HASKELL__ > 800
        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElemsStable
#else
        nameSet = ("{NameSet: "++) . (++"}") . list . GHC.nameSetElems
#endif

        fixity = ("{Fixity: "++) . (++"}") . showSDoc_ . GHC.ppr :: GHC.Fixity -> String

#if __GLASGOW_HASKELL__ >= 900
        layoutInfo = const "{LayoutInfo: blanked }" :: GHC.LayoutInfo -> String
#endif

        located :: (Data b,Data loc) => GHC.GenLocated loc b -> String
        located (GHC.L ss a) =
          indent n ++ "("
            ++ case cast ss of
                    Just (s :: GHC.SrcSpan) ->
                      srcSpan s
                    Nothing -> "nnnnnnnn"
                  ++ showAstData (n+1) a
                  ++ ")"

-- ---------------------------------------------------------------------