diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,12 @@ +2015-08-02 v0.3.1 + + * Mark LHS at the beginning of HsCase and HsIf expressions + * Mark trailing semi colons on ANN pragmas + * Correctly mark trailing semi colons distinctly from internal semicolons + * setPrecedingLinesDecl applies the setting to both the Decl and + the item wrapped in the Decl. + + 2015-07-20 v0.3 Substantial rework to manage changes introduced in GHC 7.10.2 rc2 and beyond. diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,5 +1,5 @@ name: ghc-exactprint -version: 0.3 +version: 0.3.1 synopsis: ExactPrint for GHC description: Using the API Annotations available from GHC 7.10.2, this library provides a means to round trip any code that can @@ -60,14 +60,14 @@ -- other-extensions: GHC-Options: -Wall build-depends: base >=4.7 && <4.9 - , containers - , directory - , filepath - , ghc - , ghc-paths - , mtl - , syb - , free + , containers >= 0.5 + , directory >= 1.2 + , filepath >= 1.4 + , ghc >= 7.10.2 + , ghc-paths >= 0.1 + , mtl >= 2.2.1 + , syb >= 0.5 + , free >= 4.12 hs-source-dirs: src default-language: Haskell2010 if impl (ghc < 7.10.2) @@ -82,19 +82,18 @@ Default-language: Haskell2010 if impl (ghc < 7.10.2) buildable: False - Build-depends: HUnit + Build-depends: HUnit >= 1.2 , base < 5 - , containers - , directory - , filepath - , ghc - , ghc-exactprint - , ghc-paths - , mtl - , random - , syb - , silently - , filemanip + , containers >= 0.5 + , directory >= 1.2 + , filepath >= 1.4 + , ghc >= 7.10.2 + , ghc-exactprint >= 0.3 + , ghc-paths >= 0.1 + , mtl >= 2.2.1 + , syb >= 0.5 + , silently >= 1.2 + , filemanip >= 0.3 executable roundtrip main-is: Roundtrip.hs diff --git a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs --- a/src/Language/Haskell/GHC/ExactPrint/Annotate.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Annotate.hs @@ -182,6 +182,9 @@ markOffset :: GHC.AnnKeywordId -> Int -> Annotated () markOffset kwid n = markOffsetPrim kwid n Nothing +markTrailingSemi :: Annotated () +markTrailingSemi = markOutside GHC.AnnSemi AnnSemiSep + -- --------------------------------------------------------------------- -- | Constructs a syntax tree which contains information about which @@ -486,7 +489,7 @@ Just (_isHiding,lie) -> do mark GHC.AnnHiding markLocated lie - markOutside (GHC.AnnSemi) (G GHC.AnnSemi) + markTrailingSemi -- --------------------------------------------------------------------- instance Annotate GHC.ModuleName where @@ -537,7 +540,7 @@ mark GHC.AnnOpenPE markLocated e mark GHC.AnnCloseP - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi {- - data SpliceExplicitFlag = ExplicitSplice | -- <=> $(f x y) @@ -594,7 +597,7 @@ markWithString GHC.AnnOpen src mapM_ markLocated rules markWithString GHC.AnnClose "#-}" - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -618,7 +621,7 @@ markLocated lhs mark GHC.AnnEqual markLocated rhs - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -647,6 +650,7 @@ markLocated e markWithString GHC.AnnClose "#-}" + markTrailingSemi -- --------------------------------------------------------------------- @@ -691,7 +695,7 @@ markLocated ln mark GHC.AnnDcolon markLocated typ - markOutside (GHC.AnnSemi) AnnSemiSep + markTrailingSemi markAST _l (GHC.ForeignExport ln typ _ (GHC.CExport spec (GHC.L ls src))) = do @@ -750,7 +754,7 @@ mark GHC.AnnOpenP -- '(' mapM_ markLocated typs mark GHC.AnnCloseP -- ')' - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi -- --------------------------------------------------------------------- @@ -804,7 +808,7 @@ ) mark GHC.AnnCloseC -- '}' - markOutside GHC.AnnSemi (AnnSemiSep) + markTrailingSemi -- --------------------------------------------------------------------- @@ -815,7 +819,7 @@ mark GHC.AnnType mark GHC.AnnInstance markLocated eqn - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -843,7 +847,7 @@ => Annotate (GHC.HsBind name) where markAST _ (GHC.FunBind (GHC.L _ln _n) _ (GHC.MG matches _ _ _) _ _ _) = do mapM_ markLocated matches - --markOutside GHC.AnnSemi AnnSemiSep + --markTrailingSemi -- markMatchGroup l mg markAST _ (GHC.PatBind lhs (GHC.GRHSs grhs lb) _typ _fvs _ticks) = do @@ -853,7 +857,7 @@ mark GHC.AnnWhere markLocalBindsWithLayout lb - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi markAST _ (GHC.VarBind _n rhse _) = -- Note: this bind is introduced by the typechecker @@ -880,7 +884,7 @@ mark GHC.AnnWhere mark GHC.AnnOpenC -- '{' mark GHC.AnnCloseC -- '}' - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi -- Introduced after renaming. markAST _ (GHC.AbsBinds _ _ _ _ _) = @@ -897,7 +901,7 @@ Right _i -> return () mark GHC.AnnEqual markLocated e - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -941,7 +945,7 @@ markInside GHC.AnnSemi markLocalBindsWithLayout lb mark GHC.AnnCloseC -- '}' - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -966,7 +970,7 @@ mapM_ markLocated lns mark GHC.AnnDcolon markLocated typ - markOutside (GHC.AnnSemi) (G GHC.AnnSemi) + markTrailingSemi markAST _ (GHC.PatSynSig ln (_,GHC.HsQTvs _ns bndrs) ctx1 ctx2 typ) = do mark GHC.AnnPattern @@ -1003,7 +1007,7 @@ markWithString GHC.AnnInfix fixstr markWithString GHC.AnnVal (show v) mapM_ markLocated lns - markOutside (GHC.AnnSemi) (G GHC.AnnSemi) + markTrailingSemi -- InlineSig (Located name) InlinePragma -- '{-# INLINE' activation qvar '#-}' @@ -1020,7 +1024,7 @@ mark GHC.AnnCloseS -- ']' markLocated ln markWithString GHC.AnnClose "#-}" -- '#-}' - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi markAST _ (GHC.SpecSig ln typs inl) = do @@ -1033,7 +1037,7 @@ mark GHC.AnnDcolon -- '::' mapM_ markLocated typs markWithString GHC.AnnClose "#-}" -- '#-}' - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- '{-# SPECIALISE' 'instance' inst_type '#-}' @@ -1042,7 +1046,7 @@ mark GHC.AnnInstance markLocated typ markWithString GHC.AnnClose "#-}" -- '#-}' - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi @@ -1052,7 +1056,7 @@ annotationsToComments [GHC.AnnOpenP,GHC.AnnCloseP,GHC.AnnComma,GHC.AnnVbar] markAST l formula markWithString GHC.AnnClose "#-}" - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- -------------------------------------------------------------------- @@ -1502,12 +1506,12 @@ mark GHC.AnnLarrow markLocated body mark GHC.AnnVbar -- possible in list comprehension - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi markAST _ (GHC.BodyStmt body _ _ _) = do markLocated body mark GHC.AnnVbar -- possible in list comprehension - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi markAST _ (GHC.LetStmt lb) = do -- return () `debug` ("markP.LetStmt entered") @@ -1519,12 +1523,12 @@ mark GHC.AnnCloseC -- '}' -- return () `debug` ("markP.LetStmt done") mark GHC.AnnVbar -- possible in list comprehension - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi markAST l (GHC.ParStmt pbs _ _) = do mapM_ (markAST l) pbs mark GHC.AnnVbar -- possible in list comprehension - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi markAST _ (GHC.TransStmt form stmts _b using by _ _ _) = do mapM_ markLocated stmts @@ -1544,7 +1548,7 @@ mark GHC.AnnUsing markLocated using mark GHC.AnnVbar -- possible in list comprehension - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi markAST _ (GHC.RecStmt stmts _ _ _ _ _ _ _ _) = do mark GHC.AnnRec @@ -1553,7 +1557,7 @@ mapM_ markLocated stmts mark GHC.AnnCloseC mark GHC.AnnVbar -- possible in list comprehension - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -1655,7 +1659,12 @@ if b == GHC.Boxed then mark GHC.AnnCloseP else markWithString GHC.AnnClose "#)" - markAST l (GHC.HsCase e1 matches) = do + + -- We set the layout for HsCase and HsIf even though they need not obey + -- layout rules as when moving these expressions it's useful that they + -- maintain "internal integrity", that is to say the subparts remain + -- indented relative to each other. + markAST l (GHC.HsCase e1 matches) = setLayoutFlag $ do mark GHC.AnnCase markLocated e1 mark GHC.AnnOf @@ -1664,7 +1673,7 @@ markMatchGroup l matches mark GHC.AnnCloseC - markAST _ (GHC.HsIf _ e1 e2 e3) = do + markAST _ (GHC.HsIf _ e1 e2 e3) = setLayoutFlag $ do mark GHC.AnnIf markLocated e1 markOffset GHC.AnnSemi 0 @@ -2064,7 +2073,7 @@ -- markMany GHC.AnnCloseP mark GHC.AnnEqual markLocated typ - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi markAST _ (GHC.DataDecl ln (GHC.HsQTvs _ns tyVars) (GHC.HsDataDefn _ ctx mctyp mk cons mderivs) _) = do @@ -2082,7 +2091,7 @@ mapM_ markLocated cons markMaybe mderivs mark GHC.AnnCloseC - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi -- ----------------------------------- @@ -2105,7 +2114,7 @@ ++ prepareListAnnotation docs ) mark GHC.AnnCloseC -- '}' - markOutside (GHC.AnnSemi) AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -2142,7 +2151,7 @@ #endif _ -> return () mark GHC.AnnCloseC -- } - markOutside GHC.AnnSemi AnnSemiSep + markTrailingSemi -- --------------------------------------------------------------------- @@ -2256,7 +2265,7 @@ mark GHC.AnnVbar - markOutside GHC.AnnSemi (G GHC.AnnSemi) + markTrailingSemi -- ResTyGADT has a SrcSpan for the original sigtype, we need to create diff --git a/src/Language/Haskell/GHC/ExactPrint/Transform.hs b/src/Language/Haskell/GHC/ExactPrint/Transform.hs --- a/src/Language/Haskell/GHC/ExactPrint/Transform.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Transform.hs @@ -205,7 +205,7 @@ f ans = case Map.lookup (mkAnnKey d) ans of Nothing -> ans Just ann -> - Map.insert (mkAnnKey (GHC.L newSpan s)) ann + Map.insert (mkAnnKey (GHC.L newSpan s )) ann $ Map.insert (mkAnnKey (GHC.L newSpan (GHC.ValD s))) ann ans modifyAnnsT f return (GHC.L newSpan (GHC.ValD s)) @@ -322,7 +322,9 @@ -- |Unwrap a HsDecl and call setPrecedingLines on it setPrecedingLinesDecl :: GHC.LHsDecl GHC.RdrName -> Int -> Int -> Anns -> Anns setPrecedingLinesDecl ld n c ans = - declFun (\a -> setPrecedingLines a n c ans) ld + declFun (\a -> setPrecedingLines a n c ans') ld + where + ans' = Map.insert (mkAnnKey ld) annNone ans declFun :: (forall a . Data a => GHC.Located a -> b) -> GHC.LHsDecl GHC.RdrName -> b declFun f (GHC.L l de) = @@ -352,8 +354,8 @@ setPrecedingLines ast n c anne = Map.alter go (mkAnnKey ast) anne where - go Nothing = Just (annNone { annEntryDelta = (DP (n,c)) }) - go (Just a) = Just (a { annEntryDelta = DP (n, c) } ) + go Nothing = Just (annNone { annEntryDelta = DP (n, c) }) + go (Just a) = Just (a { annEntryDelta = DP (n, c) }) -- --------------------------------------------------------------------- @@ -556,6 +558,24 @@ instance HasDecls (GHC.LMatch GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where hsDecls (GHC.L _ (GHC.Match _ _ _ grhs)) = hsDecls grhs + replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) [] + = do + let + noWhere (G GHC.AnnWhere,_) = False + noWhere _ = True + + removeWhere mkds = + case Map.lookup (mkAnnKey m) mkds of + Nothing -> error "wtf" + Just ann -> Map.insert (mkAnnKey m) ann1 mkds + where + ann1 = ann { annsDP = filter noWhere (annsDP ann) + } + modifyAnnsT removeWhere + + binds' <- replaceDecls binds [] + return (GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds'))) + replaceDecls m@(GHC.L l (GHC.Match mf p t (GHC.GRHSs rhs binds))) newBinds = do -- Need to throw in a fresh where clause if the binds were empty, @@ -692,6 +712,33 @@ binds' <- replaceDecls binds newDecls return (GHC.L l (GHC.AbsBinds a b c d binds')) replaceDecls (GHC.L _ (GHC.PatSynBind _)) _ = error "replaceDecls: PatSynBind to implement" + +-- --------------------------------------------------------------------- + +instance HasDecls (GHC.Stmt GHC.RdrName (GHC.LHsExpr GHC.RdrName)) where + hsDecls (GHC.LetStmt lb) = hsDecls lb + hsDecls (GHC.LastStmt e _) = hsDecls e + hsDecls (GHC.BindStmt _pat e _ _) = hsDecls e + hsDecls (GHC.BodyStmt e _ _ _) = hsDecls e + hsDecls _ = return [] + + replaceDecls (GHC.LetStmt lb) newDecls + = do + lb' <- replaceDecls lb newDecls + return (GHC.LetStmt lb') + replaceDecls (GHC.LastStmt e se) newDecls + = do + e' <- replaceDecls e newDecls + return (GHC.LastStmt e' se) + replaceDecls (GHC.BindStmt pat e a b) newDecls + = do + e' <- replaceDecls e newDecls + return (GHC.BindStmt pat e' a b) + replaceDecls (GHC.BodyStmt e a b c) newDecls + = do + e' <- replaceDecls e newDecls + return (GHC.BodyStmt e' a b c) + replaceDecls x newDecls = return x -- --------------------------------------------------------------------- diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -233,6 +233,7 @@ , mkParserTest "Control.hs" , mkParserTest "T10196.hs" , mkParserTest "StringGap.hs" + , mkParserTest "RedundantDo.hs" ] ++ transformTests @@ -469,6 +470,7 @@ , manipulateAstTestWFnameMod rmDecl1 "RmDecl1.hs" "RmDecl1" -- , manipulateAstTestWFname "RmDecl2.hs" "RmDecl2" , manipulateAstTestWFnameMod rmDecl2 "RmDecl2.hs" "RmDecl2" + , manipulateAstTestWFnameMod rmDecl3 "RmDecl3.hs" "RmDecl3" , manipulateAstTestWFnameMod rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1" , manipulateAstTestWFname "StringGap.hs" "StringGap" {- diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -555,6 +555,7 @@ , mkTestModChange rmDecl1 "RmDecl1.hs" "RmDecl1" , mkTestModChange rmDecl2 "RmDecl2.hs" "RmDecl2" + , mkTestModChange rmDecl3 "RmDecl3.hs" "RmDecl3" , mkTestModChange rmTypeSig1 "RmTypeSig1.hs" "RmTypeSig1" ] @@ -662,6 +663,25 @@ go x = return x SYB.everywhereM (SYB.mkM go) lp + + let (lp',(ans',_),_w) = runTransform ans doRmDecl + return (ans',lp') + +-- --------------------------------------------------------------------- + +rmDecl3 :: Changer +rmDecl3 ans lp = do + let + doRmDecl = do + tlDecs <- hsDecls lp + let [d1] = tlDecs + + subDecs <- hsDecls d1 + let [sd1] = subDecs + + modifyAnnsT (setPrecedingLinesDecl sd1 2 0) + d1' <- replaceDecls d1 [] + replaceDecls lp [d1',sd1] let (lp',(ans',_),_w) = runTransform ans doRmDecl return (ans',lp') diff --git a/tests/examples/Annotations.hs b/tests/examples/Annotations.hs --- a/tests/examples/Annotations.hs +++ b/tests/examples/Annotations.hs @@ -36,3 +36,5 @@ {-# ANN f 'f #-} {-# ANN f (-1 :: Int) #-} f x = x + +{-# ANN foo "HLint: ignore" #-};foo = map f (map g x) diff --git a/tests/examples/RedundantDo.hs b/tests/examples/RedundantDo.hs new file mode 100644 --- /dev/null +++ b/tests/examples/RedundantDo.hs @@ -0,0 +1,4 @@ +foo = + case x of + True -> foo + False -> foo diff --git a/tests/examples/RmDecl3.hs b/tests/examples/RmDecl3.hs new file mode 100644 --- /dev/null +++ b/tests/examples/RmDecl3.hs @@ -0,0 +1,8 @@ +module RmDecl3 where + +-- Remove last declaration from a where clause, where should disappear too +ff y = y + zz + where + zz = 1 + +-- EOF diff --git a/tests/examples/RmDecl3.hs.expected b/tests/examples/RmDecl3.hs.expected new file mode 100644 --- /dev/null +++ b/tests/examples/RmDecl3.hs.expected @@ -0,0 +1,8 @@ +module RmDecl3 where + +-- Remove last declaration from a where clause, where should disappear too +ff y = y + zz + +zz = 1 + +-- EOF