Merge pull request #139 from alanz/ghc-9.12-delta-ast

Ghc 9.12 delta ast

.gitignore

@@ -64,3 +64,4 @@ packages
 /failing-tests-for-ghc9.2.txt
 /failures.txt
 /tests/examples/transform/AddArgFromWhereComments.hs.expected
+/tests/examples/ghc912-copied/

configure.sh

@@ -257,7 +257,8 @@ rm -fr dist*
 # cabal configure -fdev -froundtrip --enable-tests --with-compiler=/opt/ghc/9.12.0.20241114/bin/ghc --allow-newer
 
 # cabal configure -fdev -froundtrip --enable-tests --with-compiler=/home/alanz/.ghcup/bin/ghc-9.12.0.20241128 --allow-newer
-cabal configure -fdev --enable-tests --with-compiler=/home/alanz/.ghcup/bin/ghc-9.12.0.20241128 
+# cabal configure -fdev --enable-tests --with-compiler=/home/alanz/.ghcup/bin/ghc-9.12.0.20241128 
+cabal configure -fdev --enable-tests --with-compiler=ghc-9.12.1
 
 
 

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

@@ -111,16 +111,19 @@ runEP epReader action = do
 
 defaultEPState :: EPState
 defaultEPState = EPState
-             { epPos      = (1,1)
-             , dLHS       = 0
-             , pMarkLayout = False
-             , pLHS = 0
-             , dMarkLayout = False
-             , dPriorEndPosition = (1,1)
-             , uAnchorSpan = badRealSrcSpan
+             { uAnchorSpan = badRealSrcSpan
              , uExtraDP = Nothing
              , uExtraDPReturn = Nothing
              , pAcceptSpan = False
+
+             , epPos       = (1,1)
+             , pMarkLayout = False
+             , pLHS = LayoutStartCol 1
+
+             , dPriorEndPosition = (1,1)
+             , dMarkLayout = False
+             , dLHS        = LayoutStartCol 1
+
              , epComments = []
              , epCommentsApplied = []
              , epEof = Nothing
@@ -457,7 +460,6 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
   -- delta phase variables -----------------------------------
   -- Calculate offset required to get to the start of the SrcSPan
   !off <- getLayoutOffsetD
-  let spanStart = ss2pos curAnchor
   priorEndAfterComments <- getPriorEndD
   let edp' = adjustDeltaForOffset
                -- Use the propagated offset if one is set
@@ -485,6 +487,7 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
   when (isJust medr) $ setExtraDPReturn medr
   -- ---------------------------------------------
   -- Preparation complete, perform the action
+  let spanStart = ss2pos curAnchor
   when (priorEndAfterComments < spanStart) (do
     debugM $ "enterAnn.dPriorEndPosition:spanStart=" ++ show spanStart
     modify (\s -> s { dPriorEndPosition    = spanStart } ))
@@ -517,8 +520,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
     Just (pos, prior) -> do
        let dp = if pos == prior
              then (DifferentLine 1 0)
-             else origDelta pos prior
-       debugM $ "EOF:(pos,posEnd,prior,dp) =" ++ showGhc (ss2pos pos, ss2posEnd pos, ss2pos prior, dp)
+             else adjustDeltaForOffset off (origDelta pos prior)
+       debugM $ "EOF:(pos,posend,prior,off,dp) =" ++ show (ss2pos pos, ss2posEnd pos, ss2pos prior, off, dp)
        printStringAtLsDelta dp ""
        setEofPos Nothing -- Only do this once
 
@@ -547,8 +550,8 @@ enterAnn !(Entry anchor' trailing_anns cs flush canUpdateAnchor) a = do
               return after
            else return []
   !trailing' <- markTrailing trailing_anns
-  -- mapM_ printOneComment (concatMap tokComment $ following)
   addCommentsA following
+  debugM $ "enterAnn:done:(anchor,priorCs,postCs) =" ++ show (showAst anchor', priorCs, postCs)
 
   -- Update original anchor, comments based on the printing process
   -- TODO:AZ: probably need to put something appropriate in instead of noSrcSpan
@@ -1392,7 +1395,7 @@ printOneComment c@(Comment _str loc _r _mo) = do
   dp' <- case mep of
     Just (EpaDelta _ edp _) -> do
       debugM $ "printOneComment:edp=" ++ show edp
-      adjustDeltaForOffsetM edp
+      return edp
     _ -> return dp
   -- Start of debug printing
   LayoutStartCol dOff <- getLayoutOffsetD
@@ -1405,31 +1408,10 @@ updateAndApplyComment :: (Monad m, Monoid w) => Comment -> DeltaPos -> EP w m ()
 updateAndApplyComment (Comment str anc pp mo) dp = do
   applyComment (Comment str anc' pp mo)
   where
-    (r,c) = ss2posEnd pp
-    dp'' = case anc of
-      EpaDelta _ dp1 _ -> dp1
-      EpaSpan (RealSrcSpan la _) ->
-           if r == 0
-             then (ss2delta (r,c+0) la)
-             else (ss2delta (r,c)   la)
-      EpaSpan (UnhelpfulSpan _) -> SameLine 0
-    dp' = case anc of
-      EpaSpan (RealSrcSpan r1 _) ->
-          if pp == r1
-                 then dp
-                 else dp''
-      _ -> dp''
     ss = case anc of
         EpaSpan ss' -> ss'
         _          -> noSrcSpan
-    op' = case dp' of
-            SameLine n -> if n >= 0
-                            then EpaDelta ss dp' NoComments
-                            else EpaDelta ss dp NoComments
-            _ -> EpaDelta ss dp' NoComments
-    anc' = if str == "" && op' == EpaDelta ss (SameLine 0) NoComments -- EOF comment
-           then EpaDelta ss dp NoComments
-           else EpaDelta ss dp NoComments
+    anc' = EpaDelta ss dp NoComments
 
 -- ---------------------------------------------------------------------
 
@@ -1469,11 +1451,6 @@ commentAllocationIn ss = do
 markAnnotatedWithLayout :: (Monad m, Monoid w) => ExactPrint ast => ast -> EP w m ast
 markAnnotatedWithLayout a = setLayoutBoth $ markAnnotated a
 
--- ---------------------------------------------------------------------
-
-markTopLevelList :: (Monad m, Monoid w) => ExactPrint ast => [ast] -> EP w m [ast]
-markTopLevelList ls = mapM (\a -> setLayoutTopLevelP $ markAnnotated a) ls
-
 -- ---------------------------------------------------------------------
 -- End of utility functions
 -- ---------------------------------------------------------------------
@@ -1545,11 +1522,11 @@ instance ExactPrint (HsModule GhcPs) where
           an0 <- markLensTok an lam_mod
           m' <- markAnnotated m
 
-          mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec
+          mdeprec' <- markAnnotated mdeprec
 
-          mexports' <- setLayoutTopLevelP $ markAnnotated mexports
+          mexports' <- markAnnotated mexports
 
-          an1 <- setLayoutTopLevelP $ markLensTok an0 lam_where
+          an1 <- markLensTok an0 lam_where
 
           return (an1, Just m', mdeprec', mexports')
 
@@ -1600,8 +1577,8 @@ instance ExactPrint HsModuleImpDecls where
   setAnnotationAnchor mid _anc _ cs = mid { id_cs = priorComments cs ++ getFollowingComments cs }
      `debug` ("HsModuleImpDecls.setAnnotationAnchor:cs=" ++ showAst cs)
   exact (HsModuleImpDecls cs imports decls) = do
-    imports' <- markTopLevelList imports
-    decls' <- markTopLevelList (filter notDocDecl decls)
+    imports' <- mapM markAnnotated imports
+    decls' <- mapM markAnnotated (filter notDocDecl decls)
     return (HsModuleImpDecls cs imports' decls')
 
 
@@ -2849,9 +2826,7 @@ instance ExactPrint (GRHS GhcPs (LocatedA (HsExpr GhcPs))) where
   setAnnotationAnchor (GRHS an a b) anc ts cs = GRHS (setAnchorEpa an anc ts cs) a b
 
   exact (GRHS an guards expr) = do
-    an0 <- if null guards
-             then return an
-             else markLensFun' an lga_vbar (\mt -> mapM markEpToken mt)
+    an0 <- markLensFun' an lga_vbar (\mt -> mapM markEpToken mt)
     guards' <- markAnnotated guards
     -- Mark the matchSeparator for these GRHSs
     an1 <- markLensFun' an0 lga_sep (\s -> case s of
@@ -4907,18 +4882,6 @@ setLayoutBoth k = do
                         , pLHS = oldAnchorOffset} )
   k <* reset
 
--- Use 'local', designed for this
-setLayoutTopLevelP :: (Monad m, Monoid w) => EP w m a -> EP w m a
-setLayoutTopLevelP k = do
-  debugM $ "setLayoutTopLevelP entered"
-  oldAnchorOffset <- getLayoutOffsetP
-  modify (\a -> a { pMarkLayout = False
-                  , pLHS = 0} )
-  r <- k
-  debugM $ "setLayoutTopLevelP:resetting"
-  setLayoutOffsetP oldAnchorOffset
-  return r
-
 ------------------------------------------------------------------------
 
 getPosP :: (Monad m, Monoid w) => EP w m Pos

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

@@ -301,7 +301,9 @@ setEntryDP (L (EpAnn (EpaSpan ss@(RealSrcSpan r _)) an cs) a) dp
                 line = getDeltaLine delta
                 col = deltaColumn delta
                 edp' = if line == 0 then SameLine col
-                                    else DifferentLine line col
+                                    else DifferentLine line (col - 1)
+                                         -- At the top level the layout offset is 1, adjust for it
+                                         -- TODO: what about the layout offset for nested items?
                 edp = edp' `debug` ("setEntryDP :" ++ showGhc (edp', (ss2pos $ epaLocationRealSrcSpan $ getLoc lc), r))
 
 
@@ -528,7 +530,7 @@ balanceCommentsA la1 la2 = (la1', la2')
     anc2 = comments an2
 
     (p1,m1,f1) = splitComments (anchorFromLocatedA la1) anc1
-    cs1p = priorCommentsDeltas    (anchorFromLocatedA la1) p1
+    cs1p = priorCommentsDeltas (anchorFromLocatedA la1) p1
 
     -- Split cs1 following comments into those before any
     -- TrailingAnn's on an1, and any after
@@ -769,6 +771,7 @@ insertAt f t decl = replaceDecls t (f decl oldDecls')
     oldDecls = hsDecls t
     oldDeclsb = balanceCommentsList oldDecls
     oldDecls' = oldDeclsb
+      `debug` ("insertAt: oldDeclsb:" ++ showAst oldDeclsb)
 
 -- |Insert a declaration at the beginning or end of the subdecls of the given
 -- AST item
@@ -1113,8 +1116,8 @@ oldWhereAnnotation (EpAnn anc an cs) ww _oldSpan = an'
 newWhereAnnotation :: WithWhere -> (EpAnn (AnnList (EpToken "where")))
 newWhereAnnotation ww = an
   where
-  anc  = EpaDelta noSrcSpan (DifferentLine 1 3) []
-  anc2 = EpaDelta noSrcSpan (DifferentLine 1 5) []
+  anc  = EpaDelta noSrcSpan (DifferentLine 1 2) []
+  anc2 = EpaDelta noSrcSpan (DifferentLine 1 4) []
   w = case ww of
     WithWhere -> EpTok (EpaDelta noSrcSpan (SameLine 0) [])
     WithoutWhere -> NoEpTok

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

@@ -170,7 +170,7 @@ undelta (l,_) (DifferentLine dl dc) (LayoutStartCol co) = (fl,fc)
 -- ---------------------------------------------------------------------
 
 adjustDeltaForOffset :: LayoutStartCol -> DeltaPos -> DeltaPos
-adjustDeltaForOffset _colOffset                      dp@(SameLine _) = dp
+adjustDeltaForOffset _colOffset              dp@(SameLine _) = dp
 adjustDeltaForOffset (LayoutStartCol colOffset) (DifferentLine l c)
   = DifferentLine l (c - colOffset)
 
@@ -225,14 +225,17 @@ isPointSrcSpan ss = spanLength ss == 0
 -- does not already have one.
 commentOrigDelta :: LEpaComment -> LEpaComment
 commentOrigDelta (L (EpaSpan ss@(RealSrcSpan la _)) (GHC.EpaComment t pp))
-  = (L (EpaDelta ss dp NoComments) (GHC.EpaComment t pp))
-                  `debug` ("commentOrigDelta: (la, pp, r,c, dp)=" ++ showAst (la, pp, r,c, dp))
+  = (L (EpaDelta ss dp' NoComments) (GHC.EpaComment t pp))
+                  `debug` ("commentOrigDelta: (la, pp, r,c, dp, dp')=" ++ showAst (la, pp, r,c, dp, dp'))
   where
         (r,c) = ss2posEnd pp
 
         dp = if r == 0
                then (ss2delta (r,c+1) la)
                else (ss2delta (r,c)   la)
+        dp' = case dp of
+            SameLine _ -> dp
+            DifferentLine l cc -> DifferentLine l (cc - 1)
 commentOrigDelta c = c
 
 origDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos

tests/Test.hs

@@ -54,8 +54,6 @@ testDirs =
 main :: IO ()
 main = hSilence [stderr] $ do
   print ghcVersion
-  cwd <- getCurrentDirectory
-  putStrLn $ "cwd:" ++ show cwd
   tests <- mkTests
   cnts <- fst <$> runTestText (putTextToHandle stdout True) tests
   putStrLn $ show cnts
@@ -214,7 +212,9 @@ tt' = do
 
     -- mkParserTest libdir "ghc912" "Module.hs"
     -- mkParserTest libdir "ghc912" "tests.hs"
-    mkParserTestMD libdir "ghc912" "Fff.hs"
+    -- mkParserTestMD libdir "ghc912" "Fff.hs"
+    -- mkParserTestMD libdir "transform" "AddLocalDecl5.hs"
+    mkParserTestBC libdir "transform" "AddLocalDecl5.hs"
     -- mkParserTestMD libdir "ghc912" "Module.hs"
     -- mkParserTestMD libdir "ghc912" "Operator.hs"
    -- Needs GHC changes

tests/Test/Common.hs

@@ -109,7 +109,6 @@ noChange _libdir parsed = return parsed
 
 changeBalanceComments :: Changer
 changeBalanceComments _libdir top = do
-  -- let (GHC.L l p) = makeDeltaAst top
   let (GHC.L l p) = top
   let decls0 = GHC.hsmodDecls p
       decls = balanceCommentsList decls0

tests/Test/Transform.hs

@@ -29,7 +29,7 @@ import Test.HUnit
 transformTestsTT :: LibDir -> Test
 transformTestsTT libdir = TestLabel "transformTestsTT" $ TestList
   [
-    mkTestModChange libdir changeWhereIn3b   "WhereIn3b.hs"
+    mkTestModChange libdir addLocaLDecl5  "AddLocalDecl5.hs"
   ]
 
 transformTests :: LibDir -> Test
@@ -130,8 +130,8 @@ changeLocalDecls2 libdir (L l p) = do
       replaceLocalBinds :: LMatch GhcPs (LHsExpr GhcPs)
                         -> Transform (LMatch GhcPs (LHsExpr GhcPs))
       replaceLocalBinds (L lm (Match ma mln pats (GRHSs _ rhs EmptyLocalBinds{}))) = do
-        let anc = (EpaDelta noSrcSpan (DifferentLine 1 3) [])
-        let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 5) [])
+        let anc = (EpaDelta noSrcSpan (DifferentLine 1 2) [])
+        let anc2 = (EpaDelta noSrcSpan (DifferentLine 1 4) [])
         let an = EpAnn anc
                         (AnnList (Just anc2) ListNone
                                  []
@@ -168,9 +168,7 @@ changeLocalDecls libdir (L l p) = do
             os' = setEntryDP os (DifferentLine 2 0)
         let sortKey = captureOrderBinds decls
         let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van
-        let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 5) [])) a b c dd) cs)
-        -- let (EpAnn anc (AnnList (Just _) a b c dd) cs) = van
-        -- let van' = (EpAnn anc (AnnList (Just (EpaDelta (DifferentLine 1 5) [])) a b c dd) cs)
+        let van' = (EpAnn anc (AnnList (Just (EpaDelta noSrcSpan (DifferentLine 1 4) [])) a b c dd) cs)
         let binds' = (HsValBinds van'
                           (ValBinds sortKey (decl':oldBinds)
                                           (sig':os':oldSigs)))
@@ -391,10 +389,10 @@ addLocaLDecl4 libdir lp = do
 addLocaLDecl5 :: Changer
 addLocaLDecl5 _libdir lp = do
   let
-      doAddLocal = replaceDecls lp [s1,de1',d3']
+      doAddLocal = replaceDecls lp (s1:de1':d3':ds)
         where
           decls = hsDecls lp
-          [s1,de1,d2,d3] = balanceCommentsList decls
+          (s1:de1:d2:d3:ds) = balanceCommentsList decls
 
           d3' = setEntryDP d3 (DifferentLine 2 0)
 

tests/examples/ghc912/Fff.hs

@@ -0,0 +1,8 @@
+yes p1 p2
+  | g1 = e1
+
+
+foo = 3
+  where
+    yes p1 p2
+      | g1 = e1

tests/examples/ghc912/Operator.hs

@@ -0,0 +1,54 @@
+module Operator where
+
+main :: IO ()
+main = do
+  print $ 3 + 4
+  -- lets make sure
+  print $ foo ||
+    -- that comments end up in the right place
+    bar ||
+    baz &&
+    -- even this one
+    quux
+
+  -- lets also make sure
+  print $ foo
+    -- that these comments end up in the right place
+    || bar
+    || baz
+    -- even when the operator is leading
+    && quux
+
+  return ({- comment -} x >= 1 || y >= 2)
+
+  print $ foo || bar
+  print $ foo || bar
+  print $ foo || bar
+  print $  {- comment here -} foo || bar
+  print $ foo {- comment here -} || bar
+  print $ foo || {- comment here -} bar
+  print $ foo || bar {- comment here -}
+
+  print $ foo || bar
+  print $ foo || bar
+
+{-# RULES "print" forall x. putStrLn $ show $ x = print $ x #-}
+
+f :: Int -> Bool
+f x = x == 2
+
+g :: Int -> Bool
+g y = (y == 2) /= False
+
+roundtrip :: IO [a]
+roundtrip = return $ mconcat
+  [ timeToText $ time_enrolled - mod time_enrolled t
+  , ":"
+  ]
+
+-- Ensure local fixity declarations are handled properly
+(.@@@) :: (a -> b) -> a -> b
+f .@@@ x = f x
+
+infixr 0 .@@@
+{-# RULES "printAt" forall x. putStrLn .@@@ show .@@@ x = print $ x #-}