diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -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 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: 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 diff --git a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs --- a/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs +++ b/src/Language/Haskell/GHC/ExactPrint/ExactPrint.hs @@ -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') -- --------------------------------------------------------------------- diff --git a/src/Language/Haskell/GHC/ExactPrint/Orphans.hs b/src/Language/Haskell/GHC/ExactPrint/Orphans.hs --- a/src/Language/Haskell/GHC/ExactPrint/Orphans.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Orphans.hs @@ -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 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 @@ -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 diff --git a/src/Language/Haskell/GHC/ExactPrint/Utils.hs b/src/Language/Haskell/GHC/ExactPrint/Utils.hs --- a/src/Language/Haskell/GHC/ExactPrint/Utils.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Utils.hs @@ -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 diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -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