addAnnotationsForPretty breaks layout

[isovector]

Consider the following, completely synthesized term:

import Language.Haskell.GHC.ExactPrint
import OccName
import HsExpr
import HsPat
import RdrName
import GHC
import BasicTypes


z :: LHsExpr GhcPs
z = noLoc $ HsVar NoExt $ noLoc $ Unqual $ mkVarOcc "hi"

c :: LHsExpr GhcPs
c = noLoc $ HsCase noExt z $ MG noExt (noLoc
  [ noLoc $ Match noExt CaseAlt [noLoc $ WildPat noExt] $ GRHSs noExt [noLoc $ GRHS noExt [] z] $ noLoc $ EmptyLocalBinds noExt
  , noLoc $ Match noExt CaseAlt [noLoc $ WildPat noExt] $ GRHSs noExt [noLoc $ GRHS noExt [] z] $ noLoc $ EmptyLocalBinds noExt
  , noLoc $ Match noExt CaseAlt [noLoc $ WildPat noExt] $ GRHSs noExt [noLoc $ GRHS noExt [] z] $ noLoc $ EmptyLocalBinds noExt
  ]) Generated

blarg :: String
blarg =
  let anns = addAnnotationsForPretty [] c mempty
   in exactPrint c anns

The above prints

 case hi of
   _ -> hi
      _ -> hi
      _ -> hi

which is completely broken for layout. It should instead be:

case hi of
  _ -> hi
  _ -> hi
  _ -> hi

See also: #80

[isovector]

@alanz this is my latest blocker on the hls saga. Is addAnnotationsForPretty broken, or am I just using the wrong function here?

[isovector]

I spent a few hours digging into ghc-exactprint, but the craziness that is this state machine is far beyond my ability to fix.

[isovector]

This also happens even with unique src spans:

{-# LANGUAGE LambdaCase #-}

module Test where

import Language.Haskell.GHC.ExactPrint
import OccName
import HsExpr
import HsPat
import RdrName
import GHC
import BasicTypes
import Generics.SYB


z :: LHsExpr GhcPs
z = noLoc $ HsVar NoExt $ noLoc $ Unqual $ mkVarOcc "hi"

c :: LHsExpr GhcPs
c = noLoc $ HsCase noExt z $ MG noExt (noLoc
  [ noLoc $ Match noExt CaseAlt [noLoc $ WildPat noExt] $ GRHSs noExt [noLoc $ GRHS noExt [] z] $ noLoc $ EmptyLocalBinds noExt
  , noLoc $ Match noExt CaseAlt [noLoc $ WildPat noExt] $ GRHSs noExt [noLoc $ GRHS noExt [] z] $ noLoc $ EmptyLocalBinds noExt
  , noLoc $ Match noExt CaseAlt [noLoc $ WildPat noExt] $ GRHSs noExt [noLoc $ GRHS noExt [] z] $ noLoc $ EmptyLocalBinds noExt
  ]) Generated


mkSpans :: LHsExpr GhcPs -> LHsExpr GhcPs
mkSpans z =
  let (a, _, _) = runTransform mempty $ do
        everywhereM
          (mkM $ \case
            _ -> uniqueSrcSpanT
          ) z
   in a

c2 = mkSpans c



blarg :: String
blarg =
  let anns = addAnnotationsForPretty [] c2 mempty
   in exactPrint c2 anns

[isovector]

Result from showAnnData:

({ ghc-exactprint:-1:0 }
 Just (Ann (DP (0,0)) [] [] [((G AnnCase),DP (0,1)),((G AnnOf),DP (0,1))] Nothing Nothing)
 (HsCase
  (NoExt)
  ({ ghc-exactprint:-1:1 }
   Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)
   (HsVar
    (NoExt)
    ({ ghc-exactprint:-1:2 }
     Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,1))] Nothing Nothing)
     (Unqual {OccName: hi (v, Var Val )}))))
  (MG
   (NoExt)
   ({ ghc-exactprint:-1:3 }
    Nothing
    [
     ({ ghc-exactprint:-1:4 }
      Just (Ann (DP (1,2)) [] [] [] Nothing Nothing)
      (Match
       (NoExt)
       (CaseAlt)
       [
        (WildPat
         (NoExt))]
       (GRHSs
        (NoExt)
        [
         ({ ghc-exactprint:-1:5 }
          Just (Ann (DP (0,0)) [] [] [((G AnnRarrow),DP (0,1))] Nothing Nothing)
          (GRHS
           (NoExt)
           []
           ({ ghc-exactprint:-1:6 }
            Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)
            (HsVar
             (NoExt)
             ({ ghc-exactprint:-1:7 }
              Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,1))] Nothing Nothing)
              (Unqual {OccName: hi (v, Var Val )}))))))]
        ({ ghc-exactprint:-1:8 }
         Nothing
         (EmptyLocalBinds
          (NoExt)))))),
     ({ ghc-exactprint:-1:9 }
      Just (Ann (DP (1,0)) [] [] [] Nothing Nothing)
      (Match
       (NoExt)
       (CaseAlt)
       [
        (WildPat
         (NoExt))]
       (GRHSs
        (NoExt)
        [
         ({ ghc-exactprint:-1:10 }
          Just (Ann (DP (0,0)) [] [] [((G AnnRarrow),DP (0,1))] Nothing Nothing)
          (GRHS
           (NoExt)
           []
           ({ ghc-exactprint:-1:11 }
            Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)
            (HsVar
             (NoExt)
             ({ ghc-exactprint:-1:12 }
              Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,1))] Nothing Nothing)
              (Unqual {OccName: hi (v, Var Val )}))))))]
        ({ ghc-exactprint:-1:13 }
         Nothing
         (EmptyLocalBinds
          (NoExt)))))),
     ({ ghc-exactprint:-1:14 }
      Just (Ann (DP (1,0)) [] [] [] Nothing Nothing)
      (Match
       (NoExt)
       (CaseAlt)
       [
        (WildPat
         (NoExt))]
       (GRHSs
        (NoExt)
        [
         ({ ghc-exactprint:-1:15 }
          Just (Ann (DP (0,0)) [] [] [((G AnnRarrow),DP (0,1))] Nothing Nothing)
          (GRHS
           (NoExt)
           []
           ({ ghc-exactprint:-1:16 }
            Just (Ann (DP (0,0)) [] [] [] Nothing Nothing)
            (HsVar
             (NoExt)
             ({ ghc-exactprint:-1:17 }
              Just (Ann (DP (0,0)) [] [] [((G AnnVal),DP (0,1))] Nothing Nothing)
              (Unqual {OccName: hi (v, Var Val )}))))))]
        ({ ghc-exactprint:-1:18 }
         Nothing
         (EmptyLocalBinds
          (NoExt))))))])
   (Generated))))

[alanz]

I just created a file

module Issue91 where

-- Based on https://github.com/alanz/ghc-exactprint/issues/91

foo = case hi of
        _ -> hi
        _ -> hi
        _ -> hi

and ran a test of mkPrettyRoundtrip "ghc88" "Issue91.hs" on it. It passed, meaning the ast printed from the new annotations matched the original AST`