diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,5 @@ +2022-09-30 v1.6.0 + * Support GHC 9.4.1 and GHC 9.4.2 2022-02-01 v1.5.0 * Add private version of showAstData, to be able to render AnchorOperation's hacked into SrcSpan's. diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,12 +1,12 @@ name: ghc-exactprint -version: 1.5.0 +version: 1.6.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 be compiled by GHC, currently excluding lhs files. . - Note: requires GHC 9.2 or later. For GHC versions from - 7.10.2 to 9.0.* see this library with versions < 1.1 + Note: requires GHC 9.4.*. For earlier GHC + versions see lower version numbers. . license: BSD3 @@ -15,7 +15,8 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 9.2.1 +tested-with: GHC == 9.4.1 + , GHC == 9.4.2 extra-source-files: ChangeLog tests/examples/failing/*.hs tests/examples/ghc710-only/*.hs @@ -28,6 +29,7 @@ tests/examples/ghc88/*.hs tests/examples/ghc90/*.hs tests/examples/ghc92/*.hs + tests/examples/ghc94/*.hs tests/examples/pre-ghc810/*.hs tests/examples/pre-ghc86/*.hs tests/examples/pre-ghc90/*.hs @@ -71,15 +73,14 @@ -- other-extensions: GHC-Options: -Wall -Wredundant-constraints -- GHC-Options: -Weverything - build-depends: base >=4.16 && <4.18 + build-depends: base >=4.17 && <4.18 , bytestring >= 0.10.6 , containers >= 0.5 , ordered-containers , data-default , directory >= 1.2 , filepath >= 1.4 - , ghc >= 7.10.2 - , ghc-paths >= 0.1 + , ghc >= 9.4.1 , mtl >= 2.2.1 , syb >= 0.5 , free >= 4.12 @@ -88,7 +89,7 @@ default-language: Haskell2010 - if impl (ghc < 9.2) + if impl (ghc < 9.4) buildable: False Test-Suite test @@ -106,8 +107,6 @@ , Test.Transform GHC-Options: -threaded -Wall -Wredundant-constraints Default-language: Haskell2010 - if impl (ghc < 9.2) - buildable: False Build-depends: HUnit >= 1.2 , base < 4.18 , bytestring @@ -117,7 +116,7 @@ , Diff , directory >= 1.2 , filepath >= 1.4 - , ghc >= 7.10.2 + , ghc >= 9.4.1 , ghc-paths >= 0.1 , mtl >= 2.2.1 , syb >= 0.5 @@ -126,10 +125,13 @@ -- for the lib only , fail >= 4.9 && <4.10 , ghc-boot + , Cabal-syntax if flag (dev) build-depends: free else build-depends: ghc-exactprint + if impl (ghc < 9.4) + buildable: False executable roundtrip main-is: Roundtrip.hs @@ -138,7 +140,7 @@ Test.CommonUtils -- Test.Consistency default-language: Haskell2010 - if impl (ghc >= 9.2) && flag (roundtrip) + if impl (ghc >= 9.4) && flag (roundtrip) build-depends: HUnit , base @@ -148,7 +150,7 @@ , filepath , ghc , ghc-exactprint - , ghc-paths + -- , ghc-paths , syb , temporary , time @@ -185,8 +187,7 @@ , directory , filemanip , filepath - , ghc >= 9.2 - , ghc-paths >= 0.1 + , ghc >= 9.4.1 , HUnit , text >= 1.2.2 , turtle >= 1.3.0 diff --git a/src/Language/Haskell/GHC/ExactPrint/Dump.hs b/src/Language/Haskell/GHC/ExactPrint/Dump.hs --- a/src/Language/Haskell/GHC/ExactPrint/Dump.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Dump.hs @@ -59,7 +59,6 @@ `extQ` annotationAddEpAnn `extQ` annotationGrhsAnn `extQ` annotationEpAnnHsCase - `extQ` annotationEpAnnHsLet `extQ` annotationAnnList `extQ` annotationEpAnnImportDecl `extQ` annotationAnnParen @@ -239,9 +238,6 @@ annotationEpAnnHsCase :: EpAnn EpAnnHsCase -> SDoc annotationEpAnnHsCase = annotation' (text "EpAnn EpAnnHsCase") - - annotationEpAnnHsLet :: EpAnn AnnsLet -> SDoc - annotationEpAnnHsLet = annotation' (text "EpAnn AnnsLet") annotationAnnList :: EpAnn AnnList -> SDoc annotationAnnList = annotation' (text "EpAnn AnnList") 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 @@ -5,9 +5,12 @@ {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance @@ -30,21 +33,25 @@ ) where import GHC -import GHC.Base (NonEmpty(..) ) +-- import GHC.Base (NonEmpty(..) ) import GHC.Core.Coercion.Axiom (Role(..)) import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF import GHC.Data.FastString +import GHC.TypeLits import GHC.Types.Basic hiding (EP) import GHC.Types.Fixity import GHC.Types.ForeignCall import GHC.Types.SourceText +import GHC.Types.PkgQual import GHC.Types.Var import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Panic +-- import GHC.Types.PkgQual + import Control.Monad.Identity import qualified Control.Monad.Reader as Reader import Control.Monad.RWS @@ -52,10 +59,11 @@ import Data.Dynamic import Data.Foldable import Data.Functor.Const -import qualified Data.Set.Ordered as OSet +import Data.List +-- import qualified Data.Set.Ordered as OSet import qualified Data.Set as Set import Data.Typeable -import Data.List ( partition, sortBy) +-- import Data.List ( partition, sortBy) import Data.Maybe ( isJust, mapMaybe ) import Data.Void @@ -411,12 +419,8 @@ addComments csNew = do -- debugM $ "addComments:" ++ show csNew cs <- getUnallocatedComments - -- Make sure we merge duplicates while sorting, needed until - -- https://gitlab.haskell.org/ghc/ghc/-/issues/20239 is resolved - let ocs = OSet.fromList cs - let ncs = OSet.fromList csNew - putUnallocatedComments (OSet.toAscList (ocs OSet.<>| ncs)) + putUnallocatedComments (sort (cs ++ csNew)) -- --------------------------------------------------------------------- @@ -623,30 +627,43 @@ -- --------------------------------------------------------------------- -markArrow :: (Monad m, Monoid w) - => EpAnn TrailingAnn -> HsArrow GhcPs -> EP w m (EpAnn TrailingAnn, HsArrow GhcPs) -markArrow an arr = do - arr' <- - case arr of - HsUnrestrictedArrow _u -> - return arr - HsLinearArrow u ma -> do - ma' <- mapM markAddEpAnn ma - return (HsLinearArrow u ma') - HsExplicitMult u ma t -> do - ma' <- mapM markAddEpAnn ma - t' <- markAnnotated t - return (HsExplicitMult u ma' t') +markToken :: forall m w tok . (Monad m, Monoid w, KnownSymbol tok) + => LHsToken tok GhcPs -> EP w m (LHsToken tok GhcPs) +markToken (L NoTokenLoc t) = return (L NoTokenLoc t) +markToken (L (TokenLoc aa) t) = do + aa' <- printStringAtAA aa (symbolVal (Proxy @tok)) + return (L (TokenLoc aa') t) - an' <- case an of - EpAnnNotUsed -> pure EpAnnNotUsed - EpAnn anc a cs -> do - a' <- markKwT a - return (EpAnn anc a' cs) - return (an', arr') +markUniToken :: forall m w tok utok. (Monad m, Monoid w, KnownSymbol tok, KnownSymbol utok) + => LHsUniToken tok utok GhcPs -> EP w m (LHsUniToken tok utok GhcPs) +markUniToken (L l HsNormalTok) = do + (L l' _) <- markToken (L l (HsTok @tok)) + return (L l' HsNormalTok) +markUniToken (L l HsUnicodeTok) = do + (L l' _) <- markToken (L l (HsTok @utok)) + return (L l' HsUnicodeTok) -- --------------------------------------------------------------------- +markArrow :: (Monad m, Monoid w) => HsArrow GhcPs -> EP w m (HsArrow GhcPs) +markArrow (HsUnrestrictedArrow arr) = do + arr' <- markUniToken arr + return (HsUnrestrictedArrow arr') +markArrow (HsLinearArrow (HsPct1 pct1 arr)) = do + pct1' <- markToken pct1 + arr' <- markUniToken arr + return (HsLinearArrow (HsPct1 pct1' arr')) +markArrow (HsLinearArrow (HsLolly arr)) = do + arr' <- markToken arr + return (HsLinearArrow (HsLolly arr')) +markArrow (HsExplicitMult pct t arr) = do + pct' <- markToken pct + t' <- markAnnotated t + arr' <- markUniToken arr + return (HsExplicitMult pct' t' arr') + +-- --------------------------------------------------------------------- + markAnnCloseP :: (Monad m, Monoid w) => EpAnn AnnPragma -> EP w m (EpAnn AnnPragma) markAnnCloseP an = markEpAnnLMS' an lapr_close AnnClose (Just "#-}") @@ -727,13 +744,6 @@ -- --------------------------------------------------------------------- -- Lenses -lalLet :: Lens AnnsLet EpaLocation -lalLet k annsLet = fmap (\newLoc -> annsLet { alLet = newLoc }) - (k (alLet annsLet)) - -lalIn :: Lens AnnsLet EpaLocation -lalIn k annsLet = fmap (\newLoc -> annsLet { alIn = newLoc }) - (k (alIn annsLet)) -- data AnnsModule -- = AnnsModule { -- am_main :: [AddEpAnn], @@ -930,13 +940,13 @@ -- ap_close :: EpaLocation -- } deriving (Data) -lap_open :: Lens AnnParen EpaLocation -lap_open k parent = fmap (\new -> parent { ap_open = new }) - (k (ap_open parent)) +-- lap_open :: Lens AnnParen EpaLocation +-- lap_open k parent = fmap (\new -> parent { ap_open = new }) +-- (k (ap_open parent)) -lap_close :: Lens AnnParen EpaLocation -lap_close k parent = fmap (\new -> parent { ap_close = new }) - (k (ap_close parent)) +-- lap_close :: Lens AnnParen EpaLocation +-- lap_close k parent = fmap (\new -> parent { ap_close = new }) +-- (k (ap_close parent)) -- ------------------------------------- -- data EpAnnHsCase = EpAnnHsCase @@ -1190,9 +1200,6 @@ markKwT (AddSemiAnn ss) = AddSemiAnn <$> markKwA AnnSemi ss markKwT (AddCommaAnn ss) = AddCommaAnn <$> markKwA AnnComma ss markKwT (AddVbarAnn ss) = AddVbarAnn <$> markKwA AnnVbar ss -markKwT (AddRarrowAnn ss) = AddRarrowAnn <$> markKwA AnnRarrow ss -markKwT (AddRarrowAnnU ss) = AddRarrowAnnU <$> markKwA AnnRarrowU ss -markKwT (AddLollyAnnU ss) = AddLollyAnnU <$> markKwA AnnLollyU ss -- --------------------------------------------------------------------- @@ -1342,7 +1349,6 @@ -- Start of ExactPrint instances -- --------------------------------------------------------------------- - -- | Bare Located elements are simply stripped off without further -- processing. instance (ExactPrint a) => ExactPrint (Located a) where @@ -1364,6 +1370,13 @@ ann' <- markALocatedA (ann la) return (L (la { ann = ann'}) a') +instance (ExactPrint a) => ExactPrint (LocatedAn NoEpAnns a) where + getAnnotationEntry = entryFromLocatedA + setAnnotationAnchor la anc cs = setAnchorAn la anc cs + exact (L la a) = do + a' <- markAnnotated a + return (L la a') + instance (ExactPrint a) => ExactPrint [a] where getAnnotationEntry = const NoEntryVal setAnnotationAnchor ls _ _ = ls @@ -1379,15 +1392,12 @@ -- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' instance ExactPrint HsModule where getAnnotationEntry hsmod = fromAnn' (hsmodAnn hsmod) - -- A bit pointless actually changing anything here setAnnotationAnchor hsmod anc cs = setAnchorHsModule hsmod anc cs `debug` ("setAnnotationAnchor hsmod called" ++ showAst (anc,cs)) exact hsmod@(HsModule EpAnnNotUsed _ _ _ _ _ _ _) = withPpr hsmod >> return hsmod exact (HsModule an lo mmn mexports imports decls mdeprec mbDoc) = do - debugM "HsModule Entered" - mbDoc' <- markAnnotated mbDoc (an0, mmn' , mdeprec', mexports') <- @@ -1401,9 +1411,7 @@ mexports' <- setLayoutTopLevelP $ markAnnotated mexports - debugM $ "HsModule.AnnWhere coming" an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere - debugM $ "HsModule.AnnWhere done, an1=" ++ showAst (anns an1) return (an1, Just m', mdeprec', mexports') @@ -1433,7 +1441,7 @@ -- --------------------------------------------------------------------- -instance ExactPrint (LocatedP WarningTxt) where +instance ExactPrint (LocatedP (WarningTxt GhcPs)) where getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn @@ -1490,10 +1498,9 @@ _ -> return ann1 ann3 <- case mpkg of - Just (StringLiteral src' v _) -> + RawPkgQual (StringLiteral src' v _) -> printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) _ -> return ann2 - m' <- markAnnotated m ann4 <- @@ -1530,8 +1537,17 @@ instance ExactPrint HsDocString where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ = a - exact = withPpr -- TODO:AZ use annotations + exact ds = do + (printStringAdvance . exactPrintHsDocString) ds + return ds +instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ = a + exact (WithHsDocIdentifiers ds ids) = do + ds' <- exact ds + return (WithHsDocIdentifiers ds' ids) + -- --------------------------------------------------------------------- instance ExactPrint (HsDecl GhcPs) where @@ -1572,20 +1588,19 @@ -- --------------------------------------------------------------------- instance ExactPrint (InstDecl GhcPs) where - getAnnotationEntry (ClsInstD _ _) = NoEntryVal - getAnnotationEntry (DataFamInstD an _) = fromAnn an - getAnnotationEntry (TyFamInstD _ _) = NoEntryVal + getAnnotationEntry (ClsInstD _ _) = NoEntryVal + getAnnotationEntry (DataFamInstD _ _) = NoEntryVal + getAnnotationEntry (TyFamInstD _ _) = NoEntryVal - setAnnotationAnchor (DataFamInstD an d) anc cs = DataFamInstD (setAnchorEpa an anc cs) d setAnnotationAnchor d _ _ = d exact (ClsInstD a cid) = do cid' <- markAnnotated cid return (ClsInstD a cid') - exact (DataFamInstD an decl) = do - d' <- markAnnotated (DataFamInstDeclWithContext an TopLevel decl) - return (DataFamInstD an (dc_d d')) + exact (DataFamInstD x decl) = do + d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl) + return (DataFamInstD x (dc_d d')) exact (TyFamInstD a eqn) = do eqn' <- markAnnotated eqn return (TyFamInstD a eqn') @@ -1594,7 +1609,7 @@ data DataFamInstDeclWithContext = DataFamInstDeclWithContext - { _dc_a :: EpAnn [AddEpAnn] + { _dc_a :: EpAnn [AddEpAnn] -- TODO: remove this field , _dc_f :: TopLevelFlag , dc_d :: DataFamInstDecl GhcPs } @@ -1622,6 +1637,7 @@ , feqn_fixity = fixity , feqn_rhs = defn })) = do (an', an2', tycon', bndrs', _, _mc, defn') <- exactDataDefn an2 pp_hdr defn + -- See Note [an and an2 in exactDataFamInstDecl] return (an', DataFamInstDecl ( FamEqn { feqn_ext = an2' @@ -1648,7 +1664,6 @@ {- Note [an and an2 in exactDataFamInstDecl] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ - The exactDataFamInstDecl function is called to render a DataFamInstDecl within its surrounding context. This context is rendered via the 'pp_hdr' function, which uses the exact print @@ -1877,19 +1892,15 @@ -- --------------------------------------------------------------------- -instance ExactPrint DocDecl where +instance ExactPrint (DocDecl GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact v = - let str = - case v of - (DocCommentNext ds) -> unpackHDS ds - (DocCommentPrev ds) -> unpackHDS ds - (DocCommentNamed _s ds) -> unpackHDS ds - (DocGroup _i ds) -> unpackHDS ds - in - printStringAdvance str >> return v + exact v = case v of + (DocCommentNext ds) -> DocCommentNext <$> exact ds + (DocCommentPrev ds) -> DocCommentPrev <$> exact ds + (DocCommentNamed s ds) -> DocCommentNamed s <$> exact ds + (DocGroup i ds) -> DocGroup i <$> exact ds -- --------------------------------------------------------------------- @@ -1904,7 +1915,7 @@ (L _ r') <- markAnnotated (L l r) return (L l (Just r')) markRole (L l Nothing) = do - printStringAtSs l "_" + printStringAtSs (locA l) "_" return (L l Nothing) roles' <- mapM markRole roles return (RoleAnnotDecl an1 ltycon' roles') @@ -2104,7 +2115,6 @@ getAnnotationEntry FunBind{} = NoEntryVal getAnnotationEntry PatBind{pat_ext=an} = fromAnn an getAnnotationEntry VarBind{} = NoEntryVal - getAnnotationEntry AbsBinds{} = NoEntryVal getAnnotationEntry PatSynBind{} = NoEntryVal setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs} @@ -2253,6 +2263,9 @@ CaseAlt -> do pats' <- markAnnotated pats return (an, CaseAlt, pats') + LamCaseAlt v -> do + pats' <- markAnnotated pats + return (an, LamCaseAlt v, pats') _ -> do mctxt' <- withPpr mctxt return (an, mctxt', pats) @@ -2379,13 +2392,12 @@ getAnnotationEntry (IPBind an _ _) = fromAnn an setAnnotationAnchor (IPBind an a b) anc cs = IPBind (setAnchorEpa an anc cs) a b - exact (IPBind an (Left lr) rhs) = do + exact (IPBind an lr rhs) = do lr' <- markAnnotated lr an0 <- markEpAnnL an lidl AnnEqual rhs' <- markAnnotated rhs - return (IPBind an0 (Left lr') rhs') + return (IPBind an0 lr' rhs') - exact (IPBind _ (Right _) _) = error $ "ExactPrint IPBind: Right only after typechecker" -- --------------------------------------------------------------------- @@ -2666,19 +2678,18 @@ instance ExactPrint (HsExpr GhcPs) where getAnnotationEntry (HsVar{}) = NoEntryVal getAnnotationEntry (HsUnboundVar an _) = fromAnn an - getAnnotationEntry (HsConLikeOut{}) = NoEntryVal - getAnnotationEntry (HsRecFld{}) = NoEntryVal + getAnnotationEntry (HsRecSel{}) = NoEntryVal getAnnotationEntry (HsOverLabel an _) = fromAnn an getAnnotationEntry (HsIPVar an _) = fromAnn an getAnnotationEntry (HsOverLit an _) = fromAnn an getAnnotationEntry (HsLit an _) = fromAnn an getAnnotationEntry (HsLam _ _) = NoEntryVal - getAnnotationEntry (HsLamCase an _) = fromAnn an + getAnnotationEntry (HsLamCase an _ _) = fromAnn an getAnnotationEntry (HsApp an _ _) = fromAnn an getAnnotationEntry (HsAppType _ _ _) = NoEntryVal getAnnotationEntry (OpApp an _ _ _) = fromAnn an getAnnotationEntry (NegApp an _ _) = fromAnn an - getAnnotationEntry (HsPar an _) = fromAnn an + getAnnotationEntry (HsPar an _ _ _) = fromAnn an getAnnotationEntry (SectionL an _ _) = fromAnn an getAnnotationEntry (SectionR an _ _) = fromAnn an getAnnotationEntry (ExplicitTuple an _ _) = fromAnn an @@ -2686,7 +2697,7 @@ getAnnotationEntry (HsCase an _ _) = fromAnn an getAnnotationEntry (HsIf an _ _ _) = fromAnn an getAnnotationEntry (HsMultiIf an _) = fromAnn an - getAnnotationEntry (HsLet an _ _) = fromAnn an + getAnnotationEntry (HsLet an _ _ _ _) = fromAnn an getAnnotationEntry (HsDo an _ _) = fromAnn an getAnnotationEntry (ExplicitList an _) = fromAnn an getAnnotationEntry (RecordCon an _ _) = fromAnn an @@ -2695,31 +2706,27 @@ getAnnotationEntry (HsProjection an _) = fromAnn an getAnnotationEntry (ExprWithTySig an _ _) = fromAnn an getAnnotationEntry (ArithSeq an _ _) = fromAnn an - getAnnotationEntry (HsBracket an _) = fromAnn an - getAnnotationEntry (HsRnBracketOut{}) = NoEntryVal - getAnnotationEntry (HsTcBracketOut{}) = NoEntryVal + getAnnotationEntry (HsTypedBracket an _) = fromAnn an + getAnnotationEntry (HsUntypedBracket an _) = fromAnn an getAnnotationEntry (HsSpliceE an _) = fromAnn an getAnnotationEntry (HsProc an _ _) = fromAnn an getAnnotationEntry (HsStatic an _) = fromAnn an - getAnnotationEntry (HsTick {}) = NoEntryVal - getAnnotationEntry (HsBinTick {}) = NoEntryVal getAnnotationEntry (HsPragE{}) = NoEntryVal setAnnotationAnchor a@(HsVar{}) _ _s = a setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsConLikeOut{}) _ _s = a - setAnnotationAnchor a@(HsRecFld{}) _ _s = a + setAnnotationAnchor a@(HsRecSel{}) _ _s = a setAnnotationAnchor (HsOverLabel an a) anc cs = (HsOverLabel (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsIPVar an a) anc cs = (HsIPVar (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsOverLit an a) anc cs = (HsOverLit (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsLit an a) anc cs = (HsLit (setAnchorEpa an anc cs) a) setAnnotationAnchor a@(HsLam _ _) _ _s = a - setAnnotationAnchor (HsLamCase an a) anc cs = (HsLamCase (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsLamCase an a b) anc cs = (HsLamCase (setAnchorEpa an anc cs) a b) setAnnotationAnchor (HsApp an a b) anc cs = (HsApp (setAnchorEpa an anc cs) a b) setAnnotationAnchor a@(HsAppType _ _ _) _ _s = a setAnnotationAnchor (OpApp an a b c) anc cs = (OpApp (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (NegApp an a b) anc cs = (NegApp (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsPar an a) anc cs = (HsPar (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsPar an a b c) anc cs = (HsPar (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (SectionL an a b) anc cs = (SectionL (setAnchorEpa an anc cs) a b) setAnnotationAnchor (SectionR an a b) anc cs = (SectionR (setAnchorEpa an anc cs) a b) setAnnotationAnchor (ExplicitTuple an a b) anc cs = (ExplicitTuple (setAnchorEpa an anc cs) a b) @@ -2727,7 +2734,7 @@ setAnnotationAnchor (HsCase an a b) anc cs = (HsCase (setAnchorEpa an anc cs) a b) setAnnotationAnchor (HsIf an a b c) anc cs = (HsIf (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (HsMultiIf an a) anc cs = (HsMultiIf (setAnchorEpa an anc cs) a) - setAnnotationAnchor (HsLet an a b) anc cs = (HsLet (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsLet an a b c d) anc cs = (HsLet (setAnchorEpa an anc cs) a b c d) setAnnotationAnchor (HsDo an a b) anc cs = (HsDo (setAnchorEpa an anc cs) a b) setAnnotationAnchor (ExplicitList an a) anc cs = (ExplicitList (setAnchorEpa an anc cs) a) setAnnotationAnchor (RecordCon an a b) anc cs = (RecordCon (setAnchorEpa an anc cs) a b) @@ -2736,14 +2743,11 @@ setAnnotationAnchor (HsProjection an a) anc cs = (HsProjection (setAnchorEpa an anc cs) a) setAnnotationAnchor (ExprWithTySig an a b) anc cs = (ExprWithTySig (setAnchorEpa an anc cs) a b) setAnnotationAnchor (ArithSeq an a b) anc cs = (ArithSeq (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsBracket an a) anc cs = (HsBracket (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsRnBracketOut{}) _ _s = a - setAnnotationAnchor a@(HsTcBracketOut{}) _ _s = a + setAnnotationAnchor (HsTypedBracket an a) anc cs = (HsTypedBracket (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsUntypedBracket an a) anc cs = (HsUntypedBracket (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsSpliceE an a) anc cs = (HsSpliceE (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsProc an a b) anc cs = (HsProc (setAnchorEpa an anc cs) a b) setAnnotationAnchor (HsStatic an a) anc cs = (HsStatic (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsTick {}) _ _s = a - setAnnotationAnchor a@(HsBinTick {}) _ _s = a setAnnotationAnchor a@(HsPragE{}) _ _s = a exact (HsVar x n) = do @@ -2757,8 +2761,7 @@ printStringAtAA l "_" >> return () printStringAtAA cb "`" >> return () return x - -- exact x@(HsConLikeOut{}) = withPpr x - -- exact x@(HsRecFld{}) = withPpr x + -- exact x@(HsRecSel{}) = withPpr x exact x@(HsOverLabel _ _) = withPpr x exact x@(HsIPVar _ (HsIPName n)) @@ -2781,11 +2784,12 @@ mg' <- markAnnotated mg return (HsLam x mg') - exact (HsLamCase an mg) = do + exact (HsLamCase an lc_variant mg) = do an0 <- markEpAnnL an lidl AnnLam - an1 <- markEpAnnL an0 lidl AnnCase + an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase + LamCases -> AnnCases) mg' <- markAnnotated mg - return (HsLamCase an1 mg') + return (HsLamCase an1 lc_variant mg') exact (HsApp an e1 e2) = do p <- getPosP @@ -2809,13 +2813,13 @@ e' <- markAnnotated e return (NegApp an0 e' s) - exact (HsPar an e) = do - an0 <- markOpeningParen an + exact (HsPar an lpar e rpar) = do + lpar' <- markToken lpar e' <- markAnnotated e debugM $ "HsPar closing paren" - an1 <- markClosingParen an0 + rpar' <- markToken rpar debugM $ "HsPar done" - return (HsPar an1 e') + return (HsPar an lpar' e' rpar') exact (SectionL an expr op) = do expr' <- markAnnotated expr @@ -2874,16 +2878,16 @@ an2 <- markEpAnnL an1 lidl AnnCloseC -- optional return (HsMultiIf an2 mg') - exact (HsLet an binds e) = do + exact (HsLet an tkLet binds tkIn e) = do setLayoutBoth $ do -- Make sure the 'in' gets indented too - an0 <- markLensKw an lalLet AnnLet + tkLet' <- markToken tkLet debugM $ "HSlet:binds coming" binds' <- setLayoutBoth $ markAnnotated binds debugM $ "HSlet:binds done" - an1 <- markLensKw an0 lalIn AnnIn + tkIn' <- markToken tkIn debugM $ "HSlet:expr coming" e' <- markAnnotated e - return (HsLet an1 binds' e') + return (HsLet an tkLet' binds' tkIn' e') exact (HsDo an do_or_list_comp stmts) = do debugM $ "HsDo" @@ -2915,7 +2919,7 @@ return (HsGetField an expr' field') exact (HsProjection an flds) = do an0 <- markAnnKwL an lapOpen AnnOpenP - flds' <- markAnnotated flds + flds' <- mapM markAnnotated flds an1 <- markAnnKwL an0 lapClose AnnCloseP return (HsProjection an1 flds') exact (ExprWithTySig an expr sig) = do @@ -2952,36 +2956,43 @@ an2 <- markEpAnnL an1 lidl AnnCloseS -- ']' return (ArithSeq an2 s seqInfo') - exact (HsBracket an (ExpBr a e)) = do - an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|" + + exact (HsTypedBracket an e) = do + an0 <- markEpAnnLMS an lidl AnnOpen (Just "[||") + an1 <- markEpAnnLMS an0 lidl AnnOpenE (Just "[e||") + e' <- markAnnotated e + an2 <- markEpAnnLMS an1 lidl AnnClose (Just "||]") + return (HsTypedBracket an2 e') + + exact (HsUntypedBracket an (ExpBr a e)) = do + an0 <- markEpAnnL an lidl AnnOpenEQ -- "[|" an1 <- markEpAnnL an0 lidl AnnOpenE -- "[e|" -- optional e' <- markAnnotated e an2 <- markEpAnnL an1 lidl AnnCloseQ -- "|]" - return (HsBracket an2 (ExpBr a e')) - exact (HsBracket an (PatBr a e)) = do + return (HsUntypedBracket an2 (ExpBr a e')) + + exact (HsUntypedBracket an (PatBr a e)) = do an0 <- markEpAnnLMS an lidl AnnOpen (Just "[p|") e' <- markAnnotated e an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" - return (HsBracket an1 (PatBr a e')) - exact (HsBracket an (DecBrL a e)) = do + return (HsUntypedBracket an1 (PatBr a e')) + + exact (HsUntypedBracket an (DecBrL a e)) = do an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|") - -- See https://gitlab.haskell.org/ghc/ghc/-/issues/20257, we need - -- to mark braces here for the time being - an1 <- markEpAnnL an0 lidl AnnOpenC -- "{" + an1 <- markEpAnnL an0 lidl AnnOpenC -- "{" -- optional e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseC -- "}" + an2 <- markEpAnnL an1 lidl AnnCloseC -- "}" -- optional an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]" - return (HsBracket an3 (DecBrL a e')) - -- -- exact (HsBracket an (DecBrG _ _)) = - -- -- traceM "warning: DecBrG introduced after renamer" - exact (HsBracket an (TypBr a e)) = do + return (HsUntypedBracket an3 (DecBrL a e')) + + exact (HsUntypedBracket an (TypBr a e)) = do an0 <- markEpAnnLMS an lidl AnnOpen (Just "[t|") e' <- markAnnotated e an1 <- markEpAnnL an0 lidl AnnCloseQ -- "|]" - return (HsBracket an1 (TypBr a e')) - exact (HsBracket an (VarBr a b e)) = do - (an0, e') <- - if b + return (HsUntypedBracket an1 (TypBr a e')) + + exact (HsUntypedBracket an (VarBr a b e)) = do + (an0, e') <- if b then do an' <- markEpAnnL an lidl AnnSimpleQuote e' <- markAnnotated e @@ -2990,17 +3001,8 @@ an' <- markEpAnnL an lidl AnnThTyQuote e' <- markAnnotated e return (an', e') - return (HsBracket an0 (VarBr a b e')) - exact (HsBracket an (TExpBr a e)) = do - an0 <- markEpAnnLMS an lidl AnnOpen (Just "[||") - an1 <- markEpAnnLMS an0 lidl AnnOpenE (Just "[e||") - e' <- markAnnotated e - an2 <- markEpAnnLMS an1 lidl AnnClose (Just "||]") - return (HsBracket an2 (TExpBr a e')) - + return (HsUntypedBracket an0 (VarBr a b e')) - -- exact x@(HsRnBracketOut{}) = withPpr x - -- exact x@(HsTcBracketOut{}) = withPpr x exact (HsSpliceE a sp) = do sp' <- markAnnotated sp return (HsSpliceE a sp') @@ -3019,8 +3021,6 @@ e' <- markAnnotated e return (HsStatic an0 e') - -- exact x@(HsTick {}) = withPpr x - -- exact x@(HsBinTick {}) = withPpr x exact (HsPragE a prag e) = do prag' <- markAnnotated prag e' <- markAnnotated e @@ -3030,15 +3030,13 @@ -- --------------------------------------------------------------------- exactDo :: (Monad m, Monoid w, ExactPrint (LocatedAn an a)) - => EpAnn AnnList -> HsStmtContext any -> LocatedAn an a + => EpAnn AnnList -> HsDoFlavour -> LocatedAn an a -> EP w m (EpAnn AnnList, LocatedAn an a) exactDo an (DoExpr m) stmts = exactMdo an m AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts exactDo an GhciStmtCtxt stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts -exactDo an ArrowExpr stmts = markEpAnnL an lal_rest AnnDo >>= \an0 -> markMaybeDodgyStmts an0 stmts exactDo an (MDoExpr m) stmts = exactMdo an m AnnMdo >>= \an0 -> markMaybeDodgyStmts an0 stmts exactDo an ListComp stmts = markMaybeDodgyStmts an stmts exactDo an MonadComp stmts = markMaybeDodgyStmts an stmts -exactDo _ _ _ = panic "pprDo" -- PatGuard, ParStmtCxt exactMdo :: (Monad m, Monoid w) => EpAnn AnnList -> Maybe ModuleName -> AnnKeywordId -> EP w m (EpAnn AnnList) @@ -3152,70 +3150,65 @@ -- --------------------------------------------------------------------- instance (ExactPrint body) - => ExactPrint (HsRecField' (FieldOcc GhcPs) body) where - getAnnotationEntry x = fromAnn (hsRecFieldAnn x) - setAnnotationAnchor x anc cs = x { hsRecFieldAnn = setAnchorEpa (hsRecFieldAnn x) anc cs} - exact (HsRecField an f arg isPun) = do - debugM $ "HsRecField" + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldOcc GhcPs)) body) where + getAnnotationEntry x = fromAnn (hfbAnn x) + setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) + exact (HsFieldBind an f arg isPun) = do + debugM $ "HsFieldBind" f' <- markAnnotated f - (an0, arg') <- if isPun - then return (an, arg) - else do - an0 <- markEpAnnL an lidl AnnEqual - arg' <- markAnnotated arg - return (an0, arg') - return (HsRecField an0 f' arg' isPun) + (an0, arg') <- if isPun then return (an, arg) + else do + an0 <- markEpAnnL an lidl AnnEqual + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- instance (ExactPrint body) - => ExactPrint (HsRecField' (FieldLabelStrings GhcPs) body) where - getAnnotationEntry x = fromAnn (hsRecFieldAnn x) - setAnnotationAnchor x anc cs = x { hsRecFieldAnn = setAnchorEpa (hsRecFieldAnn x) anc cs} - exact (HsRecField an f arg isPun) = do - debugM $ "HsRecField FieldLabelStrings" + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (FieldLabelStrings GhcPs)) body) where + getAnnotationEntry x = fromAnn (hfbAnn x) + setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) + + exact (HsFieldBind an f arg isPun) = do + debugM $ "HsFieldBind FieldLabelStrings" f' <- markAnnotated f - (an0, arg') <- if isPun - then return (an, arg) - else do - an0 <- markEpAnnL an lidl AnnEqual - arg' <- markAnnotated arg - return (an0, arg') - return (HsRecField an0 f' arg' isPun) + (an0, arg') <- if isPun then return (an, arg) + else do + an0 <- markEpAnnL an lidl AnnEqual + arg' <- markAnnotated arg + return (an0, arg') + return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- instance (ExactPrint (LocatedA body)) - => ExactPrint (HsRecField' (AmbiguousFieldOcc GhcPs) (LocatedA body)) where - getAnnotationEntry x = fromAnn (hsRecFieldAnn x) - setAnnotationAnchor x anc cs = x { hsRecFieldAnn = setAnchorEpa (hsRecFieldAnn x) anc cs} - exact (HsRecField an f arg isPun) = do + => ExactPrint (HsFieldBind (LocatedAn NoEpAnns (AmbiguousFieldOcc GhcPs)) (LocatedA body)) where + getAnnotationEntry x = fromAnn (hfbAnn x) + setAnnotationAnchor (HsFieldBind an f arg isPun) anc cs = (HsFieldBind (setAnchorEpa an anc cs) f arg isPun) + exact (HsFieldBind an f arg isPun) = do debugM $ "HsRecUpdField" f' <- markAnnotated f an0 <- if isPun then return an - else markEpAnnL an lidl AnnEqual + else markEpAnnL an lidl AnnEqual arg' <- if ((locA $ getLoc arg) == noSrcSpan ) - then return arg - else markAnnotated arg - return (HsRecField an0 f' arg' isPun) + then return arg + else markAnnotated arg + return (HsFieldBind an0 f' arg' isPun) -- --------------------------------------------------------------------- - instance - (ExactPrint (HsRecField' (a GhcPs) body), - ExactPrint (HsRecField' (b GhcPs) body)) + (ExactPrint (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body), + ExactPrint (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)) => ExactPrint - (Either [LocatedA (HsRecField' (a GhcPs) body)] - [LocatedA (HsRecField' (b GhcPs) body)]) where + (Either [LocatedA (HsFieldBind (LocatedAn NoEpAnns (a GhcPs)) body)] + [LocatedA (HsFieldBind (LocatedAn NoEpAnns (b GhcPs)) body)]) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (Left rbinds) = do - rbinds' <- markAnnotated rbinds - return (Left rbinds') - exact (Right pbinds) = do - pbinds' <- markAnnotated pbinds - return (Right pbinds') + exact (Left rbinds) = Left <$> markAnnotated rbinds + exact (Right pbinds) = Right <$> markAnnotated pbinds + -- --------------------------------------------------------------------- instance ExactPrint (FieldLabelStrings GhcPs) where @@ -3225,24 +3218,15 @@ -- --------------------------------------------------------------------- -instance ExactPrint (NonEmpty (Located (HsFieldLabel GhcPs))) where - getAnnotationEntry = const NoEntryVal - setAnnotationAnchor a _ _ = a - exact (h :| t) = do - h' <- markAnnotated h - t' <- markAnnotated t - return (h' :| t') - --- --------------------------------------------------------------------- +instance ExactPrint (DotFieldOcc GhcPs) where + getAnnotationEntry (DotFieldOcc an _) = fromAnn an -instance ExactPrint (HsFieldLabel GhcPs) where - getAnnotationEntry (HsFieldLabel an _) = fromAnn an - setAnnotationAnchor (HsFieldLabel an a) anc cs = HsFieldLabel (setAnchorEpa an anc cs) a + setAnnotationAnchor (DotFieldOcc an a) anc cs = DotFieldOcc (setAnchorEpa an anc cs) a - exact (HsFieldLabel an fs) = do + exact (DotFieldOcc an fs) = do an0 <- markLensKwM an lafDot AnnDot fs' <- markAnnotated fs - return (HsFieldLabel an0 fs') + return (DotFieldOcc an0 fs') -- --------------------------------------------------------------------- @@ -3272,22 +3256,22 @@ getAnnotationEntry (HsCmdArrForm an _ _ _ _ ) = fromAnn an getAnnotationEntry (HsCmdApp an _ _ ) = fromAnn an getAnnotationEntry (HsCmdLam {}) = NoEntryVal - getAnnotationEntry (HsCmdPar an _) = fromAnn an + getAnnotationEntry (HsCmdPar an _ _ _) = fromAnn an getAnnotationEntry (HsCmdCase an _ _) = fromAnn an - getAnnotationEntry (HsCmdLamCase an _) = fromAnn an + getAnnotationEntry (HsCmdLamCase an _ _) = fromAnn an getAnnotationEntry (HsCmdIf an _ _ _ _) = fromAnn an - getAnnotationEntry (HsCmdLet an _ _) = fromAnn an + getAnnotationEntry (HsCmdLet an _ _ _ _) = fromAnn an getAnnotationEntry (HsCmdDo an _) = fromAnn an setAnnotationAnchor (HsCmdArrApp an a b c d) anc cs = (HsCmdArrApp (setAnchorEpa an anc cs) a b c d) setAnnotationAnchor (HsCmdArrForm an a b c d ) anc cs = (HsCmdArrForm (setAnchorEpa an anc cs) a b c d ) setAnnotationAnchor (HsCmdApp an a b ) anc cs = (HsCmdApp (setAnchorEpa an anc cs) a b ) setAnnotationAnchor a@(HsCmdLam {}) _ _s = a - setAnnotationAnchor (HsCmdPar an a) anc cs = (HsCmdPar (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsCmdPar an a b c) anc cs = (HsCmdPar (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (HsCmdCase an a b) anc cs = (HsCmdCase (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (HsCmdLamCase an a) anc cs = (HsCmdLamCase (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsCmdLamCase an a b) anc cs = (HsCmdLamCase (setAnchorEpa an anc cs) a b) setAnnotationAnchor (HsCmdIf an a b c d) anc cs = (HsCmdIf (setAnchorEpa an anc cs) a b c d) - setAnnotationAnchor (HsCmdLet an a b) anc cs = (HsCmdLet (setAnchorEpa an anc cs) a b) + setAnnotationAnchor (HsCmdLet an a b c d) anc cs = (HsCmdLet (setAnchorEpa an anc cs) a b c d) setAnnotationAnchor (HsCmdDo an a) anc cs = (HsCmdDo (setAnchorEpa an anc cs) a) exact (HsCmdArrApp an arr arg o isRightToLeft) = do @@ -3302,11 +3286,10 @@ arg' <- markAnnotated arg an0 <- markKw (anns an) arr' <- markAnnotated arr - let an1 = an{anns = an0} + let an1 = an {anns = an0} return (HsCmdArrApp an1 arr' arg' o isRightToLeft) exact (HsCmdArrForm an e fixity mf cs) = do - -- markLocatedMAA an al_open an0 <- markLensMAA an lal_open (e',cs') <- case (fixity, cs) of (Infix, (arg1:argrest)) -> do @@ -3331,11 +3314,11 @@ match' <- markAnnotated match return (HsCmdLam a match') - exact (HsCmdPar an e) = do - an0 <- markOpeningParen an + exact (HsCmdPar an lpar e rpar) = do + lpar' <- markToken lpar e' <- markAnnotated e - an1 <- markClosingParen an0 - return (HsCmdPar an1 e') + rpar' <- markToken rpar + return (HsCmdPar an lpar' e' rpar') exact (HsCmdCase an e alts) = do an0 <- markLensKw an lhsCaseAnnCase AnnCase @@ -3347,11 +3330,12 @@ an4 <- markEpAnnL an3 lhsCaseAnnsRest AnnCloseC return (HsCmdCase an4 e' alts') - exact (HsCmdLamCase an matches) = do + exact (HsCmdLamCase an lc_variant matches) = do an0 <- markEpAnnL an lidl AnnLam - an1 <- markEpAnnL an0 lidl AnnCase + an1 <- markEpAnnL an0 lidl (case lc_variant of LamCase -> AnnCase + LamCases -> AnnCases) matches' <- markAnnotated matches - return (HsCmdLamCase an1 matches') + return (HsCmdLamCase an1 lc_variant matches') exact (HsCmdIf an a e1 e2 e3) = do an0 <- markLensKw an laiIf AnnIf @@ -3364,12 +3348,13 @@ e3' <- markAnnotated e3 return (HsCmdIf an4 a e1' e2' e3') - exact (HsCmdLet an binds e) = do - an0 <- markLensKw an lalLet AnnLet - binds' <- markAnnotated binds - an1 <- markLensKw an0 lalIn AnnIn - e' <- markAnnotated e - return (HsCmdLet an1 binds' e') + exact (HsCmdLet an tkLet binds tkIn e) = do + setLayoutBoth $ do -- Make sure the 'in' gets indented too + tkLet' <- markToken tkLet + binds' <- setLayoutBoth $ markAnnotated binds + tkIn' <- markToken tkIn + e' <- markAnnotated e + return (HsCmdLet an tkLet' binds' tkIn' e') exact (HsCmdDo an es) = do debugM $ "HsCmdDo" @@ -3377,8 +3362,6 @@ es' <- markAnnotated es return (HsCmdDo an0 es') - -- exact x = error $ "exact HsCmd for:" ++ showAst x - -- --------------------------------------------------------------------- instance ( @@ -3845,7 +3828,7 @@ getAnnotationEntry (HsListTy an _) = fromAnn an getAnnotationEntry (HsTupleTy an _ _) = fromAnn an getAnnotationEntry (HsSumTy an _) = fromAnn an - getAnnotationEntry (HsOpTy _ _ _ _) = NoEntryVal + getAnnotationEntry (HsOpTy an _ _ _ _) = fromAnn an getAnnotationEntry (HsParTy an _) = fromAnn an getAnnotationEntry (HsIParamTy an _ _) = fromAnn an getAnnotationEntry (HsStarTy _ _) = NoEntryVal @@ -3869,7 +3852,7 @@ setAnnotationAnchor (HsListTy an a) anc cs = (HsListTy (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsTupleTy an a b) anc cs = (HsTupleTy (setAnchorEpa an anc cs) a b) setAnnotationAnchor (HsSumTy an a) anc cs = (HsSumTy (setAnchorEpa an anc cs) a) - setAnnotationAnchor a@(HsOpTy _ _ _ _) _ _s = a + setAnnotationAnchor a@(HsOpTy _ _ _ _ _) _ _s = a setAnnotationAnchor (HsParTy an a) anc cs = (HsParTy (setAnchorEpa an anc cs) a) setAnnotationAnchor (HsIParamTy an a b) anc cs = (HsIParamTy (setAnchorEpa an anc cs) a b) setAnnotationAnchor a@(HsStarTy _ _) _ _s = a @@ -3912,9 +3895,9 @@ return (HsAppKindTy ss ty' ki') exact (HsFunTy an mult ty1 ty2) = do ty1' <- markAnnotated ty1 - (an', mult') <- markArrow an mult + mult' <- markArrow mult ty2' <- markAnnotated ty2 - return (HsFunTy an' mult' ty1' ty2') + return (HsFunTy an mult' ty1' ty2') exact (HsListTy an tys) = do an0 <- markOpeningParen an tys' <- markAnnotated tys @@ -3930,11 +3913,14 @@ tys' <- markAnnotated tys an1 <- markClosingParen an0 return (HsSumTy an1 tys') - exact (HsOpTy an t1 lo t2) = do + exact (HsOpTy an promoted t1 lo t2) = do + an0 <- if (isPromoted promoted) + then markEpAnnL an lidl AnnSimpleQuote + else return an t1' <- markAnnotated t1 lo' <- markAnnotated lo t2' <- markAnnotated t2 - return (HsOpTy an t1' lo' t2') + return (HsOpTy an0 promoted t1' lo' t2') exact (HsParTy an ty) = do an0 <- markOpeningParen an ty' <- markAnnotated ty @@ -3958,7 +3944,6 @@ exact (HsSpliceTy a splice) = do splice' <- markAnnotated splice return (HsSpliceTy a splice') - -- exact x@(HsDocTy an _ _) = withPpr x exact (HsBangTy an (HsSrcBang mt up str) ty) = do an0 <- case mt of @@ -3976,7 +3961,6 @@ NoSrcStrict -> return an0 ty' <- markAnnotated ty return (HsBangTy an1 (HsSrcBang mt up str) ty') - -- exact x@(HsRecTy an _) = withPpr x exact (HsExplicitListTy an prom tys) = do an0 <- if (isPromoted prom) then markEpAnnL an lidl AnnSimpleQuote @@ -4113,7 +4097,7 @@ setAnnotationAnchor = setAnchorAn exact x@(L (SrcSpanAnn EpAnnNotUsed l) n) = do - printUnicode (spanAsAnchor l) n + _ <- printUnicode (spanAsAnchor l) n return x exact (L (SrcSpanAnn (EpAnn anc ann cs) ll) n) = do ann' <- @@ -4132,6 +4116,13 @@ (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) t' <- markTrailing t return (NameAnnCommas a o' commas' c' t') + NameAnnBars a o bars c t -> do + let (kwo,kwc) = adornments a + (AddEpAnn _ o') <- markKwC NoCaptureComments (AddEpAnn kwo o) + bars' <- forM bars (\loc -> locFromAdd <$> markKwC NoCaptureComments (AddEpAnn AnnVbar loc)) + (AddEpAnn _ c') <- markKwC NoCaptureComments (AddEpAnn kwc c) + t' <- markTrailing t + return (NameAnnBars a o' bars' c' t') NameAnnOnly a o c t -> do (o',_,c') <- markName a o Nothing c t' <- markTrailing t @@ -4147,7 +4138,7 @@ t' <- markTrailing t return (NameAnnQuote q' name' t') NameAnnTrailing t -> do - anc' <- printUnicode anc n + _anc' <- printUnicode anc n t' <- markTrailing t return (NameAnnTrailing t') return (L (SrcSpanAnn (EpAnn anc ann' cs) ll) n) @@ -4304,11 +4295,12 @@ args' <- case args of (PrefixConGADT args0) -> do - args0' <- mapM markScaled args0 + args0' <- mapM markAnnotated args0 return (PrefixConGADT args0') - (RecConGADT fields) -> do + (RecConGADT fields rarr) -> do fields' <- markAnnotated fields - return (RecConGADT fields') + rarr' <- markUniToken rarr + return (RecConGADT fields' rarr') res_ty' <- markAnnotated res_ty return (ConDeclGADT { con_g_ext = an2 , con_names = cons' @@ -4370,20 +4362,12 @@ -- --------------------------------------------------------------------- -markScaled :: (Monad m, Monoid w) - => HsScaled GhcPs (LBangType GhcPs) -> EP w m (HsScaled GhcPs (LBangType GhcPs)) -markScaled (HsScaled arr (L l c)) = do - (L l1 (HsScaled arr' (L l2 c'))) <- markAnnotated (L l (HsScaled arr (L (noAnnSrcSpan $ locA l) c)) - :: LocatedA (HsScaled GhcPs (LBangType GhcPs))) - let l' = l1 <> l2 - return (HsScaled arr' (L l' c')) - instance (ExactPrint a) => ExactPrint (HsScaled GhcPs a) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a exact (HsScaled arr t) = do t' <- markAnnotated t - (_, arr') <- markArrow EpAnnNotUsed arr + arr' <- markArrow arr return (HsScaled arr' t') -- --------------------------------------------------------------------- @@ -4562,9 +4546,6 @@ m' <- markAnnotated m return (IEModuleContents an0 m') - -- exact (IEGroup _ _ _) = NoEntryVal - -- exact (IEDoc _ _) = NoEntryVal - -- exact (IEDocNamed _ _) = NoEntryVal exact x = error $ "missing match for IE:" ++ showAst x -- --------------------------------------------------------------------- @@ -4592,7 +4573,7 @@ getAnnotationEntry (VarPat _ _) = NoEntryVal getAnnotationEntry (LazyPat an _) = fromAnn an getAnnotationEntry (AsPat an _ _) = fromAnn an - getAnnotationEntry (ParPat an _) = fromAnn an + getAnnotationEntry (ParPat an _ _ _) = fromAnn an getAnnotationEntry (BangPat an _) = fromAnn an getAnnotationEntry (ListPat an _) = fromAnn an getAnnotationEntry (TuplePat an _ _) = fromAnn an @@ -4609,15 +4590,15 @@ setAnnotationAnchor a@(VarPat _ _) _ _s = a setAnnotationAnchor (LazyPat an a) anc cs = (LazyPat (setAnchorEpa an anc cs) a) setAnnotationAnchor (AsPat an a b) anc cs = (AsPat (setAnchorEpa an anc cs) a b) - setAnnotationAnchor (ParPat an a) anc cs = (ParPat (setAnchorEpa an anc cs) a) + setAnnotationAnchor (ParPat an a b c) anc cs = (ParPat (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (BangPat an a) anc cs = (BangPat (setAnchorEpa an anc cs) a) setAnnotationAnchor (ListPat an a) anc cs = (ListPat (setAnchorEpa an anc cs) a) setAnnotationAnchor (TuplePat an a b) anc cs = (TuplePat (setAnchorEpa an anc cs) a b) setAnnotationAnchor (SumPat an a b c) anc cs = (SumPat (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (ConPat an a b) anc cs = (ConPat (setAnchorEpa an anc cs) a b) setAnnotationAnchor (ViewPat an a b) anc cs = (ViewPat (setAnchorEpa an anc cs) a b) - setAnnotationAnchor a@(SplicePat _ _) _ _s = a - setAnnotationAnchor a@(LitPat _ _) _ _s = a + setAnnotationAnchor a@(SplicePat _ _) _ _s = a + setAnnotationAnchor a@(LitPat _ _) _ _s = a setAnnotationAnchor (NPat an a b c) anc cs = (NPat (setAnchorEpa an anc cs) a b c) setAnnotationAnchor (NPlusKPat an a b c d e) anc cs = (NPlusKPat (setAnchorEpa an anc cs) a b c d e) setAnnotationAnchor (SigPat an a b) anc cs = (SigPat (setAnchorEpa an anc cs) a b) @@ -4644,11 +4625,12 @@ an0 <- markEpAnnL an lidl AnnAt pat' <- markAnnotated pat return (AsPat an0 n' pat') - exact (ParPat an pat) = do - an0 <- markAnnKwL an lap_open AnnOpenP + exact (ParPat an lpar pat rpar) = do + lpar' <- markToken lpar pat' <- markAnnotated pat - an1 <- markAnnKwL an0 lap_close AnnCloseP - return (ParPat an1 pat') + rpar' <- markToken rpar + return (ParPat an lpar' pat' rpar') + exact (BangPat an pat) = do an0 <- markEpAnnL an lidl AnnBang pat' <- markAnnotated pat diff --git a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs --- a/src/Language/Haskell/GHC/ExactPrint/Lookup.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Lookup.hs @@ -19,108 +19,108 @@ case kw of -- Specifically handle all cases so that there are pattern match -- warnings if new constructors are added. - AnnAnyclass -> "anyclass" - AnnOpen -> mkErr kw - AnnClose-> mkErr kw - AnnVal -> mkErr kw - AnnPackageName -> mkErr kw - AnnHeader-> mkErr kw - AnnFunId -> mkErr kw - AnnInfix -> mkErr kw - AnnValStr-> mkErr kw - AnnName -> mkErr kw - AnnAs -> "as" - AnnAt -> "@" - AnnBang -> "!" - AnnBackquote-> "`" - AnnBy -> "by" - AnnCase -> "case" - AnnClass -> "class" - AnnCloseB -> "|)" - AnnCloseBU-> "⦈" - AnnCloseC -> "}" - AnnCloseP -> ")" - AnnClosePH-> "#)" - AnnCloseQ -> "|]" - AnnCloseQU-> "⟧" - AnnCloseS -> "]" - AnnColon -> ":" - AnnComma -> "," - AnnCommaTuple-> "," - AnnDarrow -> "=>" - AnnData -> "data" - AnnDcolon -> "::" - AnnDefault-> "default" - AnnDeriving-> "deriving" - AnnDo -> "do" - AnnDot -> "." - AnnDotdot -> ".." - AnnElse -> "else" - AnnEqual -> "=" - AnnExport -> "export" - AnnFamily -> "family" - AnnForall -> "forall" - AnnForeign -> "foreign" - AnnGroup -> "group" - AnnHiding -> "hiding" - AnnIf -> "if" - AnnImport -> "import" - AnnIn -> "in" - AnnInstance-> "instance" - AnnLam -> "\\" - AnnLarrow -> "<-" - AnnLet -> "let" - AnnLollyU -> "⊸" - AnnMdo -> "mdo" - AnnMinus -> "-" - AnnModule -> "module" - AnnNewtype -> "newtype" - AnnOf -> "of" - AnnOpenB -> "(|" - AnnOpenBU -> "⦇" - AnnOpenC -> "{" - AnnOpenE -> "[e|" - AnnOpenEQ -> "[|" - AnnOpenEQU -> "⟦" - AnnOpenP -> "(" - AnnOpenPH -> "(#" - AnnOpenS -> "[" - AnnPattern -> "pattern" - AnnPercent -> "%" - AnnPercentOne -> "%1" - AnnProc -> "proc" - AnnQualified-> "qualified" - AnnRarrow -> "->" - AnnRec -> "rec" - AnnRole -> "role" - AnnSafe -> "safe" - AnnSemi -> ";" - AnnSignature -> "signature" - AnnStock -> "stock" - AnnStatic -> "static" - AnnThen -> "then" - AnnTilde -> "~" - AnnType -> "type" - AnnUnit -> "()" - AnnUsing -> "using" - AnnVbar -> "|" - AnnWhere -> "where" - Annlarrowtail-> "-<" - Annrarrowtail-> ">-" - AnnLarrowtail-> "-<<" - AnnRarrowtail-> ">>-" - AnnSimpleQuote -> "'" - AnnThTyQuote -> "''" - AnnDollar -> "$" - AnnDollarDollar-> "$$" - AnnDarrowU -> "⇒" - AnnDcolonU -> "∷" - AnnForallU -> "∀" - AnnLarrowU -> "←" - AnnLarrowtailU -> "⤛" - AnnRarrowU -> "→" - AnnRarrowtailU -> "⤜" - AnnlarrowtailU -> "⤙" - AnnrarrowtailU -> "⤚" - -- AnnTypeApp -> "@" - AnnVia -> "via" + AnnAnyclass -> "anyclass" + AnnOpen -> mkErr kw + AnnClose -> mkErr kw + AnnVal -> mkErr kw + AnnPackageName -> mkErr kw + AnnHeader -> mkErr kw + AnnFunId -> mkErr kw + AnnInfix -> mkErr kw + AnnValStr -> mkErr kw + AnnName -> mkErr kw + AnnAs -> "as" + AnnAt -> "@" + AnnBang -> "!" + AnnBackquote -> "`" + AnnBy -> "by" + AnnCase -> "case" + AnnCases -> "cases" + AnnClass -> "class" + AnnCloseB -> "|)" + AnnCloseBU -> "⦈" + AnnCloseC -> "}" + AnnCloseP -> ")" + AnnClosePH -> "#)" + AnnCloseQ -> "|]" + AnnCloseQU -> "⟧" + AnnCloseS -> "]" + AnnColon -> ":" + AnnComma -> "," + AnnCommaTuple -> "," + AnnDarrow -> "=>" + AnnData -> "data" + AnnDcolon -> "::" + AnnDefault -> "default" + AnnDeriving -> "deriving" + AnnDo -> "do" + AnnDot -> "." + AnnDotdot -> ".." + AnnElse -> "else" + AnnEqual -> "=" + AnnExport -> "export" + AnnFamily -> "family" + AnnForall -> "forall" + AnnForeign -> "foreign" + AnnGroup -> "group" + AnnHiding -> "hiding" + AnnIf -> "if" + AnnImport -> "import" + AnnIn -> "in" + AnnInstance -> "instance" + AnnLam -> "\\" + AnnLarrow -> "<-" + AnnLet -> "let" + AnnLollyU -> "⊸" + AnnMdo -> "mdo" + AnnMinus -> "-" + AnnModule -> "module" + AnnNewtype -> "newtype" + AnnOf -> "of" + AnnOpenB -> "(|" + AnnOpenBU -> "⦇" + AnnOpenC -> "{" + AnnOpenE -> "[e|" + AnnOpenEQ -> "[|" + AnnOpenEQU -> "⟦" + AnnOpenP -> "(" + AnnOpenPH -> "(#" + AnnOpenS -> "[" + AnnPattern -> "pattern" + AnnPercent -> "%" + AnnPercentOne -> "%1" + AnnProc -> "proc" + AnnQualified -> "qualified" + AnnRarrow -> "->" + AnnRec -> "rec" + AnnRole -> "role" + AnnSafe -> "safe" + AnnSemi -> ";" + AnnSignature -> "signature" + AnnStock -> "stock" + AnnStatic -> "static" + AnnThen -> "then" + AnnTilde -> "~" + AnnType -> "type" + AnnUnit -> "()" + AnnUsing -> "using" + AnnVbar -> "|" + AnnWhere -> "where" + Annlarrowtail -> "-<" + Annrarrowtail -> ">-" + AnnLarrowtail -> "-<<" + AnnRarrowtail -> ">>-" + AnnSimpleQuote -> "'" + AnnThTyQuote -> "''" + AnnDollar -> "$" + AnnDollarDollar -> "$$" + AnnDarrowU -> "⇒" + AnnDcolonU -> "∷" + AnnForallU -> "∀" + AnnLarrowU -> "←" + AnnLarrowtailU -> "⤛" + AnnRarrowU -> "→" + AnnRarrowtailU -> "⤜" + AnnlarrowtailU -> "⤙" + AnnrarrowtailU -> "⤚" + AnnVia -> "via" 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 @@ -18,7 +18,7 @@ def = mempty instance Default AnnPragma where - def = AnnPragma def def def + def = AnnPragma def def def instance Semigroup EpAnnImportDecl where (<>) = error "unimplemented" @@ -52,9 +52,6 @@ instance Default AnnsIf where def = AnnsIf def def def def def -instance Default AnnsLet where - def = AnnsLet def def - instance Default AnnProjection where def = AnnProjection def def @@ -69,9 +66,6 @@ instance Default AnnKeywordId where def = Annlarrowtail {- gotta pick one -} - -instance Default TrailingAnn where - def = AddLollyAnnU {-gotta pick one -} def instance Default AnnContext where def = AnnContext Nothing [] [] diff --git a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs --- a/src/Language/Haskell/GHC/ExactPrint/Parsers.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Parsers.hs @@ -53,15 +53,17 @@ import qualified Control.Monad.IO.Class as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC -import qualified GHC.Driver.Config as GHC +-- import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Config.Parser as GHC +import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Session as GHC import qualified GHC.Parser as GHC import qualified GHC.Parser.Header as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Parser.PostProcess as GHC -import qualified GHC.Parser.Errors.Ppr as GHC +-- import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Utils.Error as GHC +-- import qualified GHC.Utils.Error as GHC import qualified GHC.LanguageExtensions as LangExt @@ -79,8 +81,10 @@ -> ParseResult w parseWith dflags fileName parser s = case runParser parser dflags fileName s of - GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> Right pmod + GHC.PFailed pst + -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst) + GHC.POk _ pmod + -> Right pmod parseWithECP :: (GHC.DisambECP w) @@ -91,8 +95,10 @@ -> ParseResult (GHC.LocatedA w) parseWithECP dflags fileName parser s = case runParser (parser >>= \p -> GHC.runPV $ GHC.unECP p) dflags fileName s of - GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> Right pmod + GHC.PFailed pst + -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst) + GHC.POk _ pmod + -> Right pmod -- --------------------------------------------------------------------- @@ -184,8 +190,10 @@ parseModuleFromStringInternal dflags fileName str = let (str1, lp) = stripLinePragmas str res = case runParser GHC.parseModule dflags fileName str1 of - GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> Right (lp, dflags, pmod) + GHC.PFailed pst + -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst) + GHC.POk _ pmod + -> Right (lp, dflags, pmod) in postParseTransform res parseModuleWithOptions :: LibDir -- ^ GHC libdir @@ -255,9 +263,10 @@ return (contents1,lp,dflags) return $ case parseFile dflags' file fileContents of - GHC.PFailed pst -> Left (fmap GHC.pprError $ GHC.getErrorMessages pst) - GHC.POk _ pmod -> - Right $ (injectedComments, dflags', fixModuleTrailingComments pmod) + GHC.PFailed pst + -> Left (GHC.GhcPsMessage <$> GHC.getPsErrorMessages pst) + GHC.POk _ pmod + -> Right $ (injectedComments, dflags', fixModuleTrailingComments pmod) -- | Internal function. Exposed if you want to muck with DynFlags -- before parsing. Or after parsing. @@ -300,8 +309,10 @@ -- See ghc tickets #15513, #15541. initDynFlags :: GHC.GhcMonad m => FilePath -> m GHC.DynFlags initDynFlags file = do + -- Based on GHC backpack driver doBackPack dflags0 <- GHC.getSessionDynFlags - src_opts <- GHC.liftIO $ GHC.getOptionsFromFile dflags0 file + let parser_opts0 = GHC.initParserOpts dflags0 + (_, src_opts) <- GHC.liftIO $ GHC.getOptionsFromFile parser_opts0 file (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 src_opts -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream @@ -323,11 +334,13 @@ -- See ghc tickets #15513, #15541. initDynFlagsPure :: GHC.GhcMonad m => FilePath -> String -> m GHC.DynFlags initDynFlagsPure fp s = do + -- AZ Note: "I" below appears to be Lennart Spitzner -- I was told we could get away with using the unsafeGlobalDynFlags. -- as long as `parseDynamicFilePragma` is impure there seems to be -- no reason to use it. dflags0 <- GHC.getSessionDynFlags - let pragmaInfo = GHC.getOptions dflags0 (GHC.stringToStringBuffer $ s) fp + let parser_opts0 = GHC.initParserOpts dflags0 + let (_, pragmaInfo) = GHC.getOptions parser_opts0 (GHC.stringToStringBuffer $ s) fp (dflags1, _, _) <- GHC.parseDynamicFilePragma dflags0 pragmaInfo -- Turn this on last to avoid T10942 let dflags2 = dflags1 `GHC.gopt_set` GHC.Opt_KeepRawTokenStream diff --git a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs --- a/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs +++ b/src/Language/Haskell/GHC/ExactPrint/Preprocess.hs @@ -1,5 +1,6 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -- | This module provides support for CPP, interpreter directives and line -- pragmas. module Language.Haskell.GHC.ExactPrint.Preprocess @@ -11,6 +12,7 @@ , CppOptions(..) , defaultCppOptions + , showErrorMessages ) where import qualified GHC as GHC hiding (parseModule) @@ -19,18 +21,21 @@ import qualified GHC.Data.Bag as GHC import qualified GHC.Data.FastString as GHC import qualified GHC.Data.StringBuffer as GHC -import qualified GHC.Driver.Config as GHC +-- import qualified GHC.Driver.Config as GHC +import qualified GHC.Driver.Config.Parser as GHC import qualified GHC.Driver.Env as GHC +import qualified GHC.Driver.Errors.Types as GHC import qualified GHC.Driver.Phases as GHC import qualified GHC.Driver.Pipeline as GHC import qualified GHC.Fingerprint.Type as GHC -import qualified GHC.Parser.Errors.Ppr as GHC +-- import qualified GHC.Parser.Errors.Ppr as GHC import qualified GHC.Parser.Lexer as GHC import qualified GHC.Settings as GHC import qualified GHC.Types.SourceError as GHC -import qualified GHC.Types.SourceFile as GHC import qualified GHC.Types.SrcLoc as GHC -import qualified GHC.Utils.Error as GHC +import qualified GHC.Types.SourceFile as GHC +import qualified GHC.Types.Error as GHC +-- import qualified GHC.Utils.Error as GHC import qualified GHC.Utils.Fingerprint as GHC import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) import GHC.Data.FastString (mkFastString) @@ -219,15 +224,26 @@ new_env = hsc_env { GHC.hsc_dflags = injectCppOptions cppOptions dfs } r <- GHC.liftIO $ GHC.preprocess new_env src_fn Nothing (Just (GHC.Cpp GHC.HsSrcFile)) case r of - Left err -> error $ showErrorMessages err + Left err -> error $ showErrorMessages $ fmap GHC.GhcDriverMessage err Right (dflags', hspp_fn) -> do buf <- GHC.liftIO $ GHC.hGetStringBuffer hspp_fn txt <- GHC.liftIO $ readFileGhc hspp_fn return (txt, buf, dflags') showErrorMessages :: GHC.ErrorMessages -> String -showErrorMessages msgs = intercalate "\n" $ map show $ GHC.bagToList msgs +showErrorMessages msgs = intercalate "\n" + $ map (show @(GHC.MsgEnvelope GHC.DiagnosticMessage) . fmap toDiagnosticMessage) + $ GHC.bagToList + $ GHC.getErrorMessages msgs +-- | Show Error Messages relies on show instance for MsgEnvelope DiagnosticMessage +-- We convert a known Diagnostic into this generic version +toDiagnosticMessage :: GHC.Diagnostic e => e -> GHC.DiagnosticMessage +toDiagnosticMessage msg = GHC.DiagnosticMessage { diagMessage = GHC.diagnosticMessage msg + , diagReason = GHC.diagnosticReason msg + , diagHints = GHC.diagnosticHints msg + } + injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags injectCppOptions CppOptions{..} dflags = foldr addOptP dflags (map mkDefine cppDefine ++ map mkIncludeDir cppInclude ++ map mkInclude cppFile) @@ -281,7 +297,7 @@ -- (warns,errs) = GHC.getMessages pst dflags -- throw $ GHC.mkSrcErr (GHC.unitBag $ GHC.mkPlainErrMsg dflags sspan err) -- GHC.throwErrors (fmap GHC.mkParserErr (GHC.getErrorMessages pst)) - GHC.throwErrors (fmap GHC.pprError (GHC.getErrorMessages pst)) + GHC.throwErrors (fmap GHC.GhcPsMessage (GHC.getPsErrorMessages pst)) -- --------------------------------------------------------------------- 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 @@ -20,10 +20,8 @@ ----------------------------------------------------------------------------- module Language.Haskell.GHC.ExactPrint.Transform ( - -- * Delta is still here - makeDeltaAst' -- * The Transform Monad - , Transform + Transform , TransformT(..) , hoistTransform , runTransform @@ -100,7 +98,7 @@ import Data.Maybe import Data.Generics -import Data.List (sort, sortBy) +import Data.List (sortBy) import Data.Functor.Identity import Control.Monad.State @@ -215,7 +213,6 @@ rd = case last ns of L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? - -- DP (line, col) = ss2delta (ss2pos $ anchor $ getLoc lc) r dc' = case dca of EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) EpaDelta _ _ -> AddEpAnn kw dca @@ -415,16 +412,22 @@ -- --------------------------------------------------------------------- balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -balanceCommentsList ds = balanceCommentsList'' (map tweakListComments ds) - -balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -balanceCommentsList'' [] = return [] -balanceCommentsList'' [x] = return [x] -balanceCommentsList'' (a:b:ls) = do +balanceCommentsList [] = return [] +balanceCommentsList [x] = return [x] +balanceCommentsList (a:b:ls) = do (a',b') <- balanceComments a b - r <- balanceCommentsList'' (b':ls) + r <- balanceCommentsList (b':ls) return (a':r) +balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a] +balanceCommentsList' [] = return [] +balanceCommentsList' [x] = return [x] +balanceCommentsList' (a:b:ls) = do + logTr $ "balanceCommentsList' entered" + (a',b') <- balanceComments' a b + r <- balanceCommentsList' (b':ls) + return (a':r) + -- |The GHC parser puts all comments appearing between the end of one AST -- item and the beginning of the next as 'annPriorComments' for the second one. -- This function takes two adjacent AST items and moves any 'annPriorComments' @@ -497,8 +500,9 @@ stay = map snd stay' (l'', grhss', binds', logInfo) = case reverse grhss of - [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) - (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs) -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) + [] -> (l, [], binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) + (L lg g@(GRHS EpAnnNotUsed _grs _rhs):gs) + -> (l, reverse (L lg g:gs), binds, (EpaComments [], SrcSpanAnn EpAnnNotUsed noSrcSpan)) (L lg (GRHS ag grs rhs):gs) -> let anc1' = setFollowingComments anc1 stay @@ -509,7 +513,7 @@ -- --------------------------------- (EpAnn anc an lgc) = ag - lgc' = splitCommentsEnd (realSrcSpan lg) $ addCommentOrigDeltas lgc + lgc' = splitCommentsEnd (realSrcSpan $ locA lg) $ addCommentOrigDeltas lgc ag' = if moved then EpAnn anc an lgc' else EpAnn anc an (lgc' <> (EpaCommentsBalanced [] move)) @@ -532,15 +536,6 @@ _ -> (ValBinds NoAnnSortKey emptyBag [], []) -balanceCommentsList' :: (Monad m) => [LocatedA a] -> TransformT m [LocatedA a] -balanceCommentsList' [] = return [] -balanceCommentsList' [x] = return [x] -balanceCommentsList' (a:b:ls) = do - logTr $ "balanceCommentsList' entered" - (a',b') <- balanceComments' a b - r <- balanceCommentsList' (b':ls) - return (a':r) - -- |Prior to moving an AST element, make sure any trailing comments belonging to -- it are attached to it, and not the following element. Of necessity this is a -- heuristic process, to be tuned later. Possibly a variant should be provided @@ -549,27 +544,29 @@ -- Many of these should in fact be following comments for the previous anchor balanceComments' :: (Monad m) => LocatedA a -> LocatedA b -> TransformT m (LocatedA a, LocatedA b) balanceComments' la1 la2 = do - logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) - logTr $ "balanceComments': (anc1)=" ++ showAst (anc1) - logTr $ "balanceComments': (cs1s)=" ++ showAst (cs1s) - logTr $ "balanceComments': (sort cs1f)=" ++ showAst (sort cs1f) - logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) - logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2') + -- logTr $ "balanceComments': (loc1,loc2)=" ++ showGhc (ss2range loc1,ss2range loc2) + -- logTr $ "balanceComments': (anc1)=" ++ showAst (anc1) + -- logTr $ "balanceComments': (cs2p)=" ++ showAst (cs2p) + -- logTr $ "balanceComments': (cs2f)=" ++ showAst (cs2f) + -- logTr $ "balanceComments': (cs1stay,cs1move)=" ++ showAst (cs1stay,cs1move) + -- logTr $ "balanceComments': (an1',an2')=" ++ showAst (an1',an2') return (la1', la2') where simpleBreak n (r,_) = r > n - L (SrcSpanAnn an1 loc1) f = la1 - L (SrcSpanAnn an2 loc2) s = la2 + L (SrcSpanAnn an1 _loc1) f = la1 + L (SrcSpanAnn an2 _loc2) s = la2 anc1 = addCommentOrigDeltas $ epAnnComments an1 anc2 = addCommentOrigDeltas $ epAnnComments an2 - cs1s = splitCommentsEnd (anchorFromLocatedA la1) anc1 - cs1p = priorCommentsDeltas (anchorFromLocatedA la1) (priorComments cs1s) - cs1f = trailingCommentsDeltas (anchorFromLocatedA la1) (getFollowingComments cs1s) + -- Split comments into those before the span, in the span, and after the span + (cs1prior,cs1m,cs1following) = splitCommentsAround (anchorFromLocatedA la1) anc1 + cs1p = priorCommentsDeltas (anchorFromLocatedA la1) cs1prior + cs1f = trailingCommentsDeltas (anchorFromLocatedA la1) cs1following - cs2s = splitCommentsEnd (anchorFromLocatedA la2) anc2 - cs2p = priorCommentsDeltas (anchorFromLocatedA la2) (priorComments cs2s) - cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) (getFollowingComments cs2s) + -- Split comments into those before the span, in the span, and after the span + (cs2prior,cs2m,cs2following) = splitCommentsAround (anchorFromLocatedA la2) anc2 + cs2p = priorCommentsDeltas (anchorFromLocatedA la2) cs2prior + cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) cs2following -- Split cs1f into those that belong on an1 and ones that must move to an2 (cs1move,cs1stay) = break (simpleBreak 1) cs1f @@ -581,11 +578,12 @@ move = sortEpaComments $ map snd (cs1move ++ move'' ++ move') stay = sortEpaComments $ map snd (cs1stay ++ stay') - an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) - an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced stay (map snd cs2f)) + an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced ((map snd cs1p)++cs1m) move) + an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced (cs2m++stay) (map snd cs2f)) la1' = L an1' f la2' = L an2' s + -- | Like commentsDeltas, but calculates the delta from the end of the anchor, not the start trailingCommentsDeltas :: RealSrcSpan -> [LEpaComment] -> [(Int, LEpaComment)] @@ -614,6 +612,8 @@ (ll,_) = ss2pos (anchor loc) +-- --------------------------------------------------------------------- + -- | Split comments into ones occuring before the end of the reference -- span, and those after it. splitCommentsEnd :: RealSrcSpan -> EpAnnComments -> EpAnnComments @@ -631,6 +631,7 @@ cs' = before ts' = after <> ts + -- | Split comments into ones occuring before the start of the reference -- span, and those after it. splitCommentsStart :: RealSrcSpan -> EpAnnComments -> EpAnnComments @@ -648,6 +649,21 @@ cs' = before ts' = after <> ts + +-- | Split comments into ones occuring before the start of the reference +-- span, those in the span, and those after it. +splitCommentsAround :: RealSrcSpan -> EpAnnComments + -> ([LEpaComment], [LEpaComment], [LEpaComment]) +splitCommentsAround p cs = (before,middle,after) + where + all_comments = priorComments cs ++ getFollowingComments cs + cmpbefore (L (Anchor l _) _) = ss2pos l > ss2pos p + cmpafter (L (Anchor l _) _) = ss2pos l > ss2posEnd p + (before, both) = break cmpbefore all_comments + (middle, after) = break cmpafter both + +-- --------------------------------------------------------------------- + moveLeadingComments :: (Data t, Data u, Monoid t, Monoid u) => LocatedAn t a -> SrcAnn u -> (LocatedAn t a, SrcAnn u) moveLeadingComments from@(L (SrcSpanAnn EpAnnNotUsed _) _) to = (from, to) @@ -709,113 +725,15 @@ then MovedAnchor (DifferentLine 1 0) else op' -spanOrigDelta :: RealSrcSpan -> RealSrcSpan -> DeltaPos -spanOrigDelta prior cur = dp - where - (r,c) = ss2posEnd prior - dp = if r == 0 - then (ss2delta (r,c+1) cur) - else (ss2delta (r,c) cur) - -- --------------------------------------------------------------------- --- TODO: Until https://gitlab.haskell.org/ghc/ghc/-/issues/20715 is --- fixed we have to special-case a funbind. Damn. -tweakListComments :: LHsDecl GhcPs -> LHsDecl GhcPs -tweakListComments a@(L _ (ValD _ (FunBind{}))) = tweakListCommentsFB a -tweakListComments a = tweakListComments' a --- A LocatedA item may have both trailing comments and trailing list items. --- Move any relevant comments preceding a list item into an EpaDelta instead. -tweakListComments' :: LocatedA a -> LocatedA a -tweakListComments' (L (SrcSpanAnn EpAnnNotUsed l) a) = L (SrcSpanAnn EpAnnNotUsed l) a -tweakListComments' (L (SrcSpanAnn (EpAnn anc an cs) l) a) = L (SrcSpanAnn (EpAnn anc an' cs') l) a - where - -- Note: until https://gitlab.haskell.org/ghc/ghc/-/issues/20718 is - -- resolved, the comments may be in reverse order. - (an', cs') = case cs of - EpaComments [] -> (an,cs) - EpaComments c -> go (\cc -> EpaComments cc) an (sortEpaComments c) - EpaCommentsBalanced _ [] -> (an,cs) - EpaCommentsBalanced p c -> go (\cc -> EpaCommentsBalanced (sortEpaComments p) cc) an (sortEpaComments c) - - go :: Data b => ([LEpaComment] -> b) - -> AnnListItem - -> [LEpaComment] - -> (AnnListItem, b) - go f (AnnListItem []) c = (AnnListItem [], f c) - go f (AnnListItem lis) c = process f ([],[]) lis (sortEpaComments c) - - process :: Data b => ([LEpaComment] -> b) - -> ([TrailingAnn], [LEpaComment]) - -> [TrailingAnn] - -> [LEpaComment] - -> (AnnListItem, b) - process f (ll,cc) [] cs0 = (AnnListItem (reverse ll), f (cc++cs0)) - process f (ll,cc) li [] = (AnnListItem (reverse $ ll++li), f cc) - process f (ll,cc) (l0:li) cs0 = r - where - r = case trailingAnnLoc l0 of - EpaSpan s -> r0 - where - condp (L lc _) = anchor lc >= anchor anc - (before,rest) = break condp cs0 - cond (L lc _) = anchor lc >= s - (these,those) = break cond rest - r0 = case these of - [] -> process f (l0:ll,cc) li cs0 - priors -> - -- We have at least one comment preceding the list item - let - -- dp is the delta from the end of the last comment to - -- the start of the AddXXXAnn delta - dp = tweakDelta $ spanOrigDelta (anchor $ getLoc $ last priors) s - - l' = EpaDelta dp (commentOrigDeltas these) - cs1 = those - in - process f (setTrailingAnnLoc l0 l':ll,before++cc) li cs1 - EpaDelta _d' _cs' -> process f (l0:ll,cc) li cs0 - -- | For comment-related deltas starting on a new line we have an -- off-by-one problem. Adjust tweakDelta :: DeltaPos -> DeltaPos tweakDelta (SameLine d) = SameLine d tweakDelta (DifferentLine l d) = DifferentLine l (d-1) --- TODO: Until https://gitlab.haskell.org/ghc/ghc/-/issues/20715 is --- fixed we have to special-case a funbind. Damn. --- The problem seems to depend on whether the funbind has params --- or not. If not, we can do a normal tweakListComments. -tweakListCommentsFB :: LHsDecl GhcPs -> LHsDecl GhcPs -tweakListCommentsFB (L l (ValD xv (FunBind x n (MG mx (L lm matches) o) t))) = r - where - -- We need to pass any comments from the outer location into the - -- first match for processing - (l',matches') = case matches of - [] -> (l,matches) - (L lm0 m:ms) -> (l1, L lm' m:ms) - `debug` ("tweakListCommentsFB:(l',lm')=" ++ showAst (l1,lm')) - -- (L lm m:ms) -> error $ "lm'=\n" ++ showAst lm' - where - (l1,cs',as) = case l of - SrcSpanAnn EpAnnNotUsed _ -> (l,[], []) - SrcSpanAnn (EpAnn anc an (EpaComments cs)) l0 - -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaComments [])) l0, cs, lann_trailing an) - SrcSpanAnn (EpAnn anc an (EpaCommentsBalanced ls ts)) l0 - -> (SrcSpanAnn (EpAnn anc (AnnListItem []) (EpaCommentsBalanced ls [])) l0, ts, lann_trailing an) - - lm' = case lm0 of - SrcSpanAnn EpAnnNotUsed l0 - -> SrcSpanAnn (EpAnn (spanAsAnchor l0) (AnnListItem as) (EpaComments cs')) l0 - SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaComments cs)) l0 - -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaComments (cs'<>cs))) l0 - SrcSpanAnn (EpAnn anc (AnnListItem is) (EpaCommentsBalanced ls ts)) l0 - -> SrcSpanAnn (EpAnn anc (AnnListItem (as<>is)) (EpaCommentsBalanced (cs'<>ls) ts)) l0 - - r = (L l' (ValD xv (FunBind x n (MG mx (L lm (map tweakListComments' matches')) o) t))) -tweakListCommentsFB x = error $ "tweakListCommentsFB for " ++ showAst x - -- --------------------------------------------------------------------- balanceSameLineComments :: (Monad m) @@ -866,15 +784,6 @@ -- --------------------------------------------------------------------- --- | Take an anchor and a preceding location, and generate an --- equivalent one with a 'MovedAnchor' delta. -deltaAnchor :: Anchor -> RealSrcSpan -> Anchor -deltaAnchor (Anchor anc _) ss = Anchor anc (MovedAnchor dp) - where - dp = pos2delta (ss2pos ss) (ss2pos anc) - --- --------------------------------------------------------------------- - -- | Create a @SrcSpanAnn@ with a @MovedAnchor@ operation using the -- given @DeltaPos@. noAnnSrcSpanDP :: (Monoid ann) => SrcSpan -> DeltaPos -> SrcSpanAnn' (EpAnn ann) @@ -1028,12 +937,7 @@ (l', rhs') <- case binds of EmptyLocalBinds{} -> do logTr $ "replaceDecls LMatch empty binds" - -- modifyAnnsT (setPrecedingLines (ghead "LMatch.replaceDecls" newBinds) 1 4) - -- only move the comment if the original where clause was empty. - -- toMove <- balanceTrailingComments m m - -- insertCommentBefore (mkAnnKey m) toMove (matchEpAnn AnnWhere) - -- TODO: move trailing comments on the same line to before the binds logDataWithAnnsTr "Match.replaceDecls:balancing comments:m" m L l' m' <- balanceSameLineComments m logDataWithAnnsTr "Match.replaceDecls:(m1')" (L l' m') @@ -1046,17 +950,16 @@ -- --------------------------------------------------------------------- instance HasDecls (LocatedA (HsExpr GhcPs)) where - hsDecls (L _ (HsLet _ decls _ex)) = hsDeclsValBinds decls - hsDecls _ = return [] + hsDecls (L _ (HsLet _ _ decls _ _ex)) = hsDeclsValBinds decls + hsDecls _ = return [] - replaceDecls (L ll (HsLet x binds ex)) newDecls + replaceDecls (L ll (HsLet x tkLet binds tkIn ex)) newDecls = do logTr "replaceDecls HsLet" let lastAnc = realSrcSpan $ spanHsLocaLBinds binds -- TODO: may be an intervening comment, take account for lastAnc - let (x', ex',newDecls') = case x of - EpAnnNotUsed -> (x, ex, newDecls) - (EpAnn a (AnnsLet l i) cs) -> + let (tkLet', tkIn', ex',newDecls') = case (tkLet, tkIn) of + (L (TokenLoc l) ls, L (TokenLoc i) is) -> let off = case l of (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r @@ -1066,18 +969,21 @@ newDecls'' = case newDecls of [] -> newDecls (d:ds) -> setEntryDPDecl d (SameLine 0) : ds - in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs + -- in ( EpAnn a (AnnsLet l (addEpaLocationDelta off lastAnc i)) cs + in ( L (TokenLoc l) ls + , L (TokenLoc (addEpaLocationDelta off lastAnc i)) is , ex'' , newDecls'') + (_,_) -> (tkLet, tkIn, ex, newDecls) binds' <- replaceDeclsValbinds WithoutWhere binds newDecls' - return (L ll (HsLet x' binds' ex')) + return (L ll (HsLet x tkLet' binds' tkIn' ex')) -- TODO: does this make sense? Especially as no hsDecls for HsPar - replaceDecls (L l (HsPar x e)) newDecls + replaceDecls (L l (HsPar x lpar e rpar)) newDecls = do logTr "replaceDecls HsPar" e' <- replaceDecls e newDecls - return (L l (HsPar x e')) + return (L l (HsPar x lpar e' rpar)) replaceDecls old _new = error $ "replaceDecls (LHsExpr GhcPs) undefined for:" ++ showGhc old -- --------------------------------------------------------------------- @@ -1135,9 +1041,7 @@ replaceDecls (L l (LetStmt x lb)) newDecls = do - -- modifyAnnsT (captureOrder s newDecls) lb'' <- replaceDeclsValbinds WithWhere lb newDecls - -- let lb' = L (getLoc lb) lb'' return (L l (LetStmt x lb'')) replaceDecls (L l (LastStmt x e d se)) newDecls = do @@ -1322,79 +1226,3 @@ decls <- liftT $ hsDecls t decls' <- action decls liftT $ replaceDecls t decls' - --- --------------------------------------------------------------------- - --- type RWS r w s = RWST r w s Identity --- runRWS :: Monoid w => RWS r w s a -> r -> s -> (a, s, w) --- rws :: Monoid w => (r -> s -> (a, s, w)) -> RWS r w s a - --- -- | Evaluate a computation with the given initial state and environment, --- -- returning the final value and output, discarding the final state. --- evalRWS :: (Monoid w) --- => RWS r w s a -- ^RWS computation to execute --- -> r -- ^initial environment --- -> s -- ^initial value --- -> (a, w) -- ^final value and output - --- mkM :: (Monad m, Typeable a, Typeable b) => (b -> m b) -> a -> m a - -type Delta a = RWS () [String] (Maybe Anchor) a - - --- | Generic top-down traversal through the given AST fragment, --- converting all ExactPrint Anchor's into ones with an equivalent --- MovedAnchor operation. Initially ignores comments -makeDeltaAst' :: forall a. (Data a) => a -> a -makeDeltaAst' a = fst $ evalRWS (go a) () Nothing - where - go :: a -> Delta a - go = everywhereM' (mkM (locatedAnnImpl @AnnListItem) -- LocatedA - `extM` (locatedAnnImpl @NameAnn) -- LocatedN - `extM` (locatedAnnImpl @AnnList) -- LocatedL - `extM` (locatedAnnImpl @AnnPragma) -- LocatedP - `extM` (locatedAnnImpl @AnnContext) -- LocatedC - ) - - locatedAnnImpl :: forall an. (Default an) - => SrcAnn an -> Delta (SrcAnn an) - locatedAnnImpl (SrcSpanAnn (EpAnn anc@(Anchor loc _op) an cs) l) = do - -- error "locatedAnnImpl:EpAnn" - ma <- get - put (Just anc) - let anchor' = case ma of - Nothing -> (Anchor loc (MovedAnchor (SameLine 0))) - Just (Anchor rl _op) -> deltaAnchor anc rl - let cs' = case ma of - Nothing -> cs <> mkComments ("from anc:Nothing") (Anchor loc UnchangedAnchor) - Just anc' -> cs <> mkComments ("from anc:" ++ showGhc anc') anc' - return (SrcSpanAnn (EpAnn anchor' an cs') l) - - locatedAnnImpl (SrcSpanAnn EpAnnNotUsed l) = do - -- error $ "EpAnnNotUsed: " ++ showGhc l - ma <- get - let anc = spanAsAnchor l - put (Just anc) - let anchor' = case ma of - Nothing -> Anchor (realSrcSpan l) (MovedAnchor (SameLine 0)) - Just (Anchor rl _op) -> deltaAnchor anc rl - 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' def cs') l) - --- | Monadic variation on everywhere', so Apply a monadic --- transformation everywhere in top-down manner -everywhereM' :: Monad m => GenericM m -> GenericM m -everywhereM' f x - = do x' <- f x - gmapM (everywhereM' f) x' - - -mkComments :: String -> Anchor -> EpAnnComments -mkComments str anc = EpaComments [mkCommentAnc str anc] - -mkCommentAnc :: String -> Anchor -> LEpaComment -mkCommentAnc str anc = L anc (EpaComment (EpaLineComment str) (anchor anc) ) - --- --------------------------------------------------------------------- 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 @@ -19,6 +19,7 @@ where import Control.Monad.State import Data.Function +import Data.List import Data.Maybe import Data.Ord (comparing) @@ -32,8 +33,7 @@ import GHC.Types.SrcLoc import GHC.Data.FastString import GHC.Utils.Outputable ( showPprUnsafe ) - -import Data.List (sortBy, elemIndex) +import qualified GHC.Data.Strict as Strict import Debug.Trace import Language.Haskell.GHC.ExactPrint.Types @@ -46,29 +46,15 @@ -- debugEnabledFlag = True debugEnabledFlag = False --- |Global switch to enable debug tracing in ghc-exactprint Pretty -debugPEnabledFlag :: Bool -debugPEnabledFlag = True --- debugPEnabledFlag = False - -- |Provide a version of trace that comes at the end of the line, so it can -- easily be commented out when debugging different things. debug :: c -> String -> c debug c s = if debugEnabledFlag then trace s c else c - --- |Provide a version of trace for the Pretty module, which can be enabled --- separately from 'debug' and 'debugM' -debugP :: String -> c -> c -debugP s c = if debugPEnabledFlag - then trace s c - else c - debugM :: Monad m => String -> m () debugM s = when debugEnabledFlag $ traceM s - -- --------------------------------------------------------------------- warn :: c -> String -> c @@ -203,19 +189,17 @@ insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource insertCppComments (L l p) cs = L l p' where - ncs = EpaComments cs an' = case GHC.hsmodAnn p of - (EpAnn a an ocs) -> EpAnn a an (ocs <> ncs) + (EpAnn a an ocs) -> EpAnn a an (EpaComments cs') + where + cs' = sortEpaComments $ priorComments ocs ++ getFollowingComments ocs ++ cs unused -> unused p' = p { GHC.hsmodAnn = an' } -- --------------------------------------------------------------------- ghcCommentText :: LEpaComment -> String -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNext s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentPrev s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocCommentNamed s) _)) = s -ghcCommentText (L _ (GHC.EpaComment (EpaDocSection _ s) _)) = s +ghcCommentText (L _ (GHC.EpaComment (EpaDocComment s) _)) = exactPrintHsDocString s ghcCommentText (L _ (GHC.EpaComment (EpaDocOptions s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaLineComment s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s @@ -291,6 +275,9 @@ -- --------------------------------------------------------------------- +isSymbolRdrName :: RdrName -> Bool +isSymbolRdrName n = isSymOcc $ rdrNameOcc n + rdrName2String :: RdrName -> String rdrName2String r = case isExact_maybe r of @@ -308,6 +295,21 @@ -- --------------------------------------------------------------------- +-- occAttributes :: OccName.OccName -> String +-- occAttributes o = "(" ++ ns ++ vo ++ tv ++ tc ++ d ++ ds ++ s ++ v ++ ")" +-- where +-- -- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " +-- ns = (showSDocUnsafe $ OccName.pprNameSpaceBrief $ occNameSpace o) ++ ", " +-- vo = if isVarOcc o then "Var " else "" +-- tv = if isTvOcc o then "Tv " else "" +-- tc = if isTcOcc o then "Tc " else "" +-- d = if isDataOcc o then "Data " else "" +-- ds = if isDataSymOcc o then "DataSym " else "" +-- s = if isSymOcc o then "Sym " else "" +-- v = if isValOcc o then "Val " else "" + + -- --------------------------------------------------------------------- + locatedAnAnchor :: LocatedAn a t -> RealSrcSpan locatedAnAnchor (L (SrcSpanAnn EpAnnNotUsed l) _) = realSrcSpan l locatedAnAnchor (L (SrcSpanAnn (EpAnn a _ _) _) _) = anchor a @@ -353,31 +355,17 @@ moveAnchor (SrcSpanAnn (EpAnn anc _ cs) l) = SrcSpanAnn (EpAnn anc mempty cs) l -- --------------------------------------------------------------------- -trailingAnnToAddEpAnn :: TrailingAnn -> AddEpAnn -trailingAnnToAddEpAnn (AddSemiAnn ss) = AddEpAnn AnnSemi ss -trailingAnnToAddEpAnn (AddCommaAnn ss) = AddEpAnn AnnComma ss -trailingAnnToAddEpAnn (AddVbarAnn ss) = AddEpAnn AnnVbar ss -trailingAnnToAddEpAnn (AddRarrowAnn ss) = AddEpAnn AnnRarrow ss -trailingAnnToAddEpAnn (AddRarrowAnnU ss) = AddEpAnn AnnRarrowU ss -trailingAnnToAddEpAnn (AddLollyAnnU ss) = AddEpAnn AnnLollyU ss trailingAnnLoc :: TrailingAnn -> EpaLocation trailingAnnLoc (AddSemiAnn ss) = ss trailingAnnLoc (AddCommaAnn ss) = ss trailingAnnLoc (AddVbarAnn ss) = ss -trailingAnnLoc (AddRarrowAnn ss) = ss -trailingAnnLoc (AddRarrowAnnU ss) = ss -trailingAnnLoc (AddLollyAnnU ss) = ss setTrailingAnnLoc :: TrailingAnn -> EpaLocation -> TrailingAnn setTrailingAnnLoc (AddSemiAnn _) ss = (AddSemiAnn ss) setTrailingAnnLoc (AddCommaAnn _) ss = (AddCommaAnn ss) setTrailingAnnLoc (AddVbarAnn _) ss = (AddVbarAnn ss) -setTrailingAnnLoc (AddRarrowAnn _) ss = (AddRarrowAnn ss) -setTrailingAnnLoc (AddRarrowAnnU _) ss = (AddRarrowAnnU ss) -setTrailingAnnLoc (AddLollyAnnU _) ss = (AddLollyAnnU ss) - addEpAnnLoc :: AddEpAnn -> EpaLocation addEpAnnLoc (AddEpAnn _ l) = l @@ -415,16 +403,16 @@ hackSrcSpanToAnchor :: SrcSpan -> Anchor hackSrcSpanToAnchor (UnhelpfulSpan s) = error $ "hackSrcSpanToAnchor : UnhelpfulSpan:" ++ show s -hackSrcSpanToAnchor (RealSrcSpan r Nothing) = Anchor r UnchangedAnchor -hackSrcSpanToAnchor (RealSrcSpan r (Just (BufSpan (BufPos s) (BufPos e)))) +hackSrcSpanToAnchor (RealSrcSpan r Strict.Nothing) = Anchor r UnchangedAnchor +hackSrcSpanToAnchor (RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e)))) = if s <= 0 && e <= 0 then Anchor r (MovedAnchor (deltaPos (-s) (-e))) else Anchor r UnchangedAnchor hackAnchorToSrcSpan :: Anchor -> SrcSpan -hackAnchorToSrcSpan (Anchor r UnchangedAnchor) = RealSrcSpan r Nothing +hackAnchorToSrcSpan (Anchor r UnchangedAnchor) = RealSrcSpan r Strict.Nothing hackAnchorToSrcSpan (Anchor r (MovedAnchor dp)) - = RealSrcSpan r (Just (BufSpan (BufPos s) (BufPos e))) + = RealSrcSpan r (Strict.Just (BufSpan (BufPos s) (BufPos e))) where s = - (getDeltaLine dp) e = - (deltaColumn dp) diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} @@ -28,19 +29,23 @@ -- --------------------------------------------------------------------- data GHCVersion = GHC92 + | GHC94 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion +#if MIN_VERSION_ghc(9,4,0) +ghcVersion = GHC94 +#else ghcVersion = GHC92 +#endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of GHC92 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92"] - - -- GHC92 -> ["ghc92-copied"] - -- GHC92 -> ["ghc92"] + GHC94 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94"] + -- GHC94 -> ["ghc94"] -- --------------------------------------------------------------------- @@ -86,7 +91,12 @@ "QuasiQuote.hs", "RandomPGC.hs", "HashTab.hs", - "LinePragmas.hs" + "LinePragmas.hs", + + -- All related to blending in CPP-as-comments + "Cpp.hs", + "Checkpoint.hs", + "CommentPlacement6.hs" ] findTestsMD :: LibDir -> IO Test @@ -202,12 +212,41 @@ -- mkTestModChange libdir rmDecl4 "RmDecl4.hs" -- mkParserTestMD libdir "ghc92" "Foo.hs" -- mkParserTest libdir "ghc92" "Foo.hs" - mkParserTestMD libdir "ghc92" "Foo.hs" + -- mkParserTestMD libdir "ghc92" "Foo.hs" -- mkParserTest libdir "ghc92" "Foo2.hs" -- mkParserTest libdir "ghc710" "EmptyMostly.hs" -- mkParserTestBC libdir "ghc710" "Control.hs" -- mkParserTestBC libdir "ghc92" "CommentPlacement3.hs" -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs" + + -- mkParserTest libdir "ghc92" "ConstructorComment.hs" + -- mkParserTest libdir "ghc92" "Binary.hs" + -- mkParserTest libdir "ghc92" "Observer.hs" + -- mkParserTest libdir "ghc92" "Observer1.hs" + + -- mkTestModChange libdir addLocaLDecl1 "AddLocalDecl1.hs" + -- mkTestModChange libdir addLocaLDecl3 "AddLocalDecl3.hs" + + -- mkParserTestBC libdir "ghc710" "MultiParamTypeClasses.hs" + + -- mkParserTestBC libdir "ghc710" "DataFamilies.hs" + -- mkParserTestBC libdir "ghc710" "Cpp.hs" + -- mkParserTestBC libdir "ghc80" "T4139.hs" + + -- mkParserTestBC libdir "ghc92" "Checkpoint.hs" + + -- mkParserTestBC libdir "ghc92" "CommentPlacement6.hs" + -- mkParserTest libdir "ghc92" "CommentPlacement6.hs" + + -- mkParserTest libdir "ghc92" "TopLevelSemis.hs" + -- mkParserTestBC libdir "ghc92" "TopLevelSemis.hs" + -- mkParserTestMD libdir "ghc92" "TopLevelSemis.hs" + + -- mkParserTest libdir "ghc92" "TopLevelSemis1.hs" + -- mkParserTestBC libdir "ghc92" "TopLevelSemis1.hs" + -- mkParserTestMD libdir "ghc92" "TopLevelSemis1.hs" + + mkParserTest libdir "ghc94" "record-dot-four-out.hs" -- Needs GHC changes diff --git a/tests/Test/Common.hs b/tests/Test/Common.hs --- a/tests/Test/Common.hs +++ b/tests/Test/Common.hs @@ -31,16 +31,16 @@ import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.ExactPrint +-- import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Preprocess import qualified Control.Monad.IO.Class as GHC import qualified GHC as GHC hiding (parseModule) -import qualified GHC.Data.Bag as GHC +-- import qualified GHC.Data.Bag as GHC import qualified GHC.Driver.Session as GHC -import qualified GHC.Utils.Error as GHC +-- import qualified GHC.Utils.Error as GHC import qualified GHC.LanguageExtensions as LangExt @@ -107,7 +107,9 @@ noChange _libdir parsed = return parsed changeBalanceComments :: Changer -changeBalanceComments _libdir (GHC.L l p) = do +changeBalanceComments _libdir top = do + let (GHC.L l p) = makeDeltaAst top + -- let (GHC.L l p) = top let decls0 = GHC.hsmodDecls p (decls,_,w) = runTransform (balanceCommentsList decls0) let p2 = p { GHC.hsmodDecls = decls} @@ -199,10 +201,5 @@ case mm of [] -> return Nothing fs -> return (Just (snd $ head fs)) - --- --------------------------------------------------------------------- - -showErrorMessages :: GHC.ErrorMessages -> String -showErrorMessages m = show $ GHC.bagToList m -- --------------------------------------------------------------------- diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -15,7 +15,7 @@ -- import qualified Data.ByteString as B import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.ExactPrint +-- import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -7,7 +7,7 @@ module Test.Transform where import Language.Haskell.GHC.ExactPrint -import Language.Haskell.GHC.ExactPrint.ExactPrint +-- import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Parsers import Language.Haskell.GHC.ExactPrint.Utils @@ -90,16 +90,6 @@ -- --------------------------------------------------------------------- --- changeWhereIn3a :: Changer --- changeWhereIn3a ans (GHC.L l p) = do --- let decls = GHC.hsmodDecls p --- -- (GHC.L _ (GHC.SigD sig)) = head $ drop 1 decls --- d1 = head $ drop 2 decls --- d2 = head $ drop 3 decls --- let (_p1,(ans',_),_w) = runTransform ans (balanceComments d1 d2) --- let p2 = p { GHC.hsmodDecls = d2:d1:decls} --- return (ans',GHC.L l p2) - -- | Check that balanceCommentsList is idempotent changeWhereIn3a :: Changer changeWhereIn3a _libdir (L l p) = do @@ -129,50 +119,6 @@ -- --------------------------------------------------------------------- --- -- | Add a local declaration with signature to LocalDecl, where there was no --- -- prior local decl. So it adds a "where" annotation. --- changeLocalDecls2 :: Changer --- changeLocalDecls2 ans (GHC.L l p) = do --- Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") --- Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") --- let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns --- let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns --- -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns --- -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns --- -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns' --- let (p',(ans',_),_w) = runTransform ans doAddLocal --- doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p --- replaceLocalBinds :: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) --- -> Transform (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) --- replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L _ GHC.EmptyLocalBinds{})))) = do --- newSpan <- uniqueSrcSpanT --- let --- newAnnKey = AnnKey (rs newSpan) (CN "HsValBinds") --- addWhere mkds = --- case Map.lookup (mkAnnKey m) mkds of --- Nothing -> error "wtf" --- Just ann -> Map.insert newAnnKey ann2 mkds2 --- where --- ann1 = ann { annsDP = annsDP ann ++ [(G GHC.AnnWhere,DP (1,2))] --- , annCapturedSpan = Just newAnnKey --- , annSortKey = Just [rs ls, rs ld] --- } --- mkds2 = Map.insert (mkAnnKey m) ann1 mkds --- ann2 = annNone --- { annEntryDelta = DP (1,0) } --- modifyAnnsT addWhere --- let decls = [s,d] --- -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) --- modifyAnnsT (captureOrderAnnKey newAnnKey decls) --- let binds = (GHC.HsValBinds noExt (GHC.ValBinds noExt (GHC.listToBag $ [GHC.L ld decl]) --- [GHC.L ls sig])) --- bindSpan <- uniqueSrcSpanT --- return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L bindSpan binds)))) --- replaceLocalBinds x = return x --- -- putStrLn $ "log:" ++ intercalate "\n" w --- return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p') - - -- | Add a local declaration with signature to LocalDecl, where there was no -- prior local decl. So it adds a "where" annotation. changeLocalDecls2 :: Changer @@ -204,41 +150,6 @@ -- --------------------------------------------------------------------- --- -- | Add a local declaration with signature to LocalDecl --- changeLocalDecls :: Changer --- changeLocalDecls ans (GHC.L l p) = do --- Right (declAnns, d@(GHC.L ld (GHC.ValD _ decl))) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") --- Right (sigAnns, s@(GHC.L ls (GHC.SigD _ sig))) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") --- let declAnns' = setPrecedingLines (GHC.L ld decl) 1 0 declAnns --- let sigAnns' = setPrecedingLines (GHC.L ls sig) 1 4 sigAnns --- -- putStrLn $ "changeLocalDecls:sigAnns=" ++ show sigAnns --- -- putStrLn $ "changeLocalDecls:declAnns=" ++ show declAnns --- -- putStrLn $ "\nchangeLocalDecls:sigAnns'=" ++ show sigAnns' --- let (p',(ans',_),_w) = runTransform ans doAddLocal --- doAddLocal = SYB.everywhereM (SYB.mkM replaceLocalBinds) p --- replaceLocalBinds :: GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs) --- -> Transform (GHC.LMatch GHC.GhcPs (GHC.LHsExpr GHC.GhcPs)) --- replaceLocalBinds m@(GHC.L lm (GHC.Match _ mln pats (GHC.GRHSs _ rhs (GHC.L lb (GHC.HsValBinds _ (GHC.ValBinds _ binds sigs)))))) = do --- a1 <- getAnnsT --- a' <- case sigs of --- [] -> return a1 --- (s1:_) -> do --- let a2 = setPrecedingLines s1 2 0 a1 --- return a2 --- putAnnsT a' --- let oldDecls = GHC.sortLocated $ map wrapDecl (GHC.bagToList binds) ++ map wrapSig sigs --- let decls = s:d:oldDecls --- -- logTr $ "(m,decls)=" ++ show (mkAnnKey m,map mkAnnKey decls) --- modifyAnnsT (captureOrder m decls) --- let binds' = (GHC.HsValBinds noExt --- (GHC.ValBinds noExt (GHC.listToBag $ (GHC.L ld decl):GHC.bagToList binds) --- (GHC.L ls sig:sigs))) --- return (GHC.L lm (GHC.Match noExt mln pats (GHC.GRHSs noExt rhs (GHC.L lb binds')))) --- replaceLocalBinds x = return x --- -- putStrLn $ "log:" ++ intercalate "\n" w --- return (mergeAnnList [declAnns',sigAnns',ans'],GHC.L l p') - - -- | Add a local declaration with signature to LocalDecl changeLocalDecls :: Changer changeLocalDecls libdir top = do @@ -275,20 +186,6 @@ -- --------------------------------------------------------------------- -- | Add a declaration to AddDecl --- changeAddDecl :: Changer --- changeAddDecl ans top = do --- Right (declAnns, decl) <- withDynFlags (\df -> parseDecl df "" "nn = n2") --- -- putStrLn $ "changeDecl:(declAnns,decl)=" ++ showGhc (declAnns,decl) --- let declAnns' = setPrecedingLines decl 2 0 declAnns --- -- putStrLn $ "changeDecl:(declAnns',decl)=" ++ showGhc (declAnns',decl) - --- let (p',(ans',_),_) = runTransform ans doAddDecl --- doAddDecl = SYB.everywhereM (SYB.mkM replaceTopLevelDecls) top --- replaceTopLevelDecls :: GHC.ParsedSource -> Transform (GHC.ParsedSource) --- replaceTopLevelDecls m = insertAtStart m decl --- return (mergeAnns declAnns' ans',p') - --- | Add a declaration to AddDecl changeAddDecl :: Changer changeAddDecl libdir top = do Right decl <- withDynFlags libdir (\df -> parseDecl df "" "nn = n2") @@ -301,24 +198,7 @@ replaceTopLevelDecls :: ParsedSource -> Transform ParsedSource replaceTopLevelDecls m = insertAtStart m decl' return p' --- --------------------------------------------------------------------- --- -- |Remove a decl with a trailing comment, and remove the trailing comment too --- changeWhereIn3 :: Int -> Changer --- changeWhereIn3 declIndex ans p = return (ans',p') --- where --- (p',(ans',_),_) = runTransform ans doTransform --- doTransform = doRmDecl p - --- doRmDecl (GHC.L l (GHC.HsModule lo mmn mexp imps decls mdepr haddock)) = do --- let --- -- declIndex = 2 -- zero based --- decls1 = take declIndex decls --- decls2 = drop (declIndex + 1) decls --- decls' = decls1 ++ decls2 --- return (GHC.L l (GHC.HsModule lo mmn mexp imps decls' mdepr haddock)) --- -- error $ "doRmDecl:decls2=" ++ showGhc (length decls,decls1,decls2) - -- --------------------------------------------------------------------- changeRenameCase1 :: Changer @@ -335,7 +215,6 @@ changeLayoutIn3 :: Changer changeLayoutIn3 _libdir parsed = return (rename "anotherX" [((7,13),(7,14)),((7,37),(7,38)),((8,37),(8,38))] parsed) --- changeLayoutIn3 parsed = rename "anotherX" [((7,13),(7,14)),((7,37),(7,38))] parsed changeLayoutIn4 :: Changer changeLayoutIn4 _libdir parsed = return (rename "io" [((7,8),(7,13)),((7,28),(7,33))] parsed) @@ -370,18 +249,8 @@ | cond (locA ln) = L ln newName replaceRdr x = x - -- --------------------------------------------------------------------- --- changeWhereIn4 :: Changer --- changeWhereIn4 ans parsed --- = return (ans,SYB.everywhere (SYB.mkT replace) parsed) --- where --- replace :: GHC.Located GHC.RdrName -> GHC.Located GHC.RdrName --- replace (GHC.L ln _n) --- | ss2range ln == ((12,16),(12,17)) = GHC.L ln (GHC.mkRdrUnqual (GHC.mkVarOcc "p_2")) --- replace x = x - changeWhereIn4 :: Changer changeWhereIn4 _libdir parsed = return (everywhere (mkT replace) (makeDeltaAst parsed)) @@ -390,27 +259,15 @@ replace (L ln _n) | ss2range (locA ln) == ((12,16),(12,17)) = L ln (mkRdrUnqual (mkVarOcc "p_2")) replace x = x --- --------------------------------------------------------------------- --- changeLetIn1 :: Changer --- changeLetIn1 ans parsed --- = return (ans,SYB.everywhere (SYB.mkT replace) parsed) --- where --- replace :: GHC.HsExpr GHC.GhcPs -> GHC.HsExpr GHC.GhcPs --- replace (GHC.HsLet _ (GHC.L lb localDecls) expr@(GHC.L _ _)) --- = --- let (GHC.HsValBinds x (GHC.ValBinds xv bagDecls sigs)) = localDecls --- bagDecls' = GHC.listToBag $ init $ GHC.bagToList bagDecls --- in (GHC.HsLet noExt (GHC.L lb (GHC.HsValBinds x (GHC.ValBinds xv bagDecls' sigs))) expr) - --- replace x = x +-- --------------------------------------------------------------------- changeLetIn1 :: Changer changeLetIn1 _libdir parsed = return (everywhere (mkT replace) (makeDeltaAst parsed)) where replace :: HsExpr GhcPs -> HsExpr GhcPs - replace (HsLet (EpAnn anc (AnnsLet l _i) cs) localDecls expr) + replace (HsLet an tkLet localDecls _ expr) = let (HsValBinds x (ValBinds xv bagDecls sigs)) = localDecls [l2,_l1] = map wrapDecl $ bagToList bagDecls @@ -418,8 +275,9 @@ (L (SrcSpanAnn _ le) e) = expr a = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan le) (MovedAnchor (SameLine 1))) mempty emptyComments) le) expr' = L a e - in (HsLet (EpAnn anc (AnnsLet l (EpaDelta (DifferentLine 1 0) [])) cs) - (HsValBinds x (ValBinds xv bagDecls' sigs)) expr') + tkIn' = L (TokenLoc (EpaDelta (DifferentLine 1 0) [])) HsTok + in (HsLet an tkLet + (HsValBinds x (ValBinds xv bagDecls' sigs)) tkIn' expr') replace x = x @@ -456,27 +314,13 @@ -- --------------------------------------------------------------------- --- addLocaLDecl1 :: Changer --- addLocaLDecl1 ans lp = do --- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") --- let declAnns' = setPrecedingLines newDecl 1 4 declAnns --- doAddLocal = do --- (d1:d2:_) <- hsDecls lp --- balanceComments d1 d2 --- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m d -> do --- return ((newDecl : d),Nothing) --- replaceDecls lp [d1', d2] - --- (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal --- -- putStrLn $ "log:\n" ++ intercalate "\n" _w --- return (ans',lp') - addLocaLDecl1 :: Changer -addLocaLDecl1 libdir lp = do +addLocaLDecl1 libdir top = do Right (L ld (ValD _ decl)) <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") - let decl' = setEntryDP (makeDeltaAst (L ld decl)) (DifferentLine 1 4) + let decl' = setEntryDP (L ld decl) (DifferentLine 1 5) doAddLocal = do - (de1:d2:d3:_) <- hsDecls (makeDeltaAst lp) + let lp = makeDeltaAst top + (de1:d2:d3:_) <- hsDecls lp (de1'',d2') <- balanceComments de1 d2 (de1',_) <- modifyValD (getLocA de1'') de1'' $ \_m d -> do return ((wrapDecl decl' : d),Nothing) @@ -485,27 +329,8 @@ (lp',_,w) <- runTransformT doAddLocal debugM $ "addLocaLDecl1:" ++ intercalate "\n" w return lp' --- --------------------------------------------------------------------- --- addLocaLDecl2 :: Changer --- addLocaLDecl2 ans lp = do --- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") --- let --- doAddLocal = do --- tlDecs <- hsDecls lp --- let parent = head tlDecs --- balanceComments parent (head $ tail tlDecs) - --- (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do --- transferEntryDPT (head decls) newDecl --- setEntryDPT (head decls) (DP (1, 0)) --- return ((newDecl:decls),Nothing) - --- replaceDecls lp (parent':tail tlDecs) - --- let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal --- -- putStrLn $ "log:\n" ++ intercalate "\n" _w --- return (ans',lp') +-- --------------------------------------------------------------------- addLocaLDecl2 :: Changer addLocaLDecl2 libdir lp = do @@ -529,34 +354,13 @@ -- --------------------------------------------------------------------- --- addLocaLDecl3 :: Changer --- addLocaLDecl3 ans lp = do --- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") --- let --- doAddLocal = do --- -- logDataWithAnnsTr "parsed:" lp --- logDataWithAnnsTr "newDecl:" newDecl --- tlDecs <- hsDecls lp --- let parent = head tlDecs --- balanceComments parent (head $ tail tlDecs) - --- (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \m decls -> do --- setPrecedingLinesT newDecl 1 0 --- moveTrailingComments m (last decls) --- return ((decls++[newDecl]),Nothing) - --- replaceDecls lp (parent':tail tlDecs) - --- let (lp',(ans',_),_w) = runTransform (mergeAnns ans declAnns) doAddLocal --- -- putStrLn $ "log\n" ++ intercalate "\n" _w --- return (ans',lp') - addLocaLDecl3 :: Changer -addLocaLDecl3 libdir lp = do +addLocaLDecl3 libdir top = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") let doAddLocal = do - (de1:d2:_) <- hsDecls (makeDeltaAst lp) + let lp = makeDeltaAst top + (de1:d2:_) <- hsDecls lp (de1'',d2') <- balanceComments de1 d2 (parent',_) <- modifyValD (getLocA de1) de1'' $ \_m (d:ds) -> do @@ -571,29 +375,6 @@ -- --------------------------------------------------------------------- --- addLocaLDecl4 :: Changer --- addLocaLDecl4 ans lp = do --- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "nn = 2") --- Right (sigAnns, newSig) <- withDynFlags (\df -> parseDecl df "sig" "nn :: Int") --- -- putStrLn $ "addLocaLDecl4:lp=" ++ showGhc lp --- let --- doAddLocal = do --- tlDecs <- hsDecls lp --- let parent = head tlDecs - --- setPrecedingLinesT newSig 1 0 --- setPrecedingLinesT newDecl 1 0 - --- (parent',_) <- modifyValD (GHC.getLoc parent) parent $ \_m decls -> do --- return ((decls++[newSig,newDecl]),Nothing) - --- replaceDecls lp (parent':tail tlDecs) - --- let (lp',(ans',_),_w) = runTransform (mergeAnnList [ans,declAnns,sigAnns]) doAddLocal --- -- putStrLn $ "log\n" ++ intercalate "\n" _w --- return (ans',lp') - - addLocaLDecl4 :: Changer addLocaLDecl4 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "nn = 2") @@ -616,22 +397,6 @@ -- --------------------------------------------------------------------- --- addLocaLDecl5 :: Changer --- addLocaLDecl5 ans lp = do --- let --- doAddLocal = do --- [s1,d1,d2,d3] <- hsDecls lp - --- transferEntryDPT d2 d3 - --- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m _decls -> do --- return ([d2],Nothing) --- replaceDecls lp [s1,d1',d3] - --- (lp',(ans',_),_w) <- runTransformT ans doAddLocal --- -- putStrLn $ "log\n" ++ intercalate "\n" _w --- return (ans',lp') - addLocaLDecl5 :: Changer addLocaLDecl5 _libdir lp = do let @@ -652,26 +417,6 @@ -- --------------------------------------------------------------------- --- addLocaLDecl6 :: Changer --- addLocaLDecl6 ans lp = do --- Right (declAnns, newDecl) <- withDynFlags (\df -> parseDecl df "decl" "x = 3") --- let declAnns' = setPrecedingLines newDecl 1 4 declAnns --- doAddLocal = do --- [d1,d2] <- hsDecls lp --- balanceComments d1 d2 - --- let GHC.L _ (GHC.ValD _ (GHC.FunBind _ _ (GHC.MG _ (GHC.L _ [m1,m2]) _) _)) = d1 --- balanceComments m1 m2 - --- (d1',_) <- modifyValD (GHC.getLoc m1) d1 $ \_m decls -> do --- return ((newDecl : decls),Nothing) --- replaceDecls lp [d1', d2] - --- (lp',(ans',_),_w) <- runTransformT (mergeAnns ans declAnns') doAddLocal --- -- putStrLn $ "log:\n" ++ intercalate "\n" _w --- return (ans',lp') - - addLocaLDecl6 :: Changer addLocaLDecl6 libdir lp = do Right newDecl <- withDynFlags libdir (\df -> parseDecl df "decl" "x = 3") @@ -712,24 +457,6 @@ -- --------------------------------------------------------------------- --- rmDecl2 :: Changer --- rmDecl2 ans lp = do --- let --- doRmDecl = do --- let --- go :: GHC.LHsExpr GHC.GhcPs -> Transform (GHC.LHsExpr GHC.GhcPs) --- go e@(GHC.L _ (GHC.HsLet{})) = do --- decs <- hsDecls e --- e' <- replaceDecls e (init decs) --- return e' --- go x = return x - --- SYB.everywhereM (SYB.mkM go) lp - --- let (lp',(ans',_),_w) = runTransform ans doRmDecl --- -- putStrLn $ "log:\n" ++ intercalate "\n" _w --- return (ans',lp') - rmDecl2 :: Changer rmDecl2 _libdir lp = do let @@ -750,22 +477,6 @@ return lp' -- --------------------------------------------------------------------- --- rmDecl3 :: Changer --- rmDecl3 ans lp = do --- let --- doRmDecl = do --- [d1,d2] <- hsDecls lp - --- (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1] -> do --- setPrecedingLinesDeclT sd1 2 0 --- return ([],Just sd1) - --- replaceDecls lp [d1',sd1,d2] - --- (lp',(ans',_),_w) <- runTransformT ans doRmDecl --- -- putStrLn $ "log:\n" ++ intercalate "\n" _w --- return (ans',lp') - rmDecl3 :: Changer rmDecl3 _libdir lp = do let @@ -784,25 +495,6 @@ return lp' -- --------------------------------------------------------------------- --- rmDecl4 :: Changer --- rmDecl4 ans lp = do --- let --- doRmDecl = do --- [d1] <- hsDecls lp - --- (d1',Just sd1) <- modifyValD (GHC.getLoc d1) d1 $ \_m [sd1,sd2] -> do --- -- [sd1,sd2] <- hsDecls d1 --- transferEntryDPT sd1 sd2 - --- setPrecedingLinesDeclT sd1 2 0 --- -- d1' <- replaceDecls d1 [sd2] --- return ([sd2],Just sd1) - --- replaceDecls lp [d1',sd1] - --- (lp',(ans',_),_w) <- runTransformT ans doRmDecl --- return (ans',lp') - rmDecl4 :: Changer rmDecl4 _libdir lp = do let @@ -824,41 +516,20 @@ -- --------------------------------------------------------------------- --- rmDecl5 :: Changer --- rmDecl5 ans lp = do --- let --- doRmDecl = do --- let --- go :: GHC.HsExpr GHC.GhcPs -> Transform (GHC.HsExpr GHC.GhcPs) --- go (GHC.HsLet _ (GHC.L l lb) expr) = do --- decs <- hsDeclsValBinds lb --- let dec = last decs --- transferEntryDPT (head decs) dec --- lb' <- replaceDeclsValbinds lb [dec] --- return (GHC.HsLet noExt (GHC.L l lb') expr) --- go x = return x - --- SYB.everywhereM (SYB.mkM go) lp - --- let (lp',(ans',_),_w) = runTransform ans doRmDecl --- -- putStrLn $ "log:" ++ intercalate "\n" _w --- return (ans',lp') - rmDecl5 :: Changer rmDecl5 _libdir lp = do let doRmDecl = do let go :: HsExpr GhcPs -> Transform (HsExpr GhcPs) - go (HsLet a lb expr) = do + go (HsLet a tkLet lb tkIn expr) = do decs <- hsDeclsValBinds lb let dec = last decs -- _ <- transferEntryDPT (head decs) dec lb' <- replaceDeclsValbinds WithoutWhere lb [dec] - return (HsLet a lb' expr) + return (HsLet a tkLet lb' tkIn expr) go x = return x - -- everywhereM (mkM go) (makeDeltaAst lp) everywhereM (mkM go) lp let (lp',_,_w) = runTransform doRmDecl @@ -867,24 +538,6 @@ -- --------------------------------------------------------------------- --- rmDecl6 :: Changer --- rmDecl6 ans lp = do --- let --- doRmDecl = do --- [d1] <- hsDecls lp - --- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m subDecs -> do --- let (ss1:_sd1:sd2:sds) = subDecs --- transferEntryDPT ss1 sd2 - --- return (sd2:sds,Nothing) - --- replaceDecls lp [d1'] - --- (lp',(ans',_),_w) <- runTransformT ans doRmDecl --- -- putStrLn $ "log:" ++ intercalate "\n" _w --- return (ans',lp') - rmDecl6 :: Changer rmDecl6 _libdir lp = do let @@ -904,24 +557,6 @@ return lp' -- --------------------------------------------------------------------- --- rmDecl7 :: Changer --- rmDecl7 ans lp = do --- let --- doRmDecl = do --- tlDecs <- hsDecls lp --- let [s1,d1,d2,d3] = tlDecs - --- balanceComments d1 d2 --- balanceComments d2 d3 - --- transferEntryDPT d2 d3 - --- replaceDecls lp [s1,d1,d3] - --- let (lp',(ans',_),_w) = runTransform ans doRmDecl --- -- putStrLn $ "log:" ++ intercalate "\n" _w --- return (ans',lp') - rmDecl7 :: Changer rmDecl7 _libdir lp = do let @@ -939,17 +574,6 @@ return lp' -- --------------------------------------------------------------------- --- rmTypeSig1 :: Changer --- rmTypeSig1 ans lp = do --- let doRmDecl = do --- tlDecs <- hsDecls lp --- let (s1:d1:d2) = tlDecs --- (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 names typ))) = s1 --- s1' = (GHC.L l (GHC.SigD x1 (GHC.TypeSig x2 (tail names) typ))) --- replaceDecls lp (s1':d1:d2) - --- let (lp',(ans',_),_w) = runTransform ans doRmDecl --- return (ans',lp') rmTypeSig1 :: Changer rmTypeSig1 _libdir lp = do let doRmDecl = do @@ -968,21 +592,6 @@ -- --------------------------------------------------------------------- --- rmTypeSig2 :: Changer --- rmTypeSig2 ans lp = do --- let doRmDecl = do --- tlDecs <- hsDecls lp --- let [d1] = tlDecs - --- (d1',_) <- modifyValD (GHC.getLoc d1) d1 $ \_m [s,d] -> do --- transferEntryDPT s d --- return ([d],Nothing) --- replaceDecls lp [d1'] - --- let (lp',(ans',_),_w) = runTransform ans doRmDecl --- -- putStrLn $ "log:" ++ intercalate "\n" _w --- return (ans',lp') - rmTypeSig2 :: Changer rmTypeSig2 _libdir lp = do let doRmDecl = do @@ -1000,30 +609,6 @@ -- --------------------------------------------------------------------- --- addHiding1 :: Changer --- addHiding1 ans (GHC.L l p) = do --- let doTransform = do --- l0 <- uniqueSrcSpanT --- l1 <- uniqueSrcSpanT --- l2 <- uniqueSrcSpanT --- let --- [GHC.L li imp1,imp2] = GHC.hsmodImports p --- n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) --- n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) --- v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) --- v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) --- impHiding = GHC.L l0 [v1,v2] --- imp1' = imp1 { GHC.ideclHiding = Just (True,impHiding)} --- p' = p { GHC.hsmodImports = [GHC.L li imp1',imp2]} --- addSimpleAnnT impHiding (DP (0,1)) [((G GHC.AnnHiding),DP (0,0)),((G GHC.AnnOpenP),DP (0,1)),((G GHC.AnnCloseP),DP (0,0))] --- addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] --- addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] --- addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] --- return (GHC.L l p') - --- let (lp',(ans',_),_w) = runTransform ans doTransform --- return (ans',lp') - addHiding1 :: Changer addHiding1 _libdir (L l p) = do let doTransform = do @@ -1052,29 +637,6 @@ return lp' -- --------------------------------------------------------------------- --- addHiding2 :: Changer --- addHiding2 ans (GHC.L l p) = do --- let doTransform = do --- l1 <- uniqueSrcSpanT --- l2 <- uniqueSrcSpanT --- let --- [GHC.L li imp1] = GHC.hsmodImports p --- Just (_,GHC.L lh ns) = GHC.ideclHiding imp1 --- n1 = GHC.L l1 (GHC.mkVarUnqual (GHC.mkFastString "n1")) --- n2 = GHC.L l2 (GHC.mkVarUnqual (GHC.mkFastString "n2")) --- v1 = GHC.L l1 (GHC.IEVar noExt (GHC.L l1 (GHC.IEName n1))) --- v2 = GHC.L l2 (GHC.IEVar noExt (GHC.L l2 (GHC.IEName n2))) --- imp1' = imp1 { GHC.ideclHiding = Just (True,GHC.L lh (ns ++ [v1,v2]))} --- p' = p { GHC.hsmodImports = [GHC.L li imp1']} --- addSimpleAnnT n1 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] --- addSimpleAnnT v1 (DP (0,0)) [((G GHC.AnnComma),DP (0,0))] --- addSimpleAnnT n2 (DP (0,0)) [((G GHC.AnnVal),DP (0,0))] --- addTrailingCommaT (last ns) --- return (GHC.L l p') - --- let (lp',(ans',_),_w) = runTransform ans doTransform --- return (ans',lp') - addHiding2 :: Changer addHiding2 _libdir (L l p) = do let doTransform = do @@ -1103,6 +665,7 @@ let (lp',_,_w) = runTransform doTransform debugM $ "log:[\n" ++ intercalate "\n" _w ++ "]log end\n" return lp' + -- --------------------------------------------------------------------- cloneDecl1 :: Changer diff --git a/tests/examples/failing/record-dot-operator-parens.hs b/tests/examples/failing/record-dot-operator-parens.hs new file mode 100644 --- /dev/null +++ b/tests/examples/failing/record-dot-operator-parens.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE RebindableSyntax #-} + +data Foo = Foo {bar :: Foo} + +operatorUpdate f = f{(+) = 1} diff --git a/tests/examples/failing/record-dot-operator-parens.hs.bad b/tests/examples/failing/record-dot-operator-parens.hs.bad new file mode 100644 --- /dev/null +++ b/tests/examples/failing/record-dot-operator-parens.hs.bad @@ -0,0 +1,7 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE RebindableSyntax #-} + +data Foo = Foo {bar :: Foo} + +operatorUpdate f = f{+ = 1} diff --git a/tests/examples/ghc92/CommentPlacement4.hs b/tests/examples/ghc92/CommentPlacement4.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommentPlacement4.hs @@ -0,0 +1,9 @@ +module CommentPlacement4 where + +data family GMap k :: * -> * + +data family Array e + +-- data GMap () v = GMapUnit (Maybe v) +-- deriving Show + diff --git a/tests/examples/ghc92/CommentPlacement5.hs b/tests/examples/ghc92/CommentPlacement5.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommentPlacement5.hs @@ -0,0 +1,9 @@ +module CommentPlacement5 where + +bar :: Foo -> () +bar a = + case a of + GInt -> () + -- GBool -> () +bar _ = () + diff --git a/tests/examples/ghc92/CommentPlacement6.hs b/tests/examples/ghc92/CommentPlacement6.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc92/CommentPlacement6.hs @@ -0,0 +1,27 @@ +-- | Checkpoints in the blockchain (every 1000th blocks) + +{-# LANGUAGE CPP #-} +module CommentPlacement6 where + +#ifndef WITH_TESTNET + +--8----------------------------------------------------------------------------- +-- * the real network + +theGenesisBlock :: Hash256 +theGenesisBlock = 1 + +--14---------------------------------------------------------------------------- + +#else + +--18---------------------------------------------------------------------------- +-- * testnet3 + +theGenesisBlock :: Hash256 +theGenesisBlock = 2 + +#endif + +--26---------------------------------------------------------------------------- + diff --git a/tests/examples/ghc92/Observer1.hs b/tests/examples/ghc92/Observer1.hs --- a/tests/examples/ghc92/Observer1.hs +++ b/tests/examples/ghc92/Observer1.hs @@ -1,7 +1,7 @@ module Observer1 where -instance HasPdu (ObserverRegistry event) where - data Pdu (ObserverRegistry event) r where +instance HasPdu Int where + data Pdu Int r where --a comment RegisterObserver :: Int --b comment diff --git a/tests/examples/ghc94/record-dot-four-out.hs b/tests/examples/ghc94/record-dot-four-out.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc94/record-dot-four-out.hs @@ -0,0 +1,15 @@ +{-# LANGUAGE OverloadedRecordDot #-} +{-# LANGUAGE OverloadedRecordUpdate #-} +{-# LANGUAGE RebindableSyntax #-} + +data Foo = Foo {bar :: Foo} + +mfoo = fmap (.bar) $ Nothing + +baz = (Foo 1).bar + +fooplus f n = f{foo = f.bar + n} + +nestedFoo f = f.bar.bar.bar.bar.bar + +nestedFooUpdate f = f{bar.bar = f.bar} <> f{bar.bar.bar.bar}