ghc-exactprint 1.3.0 → 1.4.0

raw patch · 7 files changed

+86/−102 lines, 7 filesdep +data-defaultPVP ok

version bump matches the API change (PVP)

Dependencies added: data-default

API changes (from Hackage documentation)

Files

• ChangeLog +4/−0
• ghc-exactprint.cabal +3/−1
• src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +7/−6
• src/Language/Haskell/GHC/ExactPrint/Orphans.hs +54/−79
• src/Language/Haskell/GHC/ExactPrint/Transform.hs +6/−5
• src/Language/Haskell/GHC/ExactPrint/Utils.hs +5/−4
• tests/Test.hs +7/−7

@@ -1,3 +1,7 @@+2022-01-03 v1.4+	* Fix handling of AnnContext (@pepeiborra)+	* Fix crashy bogus instances (@pepeiborra)+	* Remove head.hackage overlay from cabal project file 2021-11-23 v1.3 	* Update for GHC 9.2.1 as released 	* Introduce makeDeltaAst command to convert all EpaSpan's to equivalent EpaDelta versions

@@ -1,5 +1,5 @@ name:                ghc-exactprint-version:             1.3.0+version:             1.4.0 synopsis:            ExactPrint for GHC description:         Using the API Annotations available from GHC 9.2.1, this                      library provides a means to round trip any code that can@@ -74,6 +74,7 @@                      , bytestring >= 0.10.6                      , containers >= 0.5                      , ordered-containers+                     , data-default                      , directory >= 1.2                      , filepath  >= 1.4                      , ghc       >= 7.10.2@@ -111,6 +112,7 @@                      , bytestring                      , containers >= 0.5                      , ordered-containers+                     , data-default                      , Diff                      , directory >= 1.2                      , filepath  >= 1.4

@@ -6,6 +6,7 @@ {-# LANGUAGE NamedFieldPuns       #-} {-# LANGUAGE RankNTypes           #-} {-# LANGUAGE StandaloneDeriving   #-}+{-# LANGUAGE TupleSections        #-} {-# LANGUAGE TypeFamilies         #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns         #-}@@ -3094,7 +3095,7 @@ exactDo _  _             _     = panic "pprDo" -- PatGuard, ParStmtCxt  exactMdo :: (Monad m, Monoid w)-  => EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m (EpAnn AnnList) +  => EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m (EpAnn AnnList) exactMdo an Nothing            kw = markEpAnnL   an lal_rest kw exactMdo an (Just module_name) kw = markEpAnnLMS an lal_rest kw (Just n)     where@@ -4142,11 +4143,11 @@     a' <- markAnnotated a     -- mapM_ (markKwA AnnCloseP) (sort closes)     mapM_ (markKwA AnnCloseP) closes-    case ma of-      Just (UnicodeSyntax, r) -> markKwA AnnDarrowU r >> pure ()-      Just (NormalSyntax,  r) -> markKwA AnnDarrow  r >> pure ()-      Nothing -> pure ()-    return (L (SrcSpanAnn (EpAnn anc (AnnContext ma opens closes) cs) l) a')+    ma' <- case ma of+      Just (UnicodeSyntax, r) -> Just . (UnicodeSyntax,) <$> markKwA AnnDarrowU r+      Just (NormalSyntax,  r) -> Just . (NormalSyntax,) <$> markKwA AnnDarrow  r+      Nothing -> pure Nothing+    return (L (SrcSpanAnn (EpAnn anc (AnnContext ma' opens closes) cs) l) a')  -- --------------------------------------------------------------------- 

@@ -2,107 +2,82 @@  module Language.Haskell.GHC.ExactPrint.Orphans where +import Data.Default import GHC hiding (EpaComment)  -- ------------------------------------------------------------------------ Orphan Monoid instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372+-- Orphan Default instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372 -instance Semigroup AnnPragma where-  (<>) = error "unimplemented"-instance Monoid AnnPragma where-  mempty = error "meaningless"+instance Default NameAnn where+  def = mempty +instance Default AnnList where+  def = mempty++instance Default AnnListItem where+  def = mempty++instance Default AnnPragma where+  def = AnnPragma def  def def+ instance Semigroup EpAnnImportDecl where   (<>) = error "unimplemented"-instance Monoid EpAnnImportDecl where-  mempty = error "meaningless"+instance Default EpAnnImportDecl where+  def = EpAnnImportDecl def  Nothing  Nothing  Nothing  Nothing  Nothing -instance Semigroup HsRuleAnn where-  (<>) = error "unimplemented"-instance Monoid HsRuleAnn where-  mempty = error "meaningless"+instance Default HsRuleAnn where+  def = HsRuleAnn Nothing Nothing def -instance Semigroup AnnSig where-  (<>) = error "unimplemented"-instance Monoid AnnSig where-  mempty = error "meaningless"+instance Default AnnSig where+  def = AnnSig def  def -instance Semigroup GrhsAnn where-  (<>) = error "unimplemented"-instance Monoid GrhsAnn where-  mempty = error "meaningless"+instance Default GrhsAnn where+  def = GrhsAnn Nothing  def -instance Semigroup EpAnnUnboundVar where-  (<>) = error "unimplemented"-instance Monoid EpAnnUnboundVar where-  mempty = error "meaningless"+instance Default EpAnnUnboundVar where+  def = EpAnnUnboundVar def  def -instance Semigroup NoEpAnns where-  (<>) = error "unimplemented"-instance Monoid NoEpAnns where-  mempty = error "meaningless"+instance Default NoEpAnns where+  def = NoEpAnns -instance Semigroup AnnParen where-  (<>) = error "unimplemented"-instance Monoid AnnParen where-  mempty = error "meaningless"+instance Default AnnParen where+  def = AnnParen AnnParens def  def -instance Semigroup AnnExplicitSum where-  (<>) = error "unimplemented"-instance Monoid AnnExplicitSum where-  mempty = error "meaningless"+instance Default AnnExplicitSum where+  def = AnnExplicitSum def  def  def  def -instance Semigroup EpAnnHsCase where-  (<>) = error "unimplemented"-instance Monoid EpAnnHsCase where-  mempty = error "meaningless"+instance Default EpAnnHsCase where+  def = EpAnnHsCase def def def -instance Semigroup AnnsIf where-  (<>) = error "unimplemented"-instance Monoid AnnsIf where-  mempty = error "meaningless"+instance Default AnnsIf where+  def = AnnsIf def def def def def -instance Semigroup AnnsLet where-  (<>) = error "unimplemented"-instance Monoid AnnsLet where-  mempty = error "meaningless"+instance Default AnnsLet where+  def = AnnsLet def def -instance Semigroup AnnProjection where-  (<>) = error "unimplemented"-instance Monoid AnnProjection where-  mempty = error "meaningless"+instance Default AnnProjection where+  def = AnnProjection def def -instance Semigroup AnnFieldLabel where-  (<>) = error "unimplemented"-instance Monoid AnnFieldLabel where-  mempty = error "meaningless"+instance Default AnnFieldLabel where+  def = AnnFieldLabel Nothing -instance Semigroup EpaLocation where-  (<>) = error "unimplemented"-instance Monoid EpaLocation where-  mempty = error "meaningless"+instance Default EpaLocation where+  def = EpaDelta (SameLine 0) [] -instance Semigroup AddEpAnn where-  (<>) = error "unimplemented"-instance Monoid AddEpAnn where-  mempty = error "meaningless"+instance Default AddEpAnn where+  def = AddEpAnn def def -instance Semigroup TrailingAnn where-  (<>) = error "unimplemented"-instance Monoid TrailingAnn where-  mempty = error "meaningless"+instance Default AnnKeywordId where+  def = Annlarrowtail  {- gotta pick one -} -instance Semigroup AnnContext where-  (<>) = error "unimplemented"-instance Monoid AnnContext where-  mempty = AnnContext Nothing [] []+instance Default TrailingAnn where+  def = AddLollyAnnU {-gotta pick one -} def -instance Semigroup EpAnnSumPat where-  (<>) = error "unimplemented"-instance Monoid EpAnnSumPat where-  mempty = error "meaningless"+instance Default AnnContext where+  def = AnnContext Nothing [] [] -instance Semigroup AnnsModule where-  (<>) = error "unimplemented"-instance Monoid AnnsModule where-  mempty = error "meaningless"+instance Default EpAnnSumPat where+  def = EpAnnSumPat def  def  def++instance Default AnnsModule where+  def = AnnsModule [] mempty

@@ -103,6 +103,7 @@  import Data.Functor.Identity import Control.Monad.State+import Data.Default  ------------------------------------------------------------------------------ -- Transformation of source elements@@ -191,7 +192,7 @@       ms' = captureLineSpacing ms captureMatchLineSpacing d = d -captureLineSpacing :: Monoid t+captureLineSpacing :: Default t                    => [LocatedAn t e] -> [LocatedAn t e] captureLineSpacing [] = [] captureLineSpacing [d] = [d]@@ -284,10 +285,10 @@  -- |Set the true entry 'DeltaPos' from the annotation for a given AST -- element. This is the 'DeltaPos' ignoring any comments.-setEntryDP :: (Monoid t) => LocatedAn t a -> DeltaPos -> LocatedAn t a+setEntryDP :: Default t => LocatedAn t a -> DeltaPos -> LocatedAn t a setEntryDP (L (SrcSpanAnn EpAnnNotUsed l) a) dp   = L (SrcSpanAnn-           (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) mempty emptyComments)+           (EpAnn (Anchor (realSrcSpan l) (MovedAnchor dp)) def emptyComments)            l) a setEntryDP (L (SrcSpanAnn (EpAnn (Anchor r _) an (EpaComments [])) l) a) dp   = L (SrcSpanAnn@@ -1361,7 +1362,7 @@                       `extM` (locatedAnnImpl @AnnContext)  -- LocatedC                       ) -    locatedAnnImpl :: forall an. (Monoid an)+    locatedAnnImpl :: forall an. (Default an)       => SrcAnn an -> Delta (SrcAnn an)     locatedAnnImpl (SrcSpanAnn (EpAnn anc@(Anchor loc _op) an cs) l) = do       -- error "locatedAnnImpl:EpAnn"@@ -1386,7 +1387,7 @@       let cs' = case ma of             Nothing -> mkComments ("EpAnnNotUsed:from anc:Nothing") (spanAsAnchor l)             Just anc' -> mkComments ("EpAnnNotUsed:from anc:" ++ showGhc anc') anc'-      return (SrcSpanAnn (EpAnn anchor' mempty cs') l)+      return (SrcSpanAnn (EpAnn anchor' def cs') l)  -- | Monadic variation on everywhere', so Apply a monadic -- transformation everywhere in top-down manner

@@ -40,6 +40,7 @@  import Debug.Trace import Language.Haskell.GHC.ExactPrint.Types+import Data.Default  -- --------------------------------------------------------------------- @@ -324,16 +325,16 @@  -- --------------------------------------------------------------------- -setAnchorAn :: (Monoid an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a+setAnchorAn :: (Default an) => LocatedAn an a -> Anchor -> EpAnnComments -> LocatedAn an a setAnchorAn (L (SrcSpanAnn EpAnnNotUsed l)    a) anc cs-  = (L (SrcSpanAnn (EpAnn anc mempty cs) l) a)+  = (L (SrcSpanAnn (EpAnn anc def cs) l) a)      `debug` ("setAnchorAn: anc=" ++ showAst anc) setAnchorAn (L (SrcSpanAnn (EpAnn _ an _) l) a) anc cs   = (L (SrcSpanAnn (EpAnn anc an cs) l) a)      `debug` ("setAnchorAn: anc=" ++ showAst anc) -setAnchorEpa :: (Monoid an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an-setAnchorEpa EpAnnNotUsed   anc cs = EpAnn anc mempty cs+setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an+setAnchorEpa EpAnnNotUsed   anc cs = EpAnn anc def cs setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an     cs  setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList

@@ -132,15 +132,15 @@   roundTripMakeDeltaTests <- findTestsMD libdir   -- prettyRoundTripTests <- findPrettyTests libdir   return $ TestList [-                    --   internalTests,-                    --   roundTripTests-                    -- ,+                      internalTests,+                      roundTripTests+                    ,                       (transformTests libdir)                     , (failingTests libdir)-                    -- ,-                    --   roundTripBalanceCommentsTests-                    -- ,-                    --   roundTripMakeDeltaTests+                    ,+                      roundTripBalanceCommentsTests+                    ,+                      roundTripMakeDeltaTests                     ]  -- Tests that are no longer needed