Some roundtrip work.

Turns out using GHC_CPP all the time sorts out LINE pragmas

Author: alanz

roundtrip-config/knownfailures.txt

@@ -2476,6 +2476,7 @@ instance ExactPrint (HsLocalBinds GhcPs) where
         when (not $ isEmptyValBinds valbinds) $ setExtraDP (Just anc)
       _ -> return ()
 
+    debugM $ "exact HsValBinds: starting"
     (an1, valbinds') <- markAnnList an0 $ markAnnotatedWithLayout valbinds
     debugM $ "exact HsValBinds: an1=" ++ showAst an1
     medr <- getExtraDPReturn

src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs

@@ -292,7 +292,8 @@ parseModuleEpAnnsWithGhcCppInternal
 parseModuleEpAnnsWithGhcCppInternal cppOptions dflags file = do
   let useCpp = GHC.xopt LangExt.Cpp dflags
   (fileContents, injectedComments, dflags') <-
-    if useCpp
+    -- if useCpp
+    if True
       then do
         txt <- GHC.liftIO $ readFileGhc file
         let (contents1,lp) = (txt, [])
@@ -430,7 +431,8 @@ initDynFlags file = do
   hsc <- GHC.getSession
   let logger = GHC.hsc_logger hsc
   let unit_env = GHC.hsc_unit_env hsc
-  (_, src_opts)   <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 unit_env parser_opts0 (GHC.supportedLanguagePragmas dflags0) file
+  let supported_pragmas = "JavaScriptFFI" : GHC.supportedLanguagePragmas dflags0
+  (_, src_opts)   <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 unit_env parser_opts0 supported_pragmas file
   (dflags1, _, _) <- GHC.parseDynamicFilePragma logger dflags0 src_opts
   -- Turn this on last to avoid T10942
   let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream

src/Language/Haskell/GHC/ExactPrint/Parsers.hs

@@ -44,7 +44,8 @@ testDirs :: [FilePath]
 testDirs =
   case ghcVersion of
     GHC910 -> ["pre-ghc910", "ghc910"]
-    GHC912 -> ["pre-ghc910", "ghc910", "ghc912"]
+    -- GHC912 -> ["pre-ghc910", "ghc910", "ghc912"]
+    GHC912 -> ["ghc-cpp"]
     -- GHC912  -> ["ghc912"]
     -- GHC912  -> ["ghc912-copied"]
     -- GHC912  -> ["ghc912",  "ghc912-copied"]
@@ -141,14 +142,14 @@ mkTests = do
   return $ TestList [
                       internalTests,
                       roundTripTests
-                   ,
-                     (transformTests libdir)
-                   ,
-                      (failingTests libdir)
-                   ,
-                     roundTripBalanceCommentsTests
-                   ,
-                     roundTripMakeDeltaTests
+                   -- ,
+                   --   (transformTests libdir)
+                   -- ,
+                   --    (failingTests libdir)
+                   -- ,
+                   --   roundTripBalanceCommentsTests
+                   -- ,
+                   --   roundTripMakeDeltaTests
                     ]
 
 failingTests :: LibDir -> Test
@@ -230,8 +231,10 @@ tt' = do
     -- mkParserTest libdir "failing" "CppComment.hs"
     -- mkParserTest libdir "ghc-cpp" "Scan.hs"
     -- mkParserTest libdir "ghc-cpp" "Test1.hs"
-    -- mkParserTest libdir "ghc-cpp" "WithoutSomeFixpoints.hs"
-    mkParserTest libdir "ghc-cpp" "HelperMain.hs"
+    mkParserTest libdir "ghc-cpp" "WithoutSomeFixpoints.hs"
+
+    -- mkParserTest libdir "ghc-cpp" "Promise.hs"
+    -- mkParserTest libdir "ghc-cpp" "Set1.hs"
 
     ]
 

tests/Test.hs

@@ -37,6 +37,9 @@ import GHC.Internal.Data.Version (Version, makeVersion)
 hackageWorkDir :: FilePath
 hackageWorkDir = "./hackage-roundtrip-work"
 
+hackageWorkDirRest :: FilePath
+hackageWorkDirRest = "./hackage-roundtrip-work.rest"
+
 -- ---------------------------------------------------------------------
 
 -- | Round trip working dir, can be deleted
@@ -147,8 +150,9 @@ readFileGhc file = do
 packages :: IO [(String, Version)]
 packages = do
   packageDirsFull <- drop 2 <$> getDirectoryContents hackageWorkDir
+  packageDirsFullRest <- drop 2 <$> getDirectoryContents hackageWorkDirRest
   let cond c = c == '-'
-  let packageDirs = map (\p -> break cond $ reverse p) packageDirsFull
+  let packageDirs = map (\p -> break cond $ reverse p) (packageDirsFull ++ packageDirsFullRest)
   let pp = map (\(v,n) -> (dashToLower $ reverse (drop 1 n), makeVersion $ parseVersion $ reverse v)) packageDirs
   return pp
 

tests/Test/CommonUtils.hs

@@ -1,17 +1,11 @@
-{-# LANGUAGE GHC_CPP #-}
 module ADP.Fusion.SynVar.Indices.Set1 where
 
-instance
-  ( IndexHdr s x0 i0 us (BS1 k I) cs c is (BS1 k I)
-  ) => AddIndexDense s (us:.BS1 k I) (cs:.c) (is:.BS1 k I) where
-  addIndexDenseGo (cs:.c) (vs:.IVariable rb) (lbs:._) (ubs:._) (us:.BS1 uSet uBnd) (is:.BS1 set bnd)
-    = flatten mk step . addIndexDenseGo cs vs lbs ubs us is . assert (rb==1) -- only works with one element
-    where mk (SvS s t y') =
+instance AddIndexDense s where
+  addIndexDenseGo = flatten
+    where mk =
             let
             in
-#if ADPFUSION_DEBUGOUTPUT
-                traceShow (set,bnd,rb) $
-#endif
-                return (SvS s t y', Just $ set `clearBit` getBoundary bnd)
-          step (_, Nothing) = return Done
+-- comment
+                return ()
+          step = return Done
 

tests/examples/ghc-cpp/Set1.hs

@@ -1,16 +1,10 @@
--- Do not edit! Automatically created with doctest-extract from src/Combinatorics/Permutation/WithoutSomeFixpoints.hs
-{-# LANGUAGE CPP #-}
 {-# LINE 5 "src/Combinatorics/Permutation/WithoutSomeFixpoints.hs" #-}
 
 module Test.Combinatorics.Permutation.WithoutSomeFixpoints where
 
 import qualified Test.DocTest.Driver as DocTest
 
 {-# LINE 6 "src/Combinatorics/Permutation/WithoutSomeFixpoints.hs" #-}
-import     qualified Combinatorics.Permutation.WithoutSomeFixpoints as PermWOFP
-import     qualified Combinatorics as Comb
-import     qualified Test.QuickCheck as QC
-import     Control.Applicative ((<$>))
 import     Data.List (nub)
 
 genPermutationWOFP     :: QC.Gen (Int, String)