ghc-exactprint 0.3 → 0.3.1
raw patch · 10 files changed
+165/−57 lines, 10 filesdep −randomdep ~HUnitdep ~basedep ~containersPVP ok
version bump matches the API change (PVP)
Dependencies removed: random
Dependency ranges changed: HUnit, base, containers, directory, filemanip, filepath, free, ghc, ghc-exactprint, ghc-paths, mtl, silently, syb
API changes (from Hackage documentation)
+ Language.Haskell.GHC.ExactPrint.Transform: instance Language.Haskell.GHC.ExactPrint.Transform.HasDecls (HsExpr.Stmt RdrName.RdrName (HsExpr.LHsExpr RdrName.RdrName))
Files
- ChangeLog +9/−0
- ghc-exactprint.cabal +20/−21
- src/Language/Haskell/GHC/ExactPrint/Annotate.hs +41/−32
- src/Language/Haskell/GHC/ExactPrint/Transform.hs +51/−4
- tests/Test.hs +2/−0
- tests/Test/Transform.hs +20/−0
- tests/examples/Annotations.hs +2/−0
- tests/examples/RedundantDo.hs +4/−0
- tests/examples/RmDecl3.hs +8/−0
- tests/examples/RmDecl3.hs.expected +8/−0
ChangeLog view
@@ -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.
ghc-exactprint.cabal view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Annotate.hs view
@@ -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
src/Language/Haskell/GHC/ExactPrint/Transform.hs view
@@ -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 -- ---------------------------------------------------------------------
tests/Test.hs view
@@ -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" {-
tests/Test/Transform.hs view
@@ -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')
tests/examples/Annotations.hs view
@@ -36,3 +36,5 @@ {-# ANN f 'f #-} {-# ANN f (-1 :: Int) #-} f x = x++{-# ANN foo "HLint: ignore" #-};foo = map f (map g x)
+ tests/examples/RedundantDo.hs view
@@ -0,0 +1,4 @@+foo =+ case x of+ True -> foo+ False -> foo
+ tests/examples/RmDecl3.hs view
@@ -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
+ tests/examples/RmDecl3.hs.expected view
@@ -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