diff --git a/ChangeLog b/ChangeLog --- a/ChangeLog +++ b/ChangeLog @@ -1,9 +1,6 @@ -2023-06-04 v1.6.1.3 - * Fix support for exact printing when using GHC option --haddock #125 -2023-05-31 v1.6.1.2 - * Add GHC 9.4.5 to CI - * Add support for exact printing when using GHC option --haddock #125 -2022-11-08 v1.6.1.1 +2022-11-08 v1.7 + * Support GHC 9.6.1 +2022-11-08 v1.6.1 * Add GHC 9.4.4 to CI * Add support for exact printing HsDocTy. #121 2022-11-08 v1.6.1 diff --git a/ghc-exactprint.cabal b/ghc-exactprint.cabal --- a/ghc-exactprint.cabal +++ b/ghc-exactprint.cabal @@ -1,11 +1,11 @@ name: ghc-exactprint -version: 1.6.1.3 +version: 1.7.0.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.4.*. For earlier GHC + Note: requires GHC 9.6.*. For earlier GHC versions see lower version numbers. . @@ -15,11 +15,7 @@ maintainer: alan.zimm@gmail.com category: Development build-type: Simple -tested-with: GHC == 9.4.1 - , GHC == 9.4.2 - , GHC == 9.4.3 - , GHC == 9.4.4 - , GHC == 9.4.5 +tested-with: GHC == 9.6.1 extra-source-files: ChangeLog tests/examples/failing/*.hs tests/examples/ghc710-only/*.hs @@ -33,6 +29,7 @@ tests/examples/ghc90/*.hs tests/examples/ghc92/*.hs tests/examples/ghc94/*.hs + tests/examples/ghc96/*.hs tests/examples/pre-ghc810/*.hs tests/examples/pre-ghc86/*.hs tests/examples/pre-ghc90/*.hs @@ -76,7 +73,7 @@ -- other-extensions: GHC-Options: -Wall -Wredundant-constraints -- GHC-Options: -Weverything - build-depends: base >=4.17 && <4.18 + build-depends: base >=4.18 && <4.19 , bytestring >= 0.10.6 , containers >= 0.5 , ordered-containers @@ -92,7 +89,7 @@ default-language: Haskell2010 - if impl (ghc < 9.4) + if impl (ghc < 9.6) buildable: False Test-Suite test @@ -111,20 +108,20 @@ GHC-Options: -threaded -Wall -Wredundant-constraints Default-language: Haskell2010 Build-depends: HUnit >= 1.2 - , base < 4.18 + , base < 4.19 , bytestring , containers >= 0.5 , ordered-containers , data-default , Diff , directory >= 1.2 + , extra , filepath >= 1.4 , ghc >= 9.4.1 , ghc-paths >= 0.1 , mtl >= 2.2.1 , syb >= 0.5 , silently >= 1.2 - , filemanip >= 0.3 -- for the lib only , fail >= 4.9 && <4.10 , ghc-boot @@ -153,7 +150,7 @@ , filepath , ghc , ghc-exactprint - -- , ghc-paths + , ghc-paths , syb , temporary , time 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 @@ -28,7 +28,6 @@ import GHC.Types.SrcLoc import GHC.Types.Var import GHC.Types.SourceText -import GHC.Unit.Module hiding ( moduleName ) import GHC.Utils.Outputable import Data.Data hiding (Fixity) @@ -139,7 +138,7 @@ _ -> parens $ text "SourceText" <+> text "blanked" epaAnchor :: EpaLocation -> SDoc - epaAnchor (EpaSpan r) = parens $ text "EpaSpan" <+> realSrcSpan r + epaAnchor (EpaSpan r _) = parens $ text "EpaSpan" <+> realSrcSpan r epaAnchor (EpaDelta d cs) = case ba of NoBlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> showAstData' cs BlankEpAnnotations -> parens $ text "EpaDelta" <+> deltaPos d <+> text "blanked" 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 @@ -1,4 +1,3 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -14,7 +13,9 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE TypeSynonymInstances #-} {-# LANGUAGE ViewPatterns #-} +{-# LANGUAGE BlockArguments #-} {-# LANGUAGE UndecidableInstances #-} -- For the (StmtLR GhcPs GhcPs (LocatedA (body GhcPs))) ExactPrint instance +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} module Language.Haskell.GHC.ExactPrint.ExactPrint ( @@ -34,8 +35,6 @@ ) where import GHC --- import GHC.Types.SrcLoc (mkRealSrcLoc, mkRealSrcSpan) -import GHC.Base (NonEmpty(..) ) import GHC.Core.Coercion.Axiom (Role(..)) import GHC.Data.Bag import qualified GHC.Data.BooleanFormula as BF @@ -44,40 +43,37 @@ import GHC.Types.Basic hiding (EP) import GHC.Types.Fixity import GHC.Types.ForeignCall -#if MIN_VERSION_ghc(9,4,3) import GHC.Types.Name.Reader -#endif -import GHC.Types.SourceText import GHC.Types.PkgQual +import GHC.Types.SourceText import GHC.Types.Var import GHC.Utils.Outputable hiding ( (<>) ) import GHC.Unit.Module.Warnings import GHC.Utils.Misc import GHC.Utils.Panic +import qualified GHC.Data.Strict as Strict --- import GHC.Types.PkgQual +import Language.Haskell.Syntax.Basic (FieldLabelString(..)) -import Control.Monad.Identity +import Control.Monad (forM, when, unless) +import Control.Monad.Identity (Identity(..)) import qualified Control.Monad.Reader as Reader -import Control.Monad.RWS +import Control.Monad.RWS (MonadReader, RWST, evalRWST, tell, modify, get, gets, ask) +import Control.Monad.Trans (lift) import Data.Data ( Data ) import Data.Dynamic import Data.Foldable import Data.Functor.Const -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, sort, sortBy) import Data.Maybe ( isJust, mapMaybe ) - import Data.Void import Language.Haskell.GHC.ExactPrint.Dump import Language.Haskell.GHC.ExactPrint.Lookup import Language.Haskell.GHC.ExactPrint.Utils import Language.Haskell.GHC.ExactPrint.Types --- import GHC.Plugins (mkRealSrcLoc) -- import Debug.Trace @@ -90,6 +86,7 @@ showAst ast = showSDocUnsafe $ showAstData NoBlankSrcSpan NoBlankEpAnnotations ast + -- --------------------------------------------------------------------- exactPrint :: ExactPrint ast => ast -> String @@ -387,7 +384,7 @@ when (flush == NoFlushComments) $ do when ((getFollowingComments cs) /= []) $ do debugM $ "starting trailing comments:" ++ showAst (getFollowingComments cs) - mapM_ printOneComment (concatMap tokComment $ getFollowingComments cs) + mapM_ printOneComment (map tokComment $ getFollowingComments cs) debugM $ "ending trailing comments" let newAchor = anchor' { anchor_op = MovedAnchor edp } @@ -403,7 +400,7 @@ -- --------------------------------------------------------------------- addCommentsA :: (Monad m, Monoid w) => [LEpaComment] -> EP w m () -addCommentsA csNew = addComments (concatMap tokComment csNew) +addCommentsA csNew = addComments (map tokComment csNew) {- TODO: When we addComments, some may have an anchor that is no longer @@ -440,7 +437,7 @@ mapM_ printOneComment (sortComments cs) debugM $ "flushing comments:EOF:trailing:" ++ showAst (trailing) debugM $ "flushing comments:EOF:" ++ showAst (filterEofComment True trailing) - mapM_ printOneComment (concatMap tokComment (filterEofComment True trailing)) + mapM_ printOneComment (map tokComment (filterEofComment True trailing)) debugM $ "flushing comments done" filterEofComment :: Bool -> [LEpaComment] -> [LEpaComment] @@ -512,17 +509,22 @@ printStringAtRsC :: (Monad m, Monoid w) => CaptureComments -> RealSrcSpan -> String -> EP w m EpaLocation printStringAtRsC capture pa str = do + debugM $ "printStringAtRsC: pa=" ++ showAst pa printComments pa pe <- getPriorEndD - debugM $ "printStringAtRs:pe=" ++ show pe + debugM $ "printStringAtRsC:pe=" ++ show pe let p = ss2delta pe pa p' <- adjustDeltaForOffsetM p + debugM $ "printStringAtRsC:(p,p')=" ++ show (p,p') printStringAtLsDelta p' str setPriorEndASTD True pa cs' <- case capture of CaptureComments -> takeAppliedComments NoCaptureComments -> return [] - debugM $ "printStringAtRs:cs'=" ++ show cs' + debugM $ "printStringAtRsC:cs'=" ++ show cs' + debugM $ "printStringAtRsC:p'=" ++ showAst p' + debugM $ "printStringAtRsC: (EpaDelta p' [])=" ++ showAst (EpaDelta p' []) + debugM $ "printStringAtRsC: (EpaDelta p' (map comment2LEpaComment cs'))=" ++ showAst (EpaDelta p' (map comment2LEpaComment cs')) return (EpaDelta p' (map comment2LEpaComment cs')) printStringAtRs' :: (Monad m, Monoid w) => RealSrcSpan -> String -> EP w m () @@ -561,9 +563,9 @@ printStringAtAAC :: (Monad m, Monoid w) => CaptureComments -> EpaLocation -> String -> EP w m EpaLocation -printStringAtAAC capture (EpaSpan r) s = printStringAtRsC capture r s +printStringAtAAC capture (EpaSpan r _) s = printStringAtRsC capture r s printStringAtAAC capture (EpaDelta d cs) s = do - mapM_ printOneComment $ concatMap tokComment cs + mapM_ (printOneComment . tokComment) cs pe1 <- getPriorEndD p1 <- getPosP printStringAtLsDelta d s @@ -724,12 +726,10 @@ type ASetter a b = (b -> Identity b) -> (a -> Identity a) view :: MonadReader s m => Getting s a -> m a --- view l = Reader.asks (getConst #. l Const) view l = Reader.asks (getConst . l Const) {-# INLINE view #-} over :: ASetter a b -> (b -> b) -> (a -> a) --- over l f = runIdentity #. l (Identity #. f) over l f = runIdentity . l (Identity . f) {-# INLINE over #-} @@ -1121,13 +1121,6 @@ t <- markTrailing (lann_trailing a) return (EpAnn anc (a { lann_trailing = t }) cs) --- TODO: Deprecate in favour of markEpAnnL -markEpAnn :: (Monad m, Monoid w) - => EpAnn [AddEpAnn] -> AnnKeywordId -> EP w m Int -- Return something to trigger not used warning -markEpAnn EpAnnNotUsed _ = return 1 -markEpAnn (EpAnn _ a _) kw = mark a kw >> return 1 - - markEpAnnL :: (Monad m, Monoid w) => EpAnn ann -> Lens ann [AddEpAnn] -> AnnKeywordId -> EP w m (EpAnn ann) markEpAnnL EpAnnNotUsed _ _ = return EpAnnNotUsed @@ -1154,14 +1147,6 @@ [a'] -> return a' _ -> error "Should not happen: markAddEpAnn" -mark :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m Int -mark anns kw = do - case find (\(AddEpAnn k _) -> k == kw) anns of - Just aa -> markKw aa >> return 1 - Nothing -> case find (\(AddEpAnn k _) -> k == (unicodeAnn kw)) anns of - Just aau -> markKw aau >> return 1 - Nothing -> return 1 - mark' :: (Monad m, Monoid w) => [AddEpAnn] -> AnnKeywordId -> EP w m [AddEpAnn] mark' anns kw = do case find' kw anns of @@ -1309,7 +1294,6 @@ (r,c) = ss2posEnd pp la = anchor anc dp'' = if r == 0 - -- then (ss2delta (r,c+1) la) then (ss2delta (r,c+0) la) else (ss2delta (r,c) la) dp' = if pp == anchor anc @@ -1396,16 +1380,16 @@ -- --------------------------------------------------------------------- -- | 'Located (HsModule GhcPs)' corresponds to 'ParsedSource' -instance ExactPrint HsModule where - getAnnotationEntry hsmod = fromAnn' (hsmodAnn hsmod) +instance ExactPrint (HsModule GhcPs) where + getAnnotationEntry hsmod = fromAnn' (hsmodAnn $ hsmodExt 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 + exact hsmod@(HsModule {hsmodExt = XModulePs { hsmodAnn = EpAnnNotUsed }}) = withPpr hsmod >> return hsmod + exact (HsModule (XModulePs an lo mdeprec mbDoc) mmn mexports imports decls) = do - let mbDoc' = mbDoc - -- mbDoc' <- markAnnotated mbDoc + mbDoc' <- markAnnotated mbDoc (an0, mmn' , mdeprec', mexports') <- case mmn of @@ -1415,9 +1399,7 @@ m' <- markAnnotated m mdeprec' <- setLayoutTopLevelP $ markAnnotated mdeprec - mexports' <- setLayoutTopLevelP $ markAnnotated mexports - an1 <- setLayoutTopLevelP $ markEpAnnL an0 lam_main AnnWhere return (an1, Just m', mdeprec', mexports') @@ -1434,7 +1416,7 @@ let anf = an0 { anns = (anns an0) { am_decls = am_decls' }} debugM $ "HsModule, anf=" ++ showAst anf - return (HsModule anf lo mmn' mexports' imports' decls' mdeprec' mbDoc') + return (HsModule (XModulePs anf lo mdeprec' mbDoc') mmn' mexports' imports' decls') -- --------------------------------------------------------------------- @@ -1471,11 +1453,13 @@ -- --------------------------------------------------------------------- instance ExactPrint (ImportDecl GhcPs) where - getAnnotationEntry idecl = fromAnn (ideclExt idecl) - setAnnotationAnchor idecl anc cs = idecl { ideclExt = setAnchorEpa (ideclExt idecl) anc cs } + getAnnotationEntry idecl = fromAnn (ideclAnn $ ideclExt idecl) + setAnnotationAnchor idecl anc cs = idecl { ideclExt + = (ideclExt idecl) { ideclAnn = setAnchorEpa (ideclAnn $ ideclExt idecl) anc cs} } - exact x@(ImportDecl EpAnnNotUsed _ _ _ _ _ _ _ _ _) = withPpr x - exact (ImportDecl ann msrc m mpkg src safeflag qualFlag impl mAs hiding) = do + exact x@(ImportDecl{ ideclExt = XImportDeclPass{ ideclAnn = EpAnnNotUsed } }) = withPpr x + exact (ImportDecl (XImportDeclPass ann msrc impl) + modname mpkg src safeflag qualFlag mAs hiding) = do ann0 <- markLensKw ann limportDeclAnnImport AnnImport let (EpAnn _anc an _cs) = ann0 @@ -1508,7 +1492,7 @@ RawPkgQual (StringLiteral src' v _) -> printStringAtMLocL ann2 limportDeclAnnPackage (sourceTextToString src' (show v)) _ -> return ann2 - m' <- markAnnotated m + modname' <- markAnnotated modname ann4 <- case qualFlag of @@ -1536,7 +1520,8 @@ , importDeclAnnPragma = importDeclAnnPragma' } - return (ImportDecl (EpAnn anc' an2 cs') msrc m' mpkg src safeflag qualFlag impl mAs' hiding') + return (ImportDecl (XImportDeclPass (EpAnn anc' an2 cs') msrc impl) + modname' mpkg src safeflag qualFlag mAs' hiding') -- --------------------------------------------------------------------- @@ -1544,26 +1529,9 @@ instance ExactPrint HsDocString where getAnnotationEntry _ = NoEntryVal setAnnotationAnchor a _ _ = a - exact (MultiLineDocString decorator (x :| xs)) = do - printStringAdvance ("-- " ++ printDecorator decorator) - pe <- getPriorEndD - debugM $ "MultiLineDocString: (pe,x)=" ++ showAst (pe,x) - x' <- markAnnotated x - xs' <- markAnnotated (map dedentDocChunk xs) - return (MultiLineDocString decorator (x' :| xs')) - exact x = do - -- TODO: can this happen? - debugM $ "Not exact printing:" ++ showAst x - return x - - -instance ExactPrint HsDocStringChunk where - getAnnotationEntry _ = NoEntryVal - setAnnotationAnchor a _ _ = a - exact chunk = do - printStringAdvance ("--" ++ unpackHDSC chunk) - return chunk - + exact ds = do + (printStringAdvance . exactPrintHsDocString) ds + return ds instance ExactPrint a => ExactPrint (WithHsDocIdentifiers a GhcPs) where getAnnotationEntry _ = NoEntryVal @@ -1622,9 +1590,9 @@ exact (ClsInstD a cid) = do cid' <- markAnnotated cid return (ClsInstD a cid') - exact (DataFamInstD x decl) = do + exact (DataFamInstD a decl) = do d' <- markAnnotated (DataFamInstDeclWithContext noAnn TopLevel decl) - return (DataFamInstD x (dc_d d')) + return (DataFamInstD a (dc_d d')) exact (TyFamInstD a eqn) = do eqn' <- markAnnotated eqn return (TyFamInstD a eqn') @@ -1633,7 +1601,7 @@ data DataFamInstDeclWithContext = DataFamInstDeclWithContext - { _dc_a :: EpAnn [AddEpAnn] -- TODO: remove this field + { _dc_a :: EpAnn [AddEpAnn] , _dc_f :: TopLevelFlag , dc_d :: DataFamInstDecl GhcPs } @@ -1741,25 +1709,25 @@ -- --------------------------------------------------------------------- -instance ExactPrint ForeignImport where +instance ExactPrint (ForeignImport GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (CImport cconv safety@(L ll _) mh imp (L ls src)) = do + exact (CImport (L ls src) cconv safety@(L ll _) mh imp) = do cconv' <- markAnnotated cconv unless (ll == noSrcSpan) $ markAnnotated safety >> return () unless (ls == noSrcSpan) $ markExternalSourceText ls src "" >> return () - return (CImport cconv' safety mh imp (L ls src)) + return (CImport (L ls src) cconv' safety mh imp) -- --------------------------------------------------------------------- -instance ExactPrint ForeignExport where +instance ExactPrint (ForeignExport GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (CExport spec (L ls src)) = do + exact (CExport (L ls src) spec) = do debugM $ "CExport starting" spec' <- markAnnotated spec unless (ls == noSrcSpan) $ markExternalSourceText ls src "" - return (CExport spec' (L ls src)) + return (CExport (L ls src) spec') -- --------------------------------------------------------------------- @@ -1788,14 +1756,14 @@ -- --------------------------------------------------------------------- instance ExactPrint (WarnDecls GhcPs) where - getAnnotationEntry (Warnings an _ _) = fromAnn an - setAnnotationAnchor (Warnings an a b) anc cs = Warnings (setAnchorEpa an anc cs) a b + getAnnotationEntry (Warnings (an,_) _) = fromAnn an + setAnnotationAnchor (Warnings (an,a) b) anc cs = Warnings ((setAnchorEpa an anc cs),a) b - exact (Warnings an src warns) = do + exact (Warnings (an,src) warns) = do an0 <- markAnnOpen an src "{-# WARNING" -- Note: might be {-# DEPRECATED warns' <- markAnnotated warns an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (Warnings an1 src warns') + return (Warnings (an1,src) warns') -- --------------------------------------------------------------------- @@ -1838,29 +1806,29 @@ -- exact fs = printStringAdvance (show (unpackFS fs)) exact fs = printStringAdvance (unpackFS fs) >> return fs - -- --------------------------------------------------------------------- instance ExactPrint (RuleDecls GhcPs) where - getAnnotationEntry (HsRules an _ _) = fromAnn an - setAnnotationAnchor (HsRules an a b) anc cs = HsRules (setAnchorEpa an anc cs) a b - exact (HsRules an src rules) = do + getAnnotationEntry (HsRules (an,_) _) = fromAnn an + setAnnotationAnchor (HsRules (an,a) b) anc cs = HsRules ((setAnchorEpa an anc cs),a) b + exact (HsRules (an, src) rules) = do an0 <- case src of NoSourceText -> markEpAnnLMS an lidl AnnOpen (Just "{-# RULES") SourceText srcTxt -> markEpAnnLMS an lidl AnnOpen (Just srcTxt) rules' <- markAnnotated rules an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (HsRules an1 src rules') + return (HsRules (an1,src) rules') -- --------------------------------------------------------------------- instance ExactPrint (RuleDecl GhcPs) where - getAnnotationEntry (HsRule {rd_ext = an}) = fromAnn an - setAnnotationAnchor r anc cs = r { rd_ext = setAnchorEpa (rd_ext r) anc cs} - exact (HsRule an ln act mtybndrs termbndrs lhs rhs) = do + getAnnotationEntry (HsRule {rd_ext = (an,_)}) = fromAnn an + setAnnotationAnchor r@(HsRule {rd_ext = (an,a)}) anc cs + = r { rd_ext = (setAnchorEpa an anc cs, a)} + exact (HsRule (an,nsrc) (L ln n) act mtybndrs termbndrs lhs rhs) = do debugM "HsRule entered" - ln' <- markAnnotated ln + (L ln' _) <- markAnnotated (L ln (nsrc, n)) debugM "HsRule after ln" an0 <- markActivation an lra_rest act debugM "HsRule after act" @@ -1880,7 +1848,7 @@ lhs' <- markAnnotated lhs an4 <- markEpAnnL an3 lra_rest AnnEqual rhs' <- markAnnotated rhs - return (HsRule an4 ln' act mtybndrs' termbndrs' lhs' rhs') + return (HsRule (an4,nsrc) (L ln' n) act mtybndrs' termbndrs' lhs' rhs') markActivation :: (Monad m, Monoid w) => EpAnn a -> Lens a [AddEpAnn] -> Activation -> EP w m (EpAnn a) @@ -1920,12 +1888,11 @@ getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact v = 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 + 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 -- --------------------------------------------------------------------- @@ -2145,7 +2112,7 @@ setAnnotationAnchor pb@PatBind{} anc cs = pb { pat_ext = setAnchorEpa (pat_ext pb) anc cs} setAnnotationAnchor a _ _ = a - exact (FunBind x fid matches t) = do + exact (FunBind x fid matches) = do matches' <- markAnnotated matches let fun_id' = case unLoc (mg_alts matches') of @@ -2153,11 +2120,12 @@ (L _ m:_) -> case m_ctxt m of FunRhs f _ _ -> f _ -> fid - return (FunBind x fun_id' matches' t) - exact (PatBind x pat grhss t) = do + return (FunBind x fun_id' matches') + + exact (PatBind x pat grhss) = do pat' <- markAnnotated pat grhss' <- markAnnotated grhss - return (PatBind x pat' grhss' t) + return (PatBind x pat' grhss') exact (PatSynBind x bind) = do bind' <- markAnnotated bind return (PatSynBind x bind') @@ -2328,36 +2296,15 @@ -- --------------------------------------------------------------------- --- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/20247 --- is fixed -fixValbindsAnn :: EpAnn AnnList -> EpAnn AnnList -fixValbindsAnn EpAnnNotUsed = EpAnnNotUsed -fixValbindsAnn (EpAnn anchor (AnnList ma o c r t) cs) - = (EpAnn (widenAnchor anchor (map trailingAnnToAddEpAnn t)) (AnnList ma o c r t) cs) - - --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 -fixAnnListAnn :: EpAnn AnnList -> EpAnn AnnList -fixAnnListAnn EpAnnNotUsed = EpAnnNotUsed -fixAnnListAnn (EpAnn anchor (AnnList ma o c r t) cs) - = (EpAnn (widenAnchor anchor r) (AnnList ma o c r t) cs) - --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 -fixSrcAnnL :: SrcSpanAnnL -> SrcSpanAnnL -fixSrcAnnL (SrcSpanAnn an l) = SrcSpanAnn (fixAnnListAnn an) l - --- --------------------------------------------------------------------- - instance ExactPrint (HsLocalBinds GhcPs) where - getAnnotationEntry (HsValBinds an _) = fromAnn (fixValbindsAnn an) + getAnnotationEntry (HsValBinds an _) = fromAnn an getAnnotationEntry (HsIPBinds{}) = NoEntryVal getAnnotationEntry (EmptyLocalBinds{}) = NoEntryVal setAnnotationAnchor (HsValBinds an a) anc cs = HsValBinds (setAnchorEpaL an anc cs) a setAnnotationAnchor a _ _ = a - exact (HsValBinds an' valbinds) = do - let an = fixValbindsAnn an' + exact (HsValBinds an valbinds) = do debugM $ "exact HsValBinds: an=" ++ showAst an an0 <- markEpAnnL an lal_rest AnnWhere @@ -2474,26 +2421,24 @@ getAnnotationEntry (TypeSig a _ _) = fromAnn a getAnnotationEntry (PatSynSig a _ _) = fromAnn a getAnnotationEntry (ClassOpSig a _ _ _) = fromAnn a - getAnnotationEntry (IdSig {}) = NoEntryVal getAnnotationEntry (FixSig a _) = fromAnn a getAnnotationEntry (InlineSig a _ _) = fromAnn a getAnnotationEntry (SpecSig a _ _ _) = fromAnn a - getAnnotationEntry (SpecInstSig a _ _) = fromAnn a - getAnnotationEntry (MinimalSig a _ _) = fromAnn a - getAnnotationEntry (SCCFunSig a _ _ _) = fromAnn a - getAnnotationEntry (CompleteMatchSig a _ _ _) = fromAnn a + getAnnotationEntry (SpecInstSig (a, _) _) = fromAnn a + getAnnotationEntry (MinimalSig (a, _) _) = fromAnn a + getAnnotationEntry (SCCFunSig (a, _) _ _) = fromAnn a + getAnnotationEntry (CompleteMatchSig (a, _) _ _) = fromAnn a setAnnotationAnchor (TypeSig a x y) anc cs = (TypeSig (setAnchorEpa a anc cs) x y) setAnnotationAnchor (PatSynSig a x y) anc cs = (PatSynSig (setAnchorEpa a anc cs) x y) setAnnotationAnchor (ClassOpSig a x y z) anc cs = (ClassOpSig (setAnchorEpa a anc cs) x y z) - setAnnotationAnchor i@(IdSig {}) _ _s = i setAnnotationAnchor (FixSig a x) anc cs = (FixSig (setAnchorEpa a anc cs) x) setAnnotationAnchor (InlineSig a x y) anc cs = (InlineSig (setAnchorEpa a anc cs) x y) setAnnotationAnchor (SpecSig a x y z) anc cs = (SpecSig (setAnchorEpa a anc cs) x y z) - setAnnotationAnchor (SpecInstSig a x y) anc cs = (SpecInstSig (setAnchorEpa a anc cs) x y) - setAnnotationAnchor (MinimalSig a x y) anc cs = (MinimalSig (setAnchorEpa a anc cs) x y) - setAnnotationAnchor (SCCFunSig a x y z) anc cs = (SCCFunSig (setAnchorEpa a anc cs) x y z) - setAnnotationAnchor (CompleteMatchSig a x y z) anc cs = (CompleteMatchSig (setAnchorEpa a anc cs) x y z) + setAnnotationAnchor (SpecInstSig (a,x) y) anc cs = (SpecInstSig ((setAnchorEpa a anc cs),x) y) + setAnnotationAnchor (MinimalSig (a,x) y) anc cs = (MinimalSig ((setAnchorEpa a anc cs),x) y) + setAnnotationAnchor (SCCFunSig (a,x) y z) anc cs = (SCCFunSig ((setAnchorEpa a anc cs),x) y z) + setAnnotationAnchor (CompleteMatchSig (a,x) y z) anc cs = (CompleteMatchSig ((setAnchorEpa a anc cs),x) y z) exact (TypeSig an vars ty) = do (an', vars', ty') <- exactVarSig an vars ty @@ -2545,27 +2490,27 @@ an3 <- markEpAnnLMS an2 lidl AnnClose (Just "#-}") return (SpecSig an3 ln' typs' inl) - exact (SpecInstSig an src typ) = do + exact (SpecInstSig (an,src) typ) = do an0 <- markAnnOpen an src "{-# SPECIALISE" an1 <- markEpAnnL an0 lidl AnnInstance typ' <- markAnnotated typ an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") - return (SpecInstSig an2 src typ') + return (SpecInstSig (an2,src) typ') - exact (MinimalSig an src formula) = do + exact (MinimalSig (an,src) formula) = do an0 <- markAnnOpen an src "{-# MINIMAL" formula' <- markAnnotated formula an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (MinimalSig an1 src formula') + return (MinimalSig (an1,src) formula') - exact (SCCFunSig an src ln ml) = do + exact (SCCFunSig (an,src) ln ml) = do an0 <- markAnnOpen an src "{-# SCC" ln' <- markAnnotated ln ml' <- markAnnotated ml an1 <- markEpAnnLMS an0 lidl AnnClose (Just "#-}") - return (SCCFunSig an1 src ln' ml') + return (SCCFunSig (an1,src) ln' ml') - exact (CompleteMatchSig an src cs mty) = do + exact (CompleteMatchSig (an,src) cs mty) = do an0 <- markAnnOpen an src "{-# COMPLETE" cs' <- markAnnotated cs (an1, mty') <- @@ -2576,9 +2521,7 @@ ty' <- markAnnotated ty return (an1, Just ty') an2 <- markEpAnnLMS an1 lidl AnnClose (Just "#-}") - return (CompleteMatchSig an2 src cs' mty') - - exact x = error $ "exact Sig for:" ++ showAst x + return (CompleteMatchSig (an2,src) cs' mty') -- --------------------------------------------------------------------- @@ -2619,10 +2562,10 @@ -- --------------------------------------------------------------------- instance ExactPrint (AnnDecl GhcPs) where - getAnnotationEntry (HsAnnotation an _ _ _) = fromAnn an - setAnnotationAnchor (HsAnnotation an a b c) anc cs = HsAnnotation (setAnchorEpa an anc cs) a b c + getAnnotationEntry (HsAnnotation (an, _) _ _) = fromAnn an + setAnnotationAnchor (HsAnnotation (an,a) b c) anc cs = HsAnnotation ((setAnchorEpa an anc cs),a) b c - exact (HsAnnotation an src prov e) = do + exact (HsAnnotation (an, src) prov e) = do an0 <- markAnnOpenP an src "{-# ANN" (an1, prov') <- case prov of @@ -2639,7 +2582,7 @@ e' <- markAnnotated e an2 <- markAnnCloseP an1 - return (HsAnnotation an2 src prov' e') + return (HsAnnotation (an2,src) prov' e') -- --------------------------------------------------------------------- @@ -2704,14 +2647,14 @@ getAnnotationEntry (HsVar{}) = NoEntryVal getAnnotationEntry (HsUnboundVar an _) = fromAnn an getAnnotationEntry (HsRecSel{}) = NoEntryVal - getAnnotationEntry (HsOverLabel an _) = fromAnn an + 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 (HsApp an _ _) = fromAnn an - getAnnotationEntry (HsAppType _ _ _) = NoEntryVal + getAnnotationEntry (HsAppType _ _ _ _) = NoEntryVal getAnnotationEntry (OpApp an _ _ _) = fromAnn an getAnnotationEntry (NegApp an _ _) = fromAnn an getAnnotationEntry (HsPar an _ _ _) = fromAnn an @@ -2733,7 +2676,8 @@ getAnnotationEntry (ArithSeq an _ _) = fromAnn an getAnnotationEntry (HsTypedBracket an _) = fromAnn an getAnnotationEntry (HsUntypedBracket an _) = fromAnn an - getAnnotationEntry (HsSpliceE an _) = fromAnn an + getAnnotationEntry (HsTypedSplice (_, an) _) = fromAnn an + getAnnotationEntry (HsUntypedSplice an _) = fromAnn an getAnnotationEntry (HsProc an _ _) = fromAnn an getAnnotationEntry (HsStatic an _) = fromAnn an getAnnotationEntry (HsPragE{}) = NoEntryVal @@ -2741,14 +2685,14 @@ setAnnotationAnchor a@(HsVar{}) _ _s = a setAnnotationAnchor (HsUnboundVar an a) anc cs = (HsUnboundVar (setAnchorEpa an anc cs) a) setAnnotationAnchor a@(HsRecSel{}) _ _s = a - setAnnotationAnchor (HsOverLabel an a) anc cs = (HsOverLabel (setAnchorEpa an anc cs) a) + setAnnotationAnchor (HsOverLabel an s a) anc cs = (HsOverLabel (setAnchorEpa an anc cs) s 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 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 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 b c) anc cs = (HsPar (setAnchorEpa an anc cs) a b c) @@ -2770,9 +2714,10 @@ setAnnotationAnchor (ArithSeq an a b) anc cs = (ArithSeq (setAnchorEpa an anc cs) a b) 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 (HsTypedSplice (x,an) e) anc cs = (HsTypedSplice (x,(setAnchorEpa an anc cs)) e) + setAnnotationAnchor (HsUntypedSplice an e) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) e) + 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@(HsPragE{}) _ _s = a exact (HsVar x n) = do @@ -2786,8 +2731,16 @@ printStringAtAA l "_" >> return () printStringAtAA cb "`" >> return () return x - -- exact x@(HsRecSel{}) = withPpr x - exact x@(HsOverLabel _ _) = withPpr x + exact x@(HsOverLabel an src l) = do + let str = "#" ++ case src of + NoSourceText -> (unpackFS l) + SourceText txt -> txt + case an of + EpAnnNotUsed -> printString True str + EpAnn anc _ _ -> do + _ <- markAnnotated (L (RealSrcSpan (anchor anc) Strict.Nothing) (fsLit str)) + return () + return x exact x@(HsIPVar _ (HsIPName n)) = printStringAdvance ("?" ++ unpackFS n) >> return x @@ -2822,11 +2775,11 @@ e1' <- markAnnotated e1 e2' <- markAnnotated e2 return (HsApp an e1' e2') - exact (HsAppType ss fun arg) = do + exact (HsAppType ss fun at arg) = do fun' <- markAnnotated fun - printStringAtSs ss "@" + at' <- markToken at arg' <- markAnnotated arg - return (HsAppType ss fun' arg') + return (HsAppType ss fun' at' arg') exact (OpApp an e1 e2 e3) = do e1' <- markAnnotated e1 e2' <- markAnnotated e2 @@ -3004,9 +2957,9 @@ exact (HsUntypedBracket an (DecBrL a e)) = do an0 <- markEpAnnLMS an lidl AnnOpen (Just "[d|") - an1 <- markEpAnnL an0 lidl AnnOpenC -- "{" -- optional + an1 <- markEpAnnL an0 lidl AnnOpenC e' <- markAnnotated e - an2 <- markEpAnnL an1 lidl AnnCloseC -- "}" -- optional + an2 <- markEpAnnL an1 lidl AnnCloseC an3 <- markEpAnnL an2 lidl AnnCloseQ -- "|]" return (HsUntypedBracket an3 (DecBrL a e')) @@ -3028,9 +2981,13 @@ return (an', e') return (HsUntypedBracket an0 (VarBr a b e')) - exact (HsSpliceE a sp) = do - sp' <- markAnnotated sp - return (HsSpliceE a sp') + exact (HsTypedSplice (x,an) s) = do + an0 <- markEpAnnL an lidl AnnDollarDollar + s' <- exact s + return (HsTypedSplice (x,an0) s') + exact (HsUntypedSplice an s) = do + s' <- exact s + return (HsUntypedSplice an s') exact (HsProc an p c) = do debugM $ "HsProc start" @@ -3084,41 +3041,30 @@ getAnnotationEntry HsPragSCC{} = NoEntryVal setAnnotationAnchor a _ _ = a - exact (HsPragSCC an st sl) = do + exact (HsPragSCC (an,st) sl) = do an0 <- markAnnOpenP an st "{-# SCC" let txt = sourceTextToString (sl_st sl) (unpackFS $ sl_fs sl) an1 <- markEpAnnLMS an0 lapr_rest AnnVal (Just txt) -- optional an2 <- markEpAnnLMS an1 lapr_rest AnnValStr (Just txt) -- optional an3 <- markAnnCloseP an2 - return (HsPragSCC an3 st sl) + return (HsPragSCC (an3,st) sl) -- --------------------------------------------------------------------- -instance ExactPrint (HsSplice GhcPs) where - getAnnotationEntry (HsTypedSplice an _ _ _) = fromAnn an - getAnnotationEntry (HsUntypedSplice an _ _ _) = fromAnn an - getAnnotationEntry (HsQuasiQuote _ _ _ _ _) = NoEntryVal - getAnnotationEntry (HsSpliced _ _ _) = NoEntryVal +instance ExactPrint (HsUntypedSplice GhcPs) where + getAnnotationEntry (HsUntypedSpliceExpr an _) = fromAnn an + getAnnotationEntry (HsQuasiQuote _ _ _) = NoEntryVal - setAnnotationAnchor (HsTypedSplice an a b c) anc cs = (HsTypedSplice (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor (HsUntypedSplice an a b c) anc cs = (HsUntypedSplice (setAnchorEpa an anc cs) a b c) - setAnnotationAnchor a@(HsQuasiQuote _ _ _ _ _) _ _ = a - setAnnotationAnchor a@(HsSpliced _ _ _) _ _ = a + setAnnotationAnchor (HsUntypedSpliceExpr an e) anc cs = HsUntypedSpliceExpr (setAnchorEpa an anc cs) e + setAnnotationAnchor a@HsQuasiQuote {} _ _ = a - exact (HsTypedSplice an DollarSplice n e) = do - an0 <- markEpAnnL an lidl AnnDollarDollar + exact (HsUntypedSpliceExpr an e) = do + an0 <- markEpAnnL an lidl AnnDollar e' <- markAnnotated e - return (HsTypedSplice an0 DollarSplice n e') - - exact (HsUntypedSplice an decoration n b) = do - an0 <- if (decoration == DollarSplice) - then markEpAnnL an lidl AnnDollar - else return an - b' <- markAnnotated b - return (HsUntypedSplice an0 decoration n b') + return (HsUntypedSpliceExpr an0 e') - exact (HsQuasiQuote a b q ss fs) = do + exact (HsQuasiQuote an q (L l fs)) = do -- The quasiquote string does not honour layout offsets. Store -- the colOffset for now. -- TODO: use local? @@ -3129,11 +3075,7 @@ -- Note: Lexer.x does not provide unicode alternative. 2017-02-26 ("[" ++ (showPprUnsafe q) ++ "|" ++ (unpackFS fs) ++ "|]") unless pMarkLayout $ setLayoutOffsetP oldOffset - p <- getPosP - debugM $ "HsQuasiQuote:after:(p,ss)=" ++ show (p,ss2range ss) - return (HsQuasiQuote a b q ss fs) - - exact x = error $ "exact HsSplice for:" ++ showAst x + return (HsQuasiQuote an q (L l fs)) -- --------------------------------------------------------------------- @@ -3141,22 +3083,22 @@ instance ExactPrint (MatchGroup GhcPs (LocatedA (HsExpr GhcPs))) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (MG x matches o) = do + exact (MG x matches) = do -- TODO:AZ use SortKey, in MG ann. matches' <- if isGoodSrcSpan (getLocA matches) then markAnnotated matches else return matches - return (MG x matches' o) + return (MG x matches') instance ExactPrint (MatchGroup GhcPs (LocatedA (HsCmd GhcPs))) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (MG x matches o) = do + exact (MG x matches) = do -- TODO:AZ use SortKey, in MG ann. matches' <- if isGoodSrcSpan (getLocA matches) then markAnnotated matches else return matches - return (MG x matches' o) + return (MG x matches') -- --------------------------------------------------------------------- @@ -3248,19 +3190,12 @@ setAnnotationAnchor (DotFieldOcc an a) anc cs = DotFieldOcc (setAnchorEpa an anc cs) a -#if MIN_VERSION_ghc(9,4,3) - exact (DotFieldOcc an (L loc fs)) = do + exact (DotFieldOcc an (L loc (FieldLabelString fs))) = do an0 <- markLensKwM an lafDot AnnDot -- The field name has a SrcSpanAnnN, print it as a -- LocatedN RdrName L loc' _ <- markAnnotated (L loc (mkVarUnqual fs)) - return (DotFieldOcc an0 (L loc' fs)) -#else - exact (DotFieldOcc an fs) = do - an0 <- markLensKwM an lafDot AnnDot - fs' <- markAnnotated fs - return (DotFieldOcc an0 fs') -#endif + return (DotFieldOcc an0 (L loc' (FieldLabelString fs))) -- --------------------------------------------------------------------- @@ -3439,10 +3374,7 @@ return (BindStmt an0 pat' body') exact (ApplicativeStmt _ _body _) = do - debugM $ "ApplicativeStmt" - -- TODO: ApplicativeStmt - -- markAnnotated body - error $ "need to complete ApplicativeStmt" + error $ "ApplicativeStmt is introduced in the renamer" exact (BodyStmt a body b c) = do debugM $ "BodyStmt" @@ -3466,17 +3398,12 @@ (an', by', using') <- exactTransStmt an by using form return (TransStmt an' form stmts' b using' by' c d e) - exact (RecStmt an stmts a b c d e) = do debugM $ "RecStmt" an0 <- markEpAnnL an lal_rest AnnRec (an1, stmts') <- markAnnList True an0 (markAnnotated stmts) return (RecStmt an1 stmts' a b c d e) - -- exact x = error $ "exact CmdLStmt for:" ++ showAst x - -- exact x = error $ "exact CmdLStmt for:" - - -- --------------------------------------------------------------------- instance ExactPrint (ParStmtBlock GhcPs GhcPs) where @@ -3516,17 +3443,17 @@ -- --------------------------------------------------------------------- instance ExactPrint (TyClDecl GhcPs) where - getAnnotationEntry (FamDecl { }) = NoEntryVal - getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an - getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an - getAnnotationEntry (ClassDecl { tcdCExt = (an, _, _) }) = fromAnn an + getAnnotationEntry (FamDecl { }) = NoEntryVal + getAnnotationEntry (SynDecl { tcdSExt = an }) = fromAnn an + getAnnotationEntry (DataDecl { tcdDExt = an }) = fromAnn an + getAnnotationEntry (ClassDecl { tcdCExt = (an, _) }) = fromAnn an setAnnotationAnchor a@FamDecl{} _ _s = a setAnnotationAnchor x@SynDecl{} anc cs = x { tcdSExt = setAnchorEpa (tcdSExt x) anc cs } setAnnotationAnchor x@DataDecl{} anc cs = x { tcdDExt = setAnchorEpa (tcdDExt x) anc cs } - setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a, b) } + setAnnotationAnchor x@ClassDecl{} anc cs = x { tcdCExt = (setAnchorEpa an anc cs, a) } where - (an,a,b) = tcdCExt x + (an,a) = tcdCExt x exact (FamDecl a decl) = do decl' <- markAnnotated decl @@ -3558,7 +3485,8 @@ -- ----------------------------------- - exact (ClassDecl {tcdCExt = (an, sortKey, lo), + exact (ClassDecl {tcdCExt = (an, sortKey), + tcdLayout = lo, tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFixity = fixity, tcdFDs = fds, @@ -3571,7 +3499,8 @@ (an0, fds', lclas', tyvars',context') <- top_matter an1 <- markEpAnnL an0 lidl AnnOpenC an2 <- markEpAnnL an1 lidl AnnCloseC - return (ClassDecl {tcdCExt = (an2, sortKey, lo), + return (ClassDecl {tcdCExt = (an2, sortKey), + tcdLayout = lo, tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', @@ -3597,7 +3526,8 @@ methods' = listToBag $ undynamic ds ats' = undynamic ds at_defs' = undynamic ds - return (ClassDecl {tcdCExt = (an3, sortKey, lo), + return (ClassDecl {tcdCExt = (an3, sortKey), + tcdLayout = lo, tcdCtxt = context', tcdLName = lclas', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', @@ -3724,14 +3654,21 @@ , EpAnn [AddEpAnn] -- ^ updated one passed in , LocatedN RdrName, a, b, Maybe (LHsContext GhcPs), HsDataDefn GhcPs) exactDataDefn an exactHdr - (HsDataDefn { dd_ext = x, dd_ND = new_or_data, dd_ctxt = context + (HsDataDefn { dd_ext = x, dd_ctxt = context , dd_cType = mb_ct , dd_kindSig = mb_sig , dd_cons = condecls, dd_derivs = derivings }) = do + an' <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] - an0 <- if new_or_data == DataType - then markEpAnnL an' lidl AnnData - else markEpAnnL an' lidl AnnNewtype + + an00 <- if isTypeDataDefnCons condecls + then markEpAnnL an' lidl AnnType + else return an' + + an0 <- markEpAnnL an00 lidl $ case condecls of + DataTypeCons _ _ -> AnnData + NewTypeCon _ -> AnnNewtype + an1 <- markEpAnnL an0 lidl AnnInstance -- optional mb_ct' <- mapM markAnnotated mb_ct (anx, ln', tvs', b, mctxt') <- exactHdr context @@ -3741,18 +3678,23 @@ an2 <- markEpAnnL an1 lidl AnnDcolon kind' <- markAnnotated kind return (an2, Just kind') - an3 <- if (isGadt condecls) + an3 <- if (needsWhere condecls) then markEpAnnL an2 lidl AnnWhere else return an2 an4 <- markEpAnnL an3 lidl AnnOpenC - (an5, condecls') <- exact_condecls an4 condecls + (an5, condecls') <- exact_condecls an4 (toList condecls) + let condecls'' = case condecls of + DataTypeCons d _ -> DataTypeCons d condecls' + NewTypeCon _ -> case condecls' of + [decl] -> NewTypeCon decl + _ -> panic "exacprint NewTypeCon" an6 <- markEpAnnL an5 lidl AnnCloseC derivings' <- mapM markAnnotated derivings return (anx, an6, ln', tvs', b, mctxt', - (HsDataDefn { dd_ext = x, dd_ND = new_or_data, dd_ctxt = context + (HsDataDefn { dd_ext = x, dd_ctxt = context , dd_cType = mb_ct' , dd_kindSig = mb_sig' - , dd_cons = condecls', dd_derivs = derivings' })) + , dd_cons = condecls'', dd_derivs = derivings' })) exactVanillaDeclHead :: (Monad m, Monoid w) @@ -3980,8 +3922,8 @@ return (HsSpliceTy a splice') exact (HsDocTy an ty doc) = do ty' <- markAnnotated ty - -- doc' <- markAnnotated doc - return (HsDocTy an ty' doc) + doc' <- markAnnotated doc + return (HsDocTy an ty' doc') exact (HsBangTy an (HsSrcBang mt up str) ty) = do an0 <- case mt of @@ -4081,11 +4023,19 @@ setAnnotationAnchor (NewtypeStrategy an) anc cs = (NewtypeStrategy (setAnchorEpa an anc cs)) setAnnotationAnchor (ViaStrategy (XViaStrategyPs an a)) anc cs = (ViaStrategy (XViaStrategyPs (setAnchorEpa an anc cs) a)) - exact s@(StockStrategy an) = markEpAnn an AnnStock >> return s - exact s@(AnyclassStrategy an) = markEpAnn an AnnAnyclass >> return s - exact s@(NewtypeStrategy an) = markEpAnn an AnnNewtype >> return s - exact s@(ViaStrategy (XViaStrategyPs an ty)) - = markEpAnn an AnnVia >> markAnnotated ty >> return s + exact (StockStrategy an) = do + an0 <- markEpAnnL an lid AnnStock + return (StockStrategy an0) + exact (AnyclassStrategy an) = do + an0 <- markEpAnnL an lid AnnAnyclass + return (AnyclassStrategy an0) + exact (NewtypeStrategy an) = do + an0 <- markEpAnnL an lid AnnNewtype + return (NewtypeStrategy an0) + exact (ViaStrategy (XViaStrategyPs an ty)) = do + an0 <- markEpAnnL an lid AnnVia + ty' <- markAnnotated ty + return (ViaStrategy (XViaStrategyPs an0 ty')) -- --------------------------------------------------------------------- @@ -4194,7 +4144,7 @@ s -> s loc <- printStringAtAAC NoCaptureComments (EpaDelta (SameLine 0) []) str case loc of - EpaSpan _ -> return anc + EpaSpan _ _ -> return anc EpaDelta dp [] -> return anc { anchor_op = MovedAnchor dp } EpaDelta _ _cs -> error "printUnicode should not capture comments" @@ -4271,6 +4221,7 @@ , con_mb_cxt = mcxt , con_args = args , con_doc = doc }) = do + doc' <- mapM markAnnotated doc an0 <- if has_forall then markEpAnnL an lidl AnnForall else return an @@ -4290,7 +4241,7 @@ , con_ex_tvs = ex_tvs' , con_mb_cxt = mcxt' , con_args = args' - , con_doc = doc }) + , con_doc = doc' }) where -- -- In ppr_details: let's not print the multiplicities (they are always 1, by @@ -4314,12 +4265,14 @@ exact (ConDeclGADT { con_g_ext = an , con_names = cons + , con_dcolon = dcol , con_bndrs = bndrs , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = do + doc' <- mapM markAnnotated doc cons' <- mapM markAnnotated cons - an0 <- markEpAnnL an lidl AnnDcolon - an1 <- annotationsToComments an0 lidl [AnnOpenP, AnnCloseP] + dcol' <- markUniToken dcol + an1 <- annotationsToComments an lidl [AnnOpenP, AnnCloseP] -- Work around https://gitlab.haskell.org/ghc/ghc/-/issues/20558 bndrs' <- case bndrs of @@ -4342,9 +4295,10 @@ res_ty' <- markAnnotated res_ty return (ConDeclGADT { con_g_ext = an2 , con_names = cons' + , con_dcolon = dcol' , con_bndrs = bndrs' , con_mb_cxt = mcxt', con_g_args = args' - , con_res_ty = res_ty', con_doc = doc }) + , con_res_ty = res_ty', con_doc = doc' }) -- --------------------------------------------------------------------- @@ -4380,7 +4334,8 @@ names' <- markAnnotated names an0 <- markEpAnnL an lidl AnnDcolon ftype' <- markAnnotated ftype - return (ConDeclField an0 names' ftype' mdoc) + mdoc' <- mapM markAnnotated mdoc + return (ConDeclField an0 names' ftype' mdoc') -- --------------------------------------------------------------------- @@ -4476,12 +4431,10 @@ an3 <- markLensMAA an2 lal_close return (L (la { ann = an3}) a') --- instance ExactPrint (LocatedL [ExprLStmt GhcPs]) where instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsExpr GhcPs)))]) where - getAnnotationEntry = entryFromLocatedAFixed + getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn an' l) stmts) = do - let an = fixAnnListAnn an' + exact (L (SrcSpanAnn an l) stmts) = do debugM $ "LocatedL [ExprLStmt" (an'', stmts') <- markAnnList True an $ do case snocView stmts of @@ -4492,16 +4445,13 @@ return (initStmts' ++ [ls']) _ -> do markAnnotated stmts - -- x -> error $ "pprDo:ListComp" ++ showAst x - -- markLocatedMAA an al_close return (L (SrcSpanAnn an'' l) stmts') -- instance ExactPrint (LocatedL [CmdLStmt GhcPs]) where instance ExactPrint (LocatedL [LocatedA (StmtLR GhcPs GhcPs (LocatedA (HsCmd GhcPs)))]) where - getAnnotationEntry = entryFromLocatedAFixed + getAnnotationEntry = entryFromLocatedA setAnnotationAnchor = setAnchorAn - exact (L (SrcSpanAnn ann' l) es) = do - let ann = fixAnnListAnn ann' + exact (L (SrcSpanAnn ann l) es) = do debugM $ "LocatedL [CmdLStmt" an0 <- markLensMAA ann lal_open es' <- mapM markAnnotated es @@ -4583,24 +4533,17 @@ m' <- markAnnotated m return (IEModuleContents an0 m') - -- These three exist to not error out, but are no-ops The contents - -- appear as "normal" comments too, which we process instead. - exact (IEGroup x lev doc) = do - return (IEGroup x lev doc) - exact (IEDoc x doc) = do - return (IEDoc x doc) - exact (IEDocNamed x str) = do - return (IEDocNamed x str) + exact x = error $ "missing match for IE:" ++ showAst x -- --------------------------------------------------------------------- -instance ExactPrint (IEWrappedName RdrName) where +instance ExactPrint (IEWrappedName GhcPs) where getAnnotationEntry = const NoEntryVal setAnnotationAnchor a _ _ = a - exact (IEName n) = do + exact (IEName x n) = do n' <- markAnnotated n - return (IEName n') + return (IEName x n') exact (IEPattern r n) = do r' <- printStringAtAA r "pattern" n' <- markAnnotated n @@ -4616,7 +4559,7 @@ getAnnotationEntry (WildPat _) = NoEntryVal getAnnotationEntry (VarPat _ _) = NoEntryVal getAnnotationEntry (LazyPat an _) = fromAnn an - getAnnotationEntry (AsPat an _ _) = fromAnn an + getAnnotationEntry (AsPat an _ _ _) = fromAnn an getAnnotationEntry (ParPat an _ _ _) = fromAnn an getAnnotationEntry (BangPat an _) = fromAnn an getAnnotationEntry (ListPat an _) = fromAnn an @@ -4633,7 +4576,7 @@ setAnnotationAnchor a@(WildPat _) _ _s = a 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 (AsPat an a at b) anc cs = (AsPat (setAnchorEpa an anc cs) a at b) 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) @@ -4664,11 +4607,11 @@ an0 <- markEpAnnL an lidl AnnTilde pat' <- markAnnotated pat return (LazyPat an0 pat') - exact (AsPat an n pat) = do + exact (AsPat an n at pat) = do n' <- markAnnotated n - an0 <- markEpAnnL an lidl AnnAt + at' <- markToken at pat' <- markAnnotated pat - return (AsPat an0 n' pat') + return (AsPat an n' at' pat') exact (ParPat an lpar pat rpar) = do lpar' <- markToken lpar pat' <- markAnnotated pat @@ -4742,9 +4685,8 @@ setAnnotationAnchor a _ _ = a exact (HsPS an ty) = do - an0 <- markAnnKwL an lid AnnAt ty' <- markAnnotated ty - return (HsPS an0 ty') + return (HsPS an ty') -- --------------------------------------------------------------------- @@ -4768,9 +4710,7 @@ hsLit2String lit = case lit of HsChar src v -> toSourceTextWithSuffix src v "" - -- It should be included here - -- https://github.com/ghc/ghc/blob/master/compiler/parser/Lexer.x#L1471 - HsCharPrim src p -> toSourceTextWithSuffix src p "#" + HsCharPrim src p -> toSourceTextWithSuffix src p "" HsString src v -> toSourceTextWithSuffix src v "" HsStringPrim src v -> toSourceTextWithSuffix src v "" HsInt _ (IL src _ v) -> toSourceTextWithSuffix src v "" @@ -4782,7 +4722,6 @@ HsRat _ fl@(FL{fl_text = src }) _ -> toSourceTextWithSuffix src fl "" HsFloatPrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "#" HsDoublePrim _ fl@(FL{fl_text = src }) -> toSourceTextWithSuffix src fl "##" - -- (XLit x) -> error $ "got XLit for:" ++ showPprUnsafe x toSourceTextWithSuffix :: (Show a) => SourceText -> a -> String -> String toSourceTextWithSuffix (NoSourceText) alt suffix = show alt ++ suffix @@ -4809,6 +4748,14 @@ an1 <- markEpAnnL an0 lidl AnnCloseC return (an1, c', details') +instance ExactPrint (HsConPatTyArg GhcPs) where + getAnnotationEntry _ = NoEntryVal + setAnnotationAnchor a _ _ = a + exact (HsConPatTyArg at tyarg) = do + at' <- markToken at + tyarg' <- markAnnotated tyarg + return (HsConPatTyArg at' tyarg') + exactConArgs :: (Monad m, Monoid w) => HsConPatDetails GhcPs -> EP w m (HsConPatDetails GhcPs) exactConArgs (PrefixCon tyargs pats) = do @@ -4828,11 +4775,6 @@ entryFromLocatedA :: LocatedAn ann a -> Entry entryFromLocatedA (L la _) = fromAnn la --- See https://gitlab.haskell.org/ghc/ghc/-/issues/20256 -entryFromLocatedAFixed :: LocatedL a -> Entry -entryFromLocatedAFixed (L la _) - = fromAnn (fixSrcAnnL la) - -- ===================================================================== -- Utility stuff -- --------------------------------------------------------------------- @@ -5086,7 +5028,6 @@ printStringAdvance :: (Monad m, Monoid w) => String -> EP w m () printStringAdvance str = do ss <- getAnchorU - debugM $ "printStringAdvance: ss =" ++ showGhc ss _ <- printStringAtRs ss str return () 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 @@ -30,7 +30,6 @@ AnnValStr -> mkErr kw AnnName -> mkErr kw AnnAs -> "as" - AnnAt -> "@" AnnBang -> "!" AnnBackquote -> "`" AnnBy -> "by" 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 @@ -6,8 +6,14 @@ import GHC hiding (EpaComment) -- --------------------------------------------------------------------- + +-- --------------------------------------------------------------------- -- Orphan Default instances. See https://gitlab.haskell.org/ghc/ghc/-/issues/20372 +{- +instance Default [a] where + def = [] +-} instance Default NameAnn where def = mempty @@ -37,6 +43,11 @@ instance Default EpAnnUnboundVar where def = EpAnnUnboundVar def def +{- +instance (Default a, Default b) => Default (a, b) where + def = (def, def) +-} + instance Default NoEpAnns where def = NoEpAnns @@ -51,6 +62,11 @@ instance Default AnnsIf where def = AnnsIf def def def def def + +{- +instance Default (Maybe a) where + def = Nothing +-} instance Default AnnProjection where def = AnnProjection def def 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 @@ -47,29 +47,24 @@ import Language.Haskell.GHC.ExactPrint.Preprocess -import Control.Monad.RWS +-- import Control.Monad.RWS +import Data.Functor (void) import qualified GHC hiding (parseModule) 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.Parser as GHC -import qualified GHC.Driver.Errors.Types 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.Types.SrcLoc as GHC --- import qualified GHC.Utils.Error as GHC import qualified GHC.LanguageExtensions as LangExt -{-# ANN module "HLint: ignore Eta reduce" #-} -{-# ANN module "HLint: ignore Redundant do" #-} -{-# ANN module "HLint: ignore Reduce duplication" #-} -- --------------------------------------------------------------------- -- | Wrapper function which returns Annotations along with the parsed @@ -125,7 +120,7 @@ -- --------------------------------------------------------------------- -parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located GHC.HsModule) +parseFile :: GHC.DynFlags -> FilePath -> String -> GHC.ParseResult (GHC.Located (GHC.HsModule GHC.GhcPs)) parseFile = runParser GHC.parseModule -- --------------------------------------------------------------------- @@ -281,17 +276,17 @@ fixModuleTrailingComments :: GHC.ParsedSource -> GHC.ParsedSource fixModuleTrailingComments (GHC.L l p) = GHC.L l p' where - an' = case GHC.hsmodAnn p of + an' = case GHC.hsmodAnn $ GHC.hsmodExt p of (GHC.EpAnn a an ocs) -> GHC.EpAnn a an (rebalance (GHC.am_decls an) ocs) unused -> unused - p' = p { GHC.hsmodAnn = an' } + p' = p { GHC.hsmodExt = (GHC.hsmodExt p){ GHC.hsmodAnn = an' } } -- p' = error $ "fixModuleTrailingComments: an'=" ++ showAst an' rebalance :: GHC.AnnList -> GHC.EpAnnComments -> GHC.EpAnnComments rebalance al cs = cs' where cs' = case GHC.al_close al of - Just (GHC.AddEpAnn _ (GHC.EpaSpan ss)) -> + Just (GHC.AddEpAnn _ (GHC.EpaSpan ss _)) -> let pc = GHC.priorComments cs fc = GHC.getFollowingComments cs 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 @@ -18,29 +18,28 @@ import qualified GHC as GHC hiding (parseModule) import qualified Control.Monad.IO.Class as GHC -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.Parser 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.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.Lexer as GHC import qualified GHC.Settings as GHC +import qualified GHC.Types.Error as GHC import qualified GHC.Types.SourceError as GHC -import qualified GHC.Types.SrcLoc 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.Types.SrcLoc as GHC +import qualified GHC.Utils.Error as GHC import qualified GHC.Utils.Fingerprint as GHC +import qualified GHC.Utils.Outputable as GHC import GHC.Types.SrcLoc (mkSrcSpan, mkSrcLoc) import GHC.Data.FastString (mkFastString) -import Data.List (isPrefixOf, intercalate) +import Data.List (isPrefixOf) import Data.Maybe import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils @@ -49,9 +48,6 @@ -- import Debug.Trace -- -{-# ANN module ("HLint: ignore Eta reduce" :: String) #-} -{-# ANN module ("HLint: ignore Redundant do" :: String) #-} -{-# ANN module ("HLint: ignore Reduce duplication" :: String) #-} -- --------------------------------------------------------------------- @@ -130,9 +126,8 @@ goodComment :: GHC.LEpaComment -> Bool goodComment c = isGoodComment (tokComment c) where - isGoodComment :: [Comment] -> Bool - isGoodComment [] = False - isGoodComment [Comment "" _ _ _] = False + isGoodComment :: Comment -> Bool + isGoodComment (Comment "" _ _ _) = False isGoodComment _ = True @@ -225,25 +220,19 @@ 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 $ fmap GHC.GhcDriverMessage err + Left err -> error $ showErrorMessages 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.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 - } +showErrorMessages :: (GHC.Diagnostic a) => GHC.Messages a -> String +showErrorMessages msgs = + GHC.renderWithContext GHC.defaultSDocContext + $ GHC.vcat + $ GHC.pprMsgEnvelopeBagWithLocDefault + $ GHC.getMessages + $ msgs injectCppOptions :: CppOptions -> GHC.DynFlags -> GHC.DynFlags injectCppOptions CppOptions{..} dflags = 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 @@ -88,6 +88,7 @@ import Language.Haskell.GHC.ExactPrint.ExactPrint import Language.Haskell.GHC.ExactPrint.Types import Language.Haskell.GHC.ExactPrint.Utils +-- import Language.Haskell.GHC.ExactPrint.Orphans (Default(..)) import Control.Monad.RWS import qualified Control.Monad.Fail as Fail @@ -96,13 +97,14 @@ import GHC.Data.Bag import GHC.Data.FastString +import Data.Data +import Data.Default import Data.Maybe import Data.Generics import Data.List (sortBy) import Data.Functor.Identity import Control.Monad.State -import Data.Default ------------------------------------------------------------------------------ -- Transformation of source elements @@ -117,7 +119,6 @@ ,MonadReader () ,MonadWriter [String] ,MonadState Int - ,MonadTrans ) instance Fail.MonadFail m => Fail.MonadFail (TransformT m) where @@ -184,8 +185,8 @@ -- --------------------------------------------------------------------- captureMatchLineSpacing :: LHsDecl GhcPs -> LHsDecl GhcPs -captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ) e) f))) - = L l (ValD x (FunBind a b (MG c (L d ms') e) f)) +captureMatchLineSpacing (L l (ValD x (FunBind a b (MG c (L d ms ))))) + = L l (ValD x (FunBind a b (MG c (L d ms')))) where ms' :: [LMatch GhcPs (LHsExpr GhcPs)] ms' = captureLineSpacing ms @@ -214,7 +215,7 @@ L (SrcSpanAnn EpAnnNotUsed ll) _ -> realSrcSpan ll L (SrcSpanAnn (EpAnn anc' _ _) _) _ -> anchor anc' -- TODO MovedAnchor? dc' = case dca of - EpaSpan r -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) + EpaSpan r _ -> AddEpAnn kw (EpaDelta (ss2delta (ss2posEnd rd) r) []) EpaDelta _ _ -> AddEpAnn kw dca -- --------------------------------- @@ -224,7 +225,7 @@ (L (SrcSpanAnn EpAnnNotUsed ll) b) -> let op = case dca of - EpaSpan r -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) + EpaSpan r _ -> MovedAnchor (ss2delta (ss2posEnd r) (realSrcSpan ll)) EpaDelta _ _ -> MovedAnchor (SameLine 1) in (L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan ll) op) mempty emptyComments) ll) b) (L (SrcSpanAnn (EpAnn (Anchor r op) a c) ll) b) @@ -232,7 +233,7 @@ op' = case op of MovedAnchor _ -> op _ -> case dca of - EpaSpan dcr -> MovedAnchor (ss2delta (ss2posEnd dcr) r) + EpaSpan dcr _ -> MovedAnchor (ss2delta (ss2posEnd dcr) r) EpaDelta _ _ -> MovedAnchor (SameLine 1) in (L (SrcSpanAnn (EpAnn (Anchor r op') a c) ll) b) @@ -269,8 +270,8 @@ -- --------------------------------------------------------------------- setEntryDPDecl :: LHsDecl GhcPs -> DeltaPos -> LHsDecl GhcPs -setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ) e) f))) dp - = L l' (ValD x (FunBind a b (MG c (L d ms') e) f)) +setEntryDPDecl decl@(L _ (ValD x (FunBind a b (MG c (L d ms ))))) dp + = L l' (ValD x (FunBind a b (MG c (L d ms')))) where L l' _ = setEntryDP decl dp ms' :: [LMatch GhcPs (LHsExpr GhcPs)] @@ -342,13 +343,13 @@ addEpaLocationDelta :: LayoutStartCol -> RealSrcSpan -> EpaLocation -> EpaLocation addEpaLocationDelta _off _anc (EpaDelta d cs) = EpaDelta d cs -addEpaLocationDelta off anc (EpaSpan r) +addEpaLocationDelta off anc (EpaSpan r _) = EpaDelta (adjustDeltaForOffset off (ss2deltaEnd anc r)) [] -- Set the entry DP for an element coming after an existing keyword annotation setEntryDPFromAnchor :: LayoutStartCol -> EpaLocation -> LocatedA t -> LocatedA t setEntryDPFromAnchor _off (EpaDelta _ _) (L la a) = L la a -setEntryDPFromAnchor off (EpaSpan anc) ll@(L la _) = setEntryDP ll dp' +setEntryDPFromAnchor off (EpaSpan anc _) ll@(L la _) = setEntryDP ll dp' where r = case la of (SrcSpanAnn EpAnnNotUsed l) -> realSrcSpan l @@ -399,8 +400,8 @@ pushDeclDP :: HsDecl GhcPs -> DeltaPos -> HsDecl GhcPs -pushDeclDP (ValD x (FunBind a b (MG c (L d ms ) e) f)) dp - = ValD x (FunBind a b (MG c (L d' ms') e) f) +pushDeclDP (ValD x (FunBind a b (MG c (L d ms )))) dp + = ValD x (FunBind a b (MG c (L d' ms'))) where L d' _ = setEntryDP (L d ms) dp ms' :: [LMatch GhcPs (LHsExpr GhcPs)] @@ -412,20 +413,14 @@ -- --------------------------------------------------------------------- balanceCommentsList :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] -balanceCommentsList [] = return [] -balanceCommentsList [x] = return [x] -balanceCommentsList (a:b:ls) = do - (a',b') <- balanceComments a b - r <- balanceCommentsList (b':ls) - return (a':r) +balanceCommentsList ds = balanceCommentsList'' ds -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) +balanceCommentsList'' :: (Monad m) => [LHsDecl GhcPs] -> TransformT m [LHsDecl GhcPs] +balanceCommentsList'' [] = return [] +balanceCommentsList'' [x] = return [x] +balanceCommentsList'' (a:b:ls) = do + (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 @@ -449,7 +444,7 @@ -- 'Match' if that 'Match' needs to be manipulated. balanceCommentsFB :: (Monad m) => LHsBind GhcPs -> LocatedA b -> TransformT m (LHsBind GhcPs, LocatedA b) -balanceCommentsFB (L lf (FunBind x n (MG mx (L lm matches) o) t)) second = do +balanceCommentsFB (L lf (FunBind x n (MG o (L lm matches)))) second = do logTr $ "balanceCommentsFB entered: " ++ showGhc (ss2range $ locA lf) -- There are comments on lf. We need to -- + Keep the prior ones here @@ -480,7 +475,7 @@ [] -> moveLeadingComments m'' lf' _ -> (m'',lf') logTr $ "balanceCommentsMatch done" - balanceComments' (L lf'' (FunBind x n (MG mx (L lm (reverse (m''':ms))) o) t)) second' + balanceComments' (L lf'' (FunBind x n (MG o (L lm (reverse (m''':ms)))))) second' balanceCommentsFB f s = balanceComments' f s -- | Move comments on the same line as the end of the match into the @@ -536,6 +531,15 @@ _ -> (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 @@ -544,29 +548,26 @@ -- 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': (cs2p)=" ++ showAst (cs2p) - -- logTr $ "balanceComments': (cs2f)=" ++ showAst (cs2f) - -- 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': (cs1s)=" ++ showAst (cs1s) + 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 - -- 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 + 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 - (cs2prior,cs2m,cs2following) = splitCommentsAround (anchorFromLocatedA la2) anc2 - cs2p = priorCommentsDeltas (anchorFromLocatedA la2) cs2prior - cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) cs2following + cs2s = splitCommentsEnd (anchorFromLocatedA la2) anc2 + cs2p = priorCommentsDeltas (anchorFromLocatedA la2) (priorComments cs2s) + cs2f = trailingCommentsDeltas (anchorFromLocatedA la2) (getFollowingComments cs2s) -- Split cs1f into those that belong on an1 and ones that must move to an2 (cs1move,cs1stay) = break (simpleBreak 1) cs1f @@ -578,12 +579,11 @@ move = sortEpaComments $ map snd (cs1move ++ move'' ++ move') stay = sortEpaComments $ map snd (cs1stay ++ stay') - an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced ((map snd cs1p)++cs1m) move) - an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced (cs2m++stay) (map snd cs2f)) + an1' = setCommentsSrcAnn (getLoc la1) (EpaCommentsBalanced (map snd cs1p) move) + an2' = setCommentsSrcAnn (getLoc la2) (EpaCommentsBalanced 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)] @@ -631,7 +631,6 @@ 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 @@ -649,21 +648,6 @@ 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) @@ -771,7 +755,7 @@ -- --------------------------------------------------------------------- anchorEof :: ParsedSource -> ParsedSource -anchorEof (L l m@(HsModule an _lo _mn _exps _imps _decls _ _)) = L l (m { hsmodAnn = an' }) +anchorEof (L l m@(HsModule (XModulePs an _lo _ _) _mn _exps _imps _decls)) = L l (m { hsmodExt = (hsmodExt m){ hsmodAnn = an' } }) where an' = addCommentOrigDeltasAnn an @@ -911,12 +895,12 @@ -- --------------------------------------------------------------------- instance HasDecls ParsedSource where - hsDecls (L _ (HsModule _ _lo _mn _exps _imps decls _ _)) = return decls - replaceDecls (L l (HsModule a lo mname exps imps _decls deps haddocks)) decls + hsDecls (L _ (HsModule (XModulePs _ _lo _ _) _mn _exps _imps decls)) = return decls + replaceDecls (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps _decls)) decls = do logTr "replaceDecls LHsModule" -- modifyAnnsT (captureOrder m decls) - return (L l (HsModule a lo mname exps imps decls deps haddocks)) + return (L l (HsModule (XModulePs a lo deps haddocks) mname exps imps decls)) -- --------------------------------------------------------------------- @@ -962,7 +946,7 @@ (L (TokenLoc l) ls, L (TokenLoc i) is) -> let off = case l of - (EpaSpan r) -> LayoutStartCol $ snd $ ss2pos r + (EpaSpan r _) -> LayoutStartCol $ snd $ ss2pos r (EpaDelta (SameLine _) _) -> LayoutStartCol 0 (EpaDelta (DifferentLine _ c) _) -> LayoutStartCol c ex'' = setEntryDPFromAnchor off i ex @@ -1001,7 +985,7 @@ -- for 'hsDecls' \/ 'replaceDecls'. 'hsDeclsPatBind' \/ 'replaceDeclsPatBind' is -- idempotent. hsDeclsPatBind :: (Monad m) => LHsBind GhcPs -> TransformT m [LHsDecl GhcPs] -hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb) _)) = hsDeclsValBinds lb +hsDeclsPatBind (L _ (PatBind _ _ (GRHSs _ _grhs lb))) = hsDeclsValBinds lb hsDeclsPatBind x = error $ "hsDeclsPatBind called for:" ++ showGhc x -- ------------------------------------- @@ -1023,11 +1007,11 @@ -- idempotent. replaceDeclsPatBind :: (Monad m) => LHsBind GhcPs -> [LHsDecl GhcPs] -> TransformT m (LHsBind GhcPs) -replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds) b)) newDecls +replaceDeclsPatBind (L l (PatBind x a (GRHSs xr rhss binds))) newDecls = do logTr "replaceDecls PatBind" binds'' <- replaceDeclsValbinds WithWhere binds newDecls - return (L l (PatBind x a (GRHSs xr rhss binds'') b)) + return (L l (PatBind x a (GRHSs xr rhss binds''))) replaceDeclsPatBind x _ = error $ "replaceDeclsPatBind called for:" ++ showGhc x -- --------------------------------------------------------------------- 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 @@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -17,28 +18,29 @@ -- , isGoodDelta -- ) where where -import Control.Monad.State + +import Control.Monad (when) import Data.Function import Data.List import Data.Maybe import Data.Ord (comparing) import Language.Haskell.GHC.ExactPrint.Lookup -import Language.Haskell.GHC.ExactPrint.Orphans () +import qualified Language.Haskell.GHC.ExactPrint.Orphans() + import GHC hiding (EpaComment) import qualified GHC import GHC.Types.Name import GHC.Types.Name.Reader import GHC.Types.SrcLoc +import GHC.Driver.Ppr import GHC.Data.FastString -import GHC.Utils.Outputable ( showPprUnsafe ) import qualified GHC.Data.Strict as Strict import Debug.Trace import Language.Haskell.GHC.ExactPrint.Types import Data.Default -import GHC.Base (NonEmpty(..)) -- --------------------------------------------------------------------- @@ -116,7 +118,7 @@ fc = co + dc undeltaSpan :: RealSrcSpan -> AnnKeywordId -> DeltaPos -> AddEpAnn -undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp) +undeltaSpan anchor kw dp = AddEpAnn kw (EpaSpan sp Strict.Nothing) where (l,c) = undelta (ss2pos anchor) dp (LayoutStartCol 0) len = length (keywordToString kw) @@ -180,22 +182,28 @@ -- --------------------------------------------------------------------- -isGadt :: [LConDecl (GhcPass p)] -> Bool -isGadt [] = True -isGadt ((L _ (ConDeclGADT{})):_) = True -isGadt _ = False +isListComp :: HsDoFlavour -> Bool +isListComp = isDoComprehensionContext -- --------------------------------------------------------------------- +needsWhere :: DataDefnCons (LConDecl (GhcPass p)) -> Bool +needsWhere (NewTypeCon _) = True +needsWhere (DataTypeCons _ []) = True +needsWhere (DataTypeCons _ ((L _ (ConDeclGADT{})):_)) = True +needsWhere _ = False + +-- --------------------------------------------------------------------- + insertCppComments :: ParsedSource -> [LEpaComment] -> ParsedSource insertCppComments (L l p) cs = L l p' where - an' = case GHC.hsmodAnn p of + an' = case GHC.hsmodAnn $ GHC.hsmodExt p of (EpAnn a an ocs) -> EpAnn a an (EpaComments cs') where cs' = sortEpaComments $ priorComments ocs ++ getFollowingComments ocs ++ cs unused -> unused - p' = p { GHC.hsmodAnn = an' } + p' = p { GHC.hsmodExt = (GHC.hsmodExt p) { GHC.hsmodAnn = an' } } -- --------------------------------------------------------------------- @@ -206,56 +214,8 @@ ghcCommentText (L _ (GHC.EpaComment (EpaBlockComment s) _)) = s ghcCommentText (L _ (GHC.EpaComment (EpaEofComment) _)) = "" -tokComment :: LEpaComment -> [Comment] -tokComment t@(L lt c) = - case c of - (GHC.EpaComment (EpaDocComment dc) pt) -> hsDocStringComments lt pt dc - _ -> [mkComment (normaliseCommentText (ghcCommentText t)) lt (ac_prior_tok c)] - -hsDocStringComments :: Anchor -> RealSrcSpan -> GHC.HsDocString -> [Comment] -hsDocStringComments _ pt (MultiLineDocString dec (x :| xs)) = - let - decStr = printDecorator dec - L lx x' = dedentDocChunkBy (3 + length decStr) x - str = "-- " ++ decStr ++ unpackHDSC x' - docChunk _ [] = [] - docChunk pt' (L l chunk:cs) - = Comment ("--" ++ unpackHDSC chunk) (spanAsAnchor l) pt' Nothing : docChunk (rs l) cs - in - (Comment str (spanAsAnchor lx) pt Nothing : docChunk (rs lx) (map dedentDocChunk xs)) -hsDocStringComments anc pt (NestedDocString dec@(HsDocStringNamed _) (L _ chunk)) - = [Comment ("{- " ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] -hsDocStringComments anc pt (NestedDocString dec (L _ chunk)) - = [Comment ("{-" ++ printDecorator dec ++ unpackHDSC chunk ++ "-}") anc pt Nothing ] -hsDocStringComments _ _ (GeneratedDocString _) = [] -- Should not appear in user-written code - --- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed --- At the moment the locations of the 'HsDocStringChunk's are from the start of --- the string part, leaving aside the "--". So we need to subtract 2 columns from it -dedentDocChunk :: LHsDocStringChunk -> LHsDocStringChunk -dedentDocChunk chunk = dedentDocChunkBy 2 chunk - -dedentDocChunkBy :: Int -> LHsDocStringChunk -> LHsDocStringChunk -dedentDocChunkBy dedent (L (RealSrcSpan l mb) c) = L (RealSrcSpan l' mb) c - where - f = srcSpanFile l - sl = srcSpanStartLine l - sc = srcSpanStartCol l - el = srcSpanEndLine l - ec = srcSpanEndCol l - l' = mkRealSrcSpan (mkRealSrcLoc f sl (sc - dedent)) - (mkRealSrcLoc f el (ec - dedent)) - -dedentDocChunkBy _ x = x - --- Temporary until https://gitlab.haskell.org/ghc/ghc/-/issues/23459 is landed -printDecorator :: HsDocStringDecorator -> String -printDecorator HsDocStringNext = "|" -printDecorator HsDocStringPrevious = "^" -printDecorator (HsDocStringNamed n) = '$':n -printDecorator (HsDocStringGroup n) = replicate n '*' - - +tokComment :: LEpaComment -> Comment +tokComment t@(L lt c) = mkComment (normaliseCommentText $ ghcCommentText t) lt (ac_prior_tok c) mkEpaComments :: [Comment] -> [Comment] -> EpAnnComments mkEpaComments priorCs [] @@ -295,7 +255,7 @@ -- | Makes a comment which originates from a specific keyword. mkKWComment :: AnnKeywordId -> EpaLocation -> Comment -mkKWComment kw (EpaSpan ss) +mkKWComment kw (EpaSpan ss _) = Comment (keywordToString kw) (Anchor ss UnchangedAnchor) ss (Just kw) mkKWComment kw (EpaDelta dp _) = Comment (keywordToString kw) (Anchor placeholderRealSpan (MovedAnchor dp)) placeholderRealSpan (Just kw) @@ -385,17 +345,17 @@ setAnchorEpa :: (Default an) => EpAnn an -> Anchor -> EpAnnComments -> EpAnn an setAnchorEpa EpAnnNotUsed anc cs = EpAnn anc def cs -setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs +setAnchorEpa (EpAnn _ an _) anc cs = EpAnn anc an cs setAnchorEpaL :: EpAnn AnnList -> Anchor -> EpAnnComments -> EpAnn AnnList setAnchorEpaL EpAnnNotUsed anc cs = EpAnn anc mempty cs setAnchorEpaL (EpAnn _ an _) anc cs = EpAnn anc (an {al_anchor = Nothing}) cs -setAnchorHsModule :: HsModule -> Anchor -> EpAnnComments -> HsModule -setAnchorHsModule hsmod anc cs = hsmod { hsmodAnn = an' } +setAnchorHsModule :: HsModule GhcPs -> Anchor -> EpAnnComments -> HsModule GhcPs +setAnchorHsModule hsmod anc cs = hsmod { hsmodExt = (hsmodExt hsmod) {hsmodAnn = an'} } where anc' = anc { anchor_op = UnchangedAnchor } - an' = setAnchorEpa (hsmodAnn hsmod) anc' cs + an' = setAnchorEpa (hsmodAnn $ hsmodExt hsmod) anc' cs -- |Version of l2l that preserves the anchor, immportant if it has an -- updated AnchorOperation @@ -422,7 +382,7 @@ -- TODO: move this to GHC anchorToEpaLocation :: Anchor -> EpaLocation -anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r +anchorToEpaLocation (Anchor r UnchangedAnchor) = EpaSpan r Strict.Nothing anchorToEpaLocation (Anchor _ (MovedAnchor dp)) = EpaDelta dp [] -- --------------------------------------------------------------------- diff --git a/tests/Test.hs b/tests/Test.hs --- a/tests/Test.hs +++ b/tests/Test.hs @@ -28,24 +28,25 @@ -- --------------------------------------------------------------------- -data GHCVersion = GHC92 - | GHC94 +data GHCVersion = GHC94 + | GHC96 deriving (Eq, Ord, Show) ghcVersion :: GHCVersion -#if MIN_VERSION_ghc(9,4,0) -ghcVersion = GHC94 +#if MIN_VERSION_ghc(9,6,0) +ghcVersion = GHC96 #else -ghcVersion = GHC92 +ghcVersion = GHC94 #endif -- | Directories to automatically find roundtrip tests testDirs :: [FilePath] testDirs = case ghcVersion of - GHC92 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92"] GHC94 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94"] - -- GHC94 -> ["ghc94"] + GHC96 -> ["ghc710", "ghc80", "ghc82", "ghc84", "ghc86", "ghc88", "ghc810", "ghc90", "ghc92", "ghc94", "ghc96"] + -- GHC96 -> ["ghc96"] + -- GHC96 -> ["ghc96-copied"] -- --------------------------------------------------------------------- @@ -144,13 +145,13 @@ return $ TestList [ internalTests, roundTripTests - , - (transformTests libdir) - , (failingTests libdir) - , - roundTripBalanceCommentsTests - , - roundTripMakeDeltaTests + , + (transformTests libdir) + , (failingTests libdir) + , + roundTripBalanceCommentsTests + , + roundTripMakeDeltaTests ] -- Tests that are no longer needed @@ -242,17 +243,11 @@ -- 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" "Haddock.hs" - - -- mkParserTest libdir "ghc94" "Haddock1.hs" - -- mkParserTestBC libdir "ghc94" "Haddock1.hs" + -- mkParserTest libdir "ghc96" "T11671_run.hs" - -- mkParserTest libdir "ghc94" "HsDocTy.hs" - mkParserTestBC libdir "ghc94" "HsDocTy.hs" + -- mkParserTest libdir "ghc96" "LexerM.hs" + mkParserTestBC libdir "ghc96" "LexerM.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 @@ -164,7 +164,7 @@ runRoundTrip :: LibDir -> Changer - -> GHC.Located GHC.HsModule + -> GHC.Located (GHC.HsModule GHC.GhcPs) -> [GHC.LEpaComment] -> IO (String, GHC.ParsedSource) runRoundTrip libdir f !parsedOrig cs = do diff --git a/tests/Test/CommonUtils.hs b/tests/Test/CommonUtils.hs --- a/tests/Test/CommonUtils.hs +++ b/tests/Test/CommonUtils.hs @@ -21,10 +21,12 @@ , failuresHtmlFile ) where +import Control.Monad +import Control.Monad.Extra import Data.List hiding (find) -import System.FilePath -import System.FilePath.Find import qualified GHC.Data.StringBuffer as GHC +import System.Directory +import System.FilePath -- --------------------------------------------------------------------- @@ -100,30 +102,38 @@ -- Given base directory finds all haskell source files findSrcFiles :: FilePath -> IO [FilePath] -findSrcFiles = find filterDirectory filterFilename - -filterDirectory :: FindClause Bool -filterDirectory = - p <$> fileName +findSrcFiles = traverseDir okDirectory accFile [] where - p x - | "." `isPrefixOf` x = False + okDirectory :: FilePath -> Bool + okDirectory path + | "." `isPrefixOf` takeBaseName path = False | otherwise = True -filterFilename :: FindClause Bool -filterFilename = do - ext <- extension - fname <- fileName - return (ext == ".hs" && p fname) - where - p x - | "refactored" `isInfixOf` x = False - | "Setup.hs" `isInfixOf` x = False - | "HLint.hs" `isInfixOf` x = False -- HLint config files - | otherwise = True + accFile :: [FilePath] -> FilePath -> IO [FilePath] + accFile acc fileName = do + return (if (takeExtension fileName == ".hs" && p fileName) + then fileName:acc + else acc) + where + p x + | "refactored" `isInfixOf` x = False + | "Setup.hs" `isInfixOf` x = False + | "HLint.hs" `isInfixOf` x = False -- HLint config files + | otherwise = True -- --------------------------------------------------------------------- +-- Based on https://stackoverflow.com/questions/51712083/recursively-search-directories-for-all-files-matching-name-criteria-in-haskell +traverseDir :: (FilePath -> Bool) -> (b -> FilePath -> IO b) -> b -> FilePath -> IO b +traverseDir validDir transition = + let go state dirPath = + do names <- listDirectory dirPath + let paths = map (dirPath ) names + (dirPaths, filePaths) <- partitionM doesDirectoryExist paths + state' <- foldM transition state filePaths -- process current dir + foldM go state' (filter validDir dirPaths) -- process subdirs + in go +-- --------------------------------------------------------------------- readFileGhc :: FilePath -> IO String readFileGhc file = do buf@(GHC.StringBuffer _ len _) <- GHC.hGetStringBuffer file diff --git a/tests/Test/NoAnnotations.hs b/tests/Test/NoAnnotations.hs --- a/tests/Test/NoAnnotations.hs +++ b/tests/Test/NoAnnotations.hs @@ -11,7 +11,6 @@ -- import Data.Data (Data, toConstr, showConstr, cast) -- import Data.Generics (extQ, ext1Q, ext2Q, gmapQ) import Data.List -import Data.Maybe -- import Data.Ord (comparing) -- import qualified Data.ByteString as B @@ -88,15 +87,13 @@ -> [GHC.LEpaComment] -> IO (ParseResult GHC.ParsedSource) runPrettyRoundTrip libdir origFile !parsedOrig _cs = do - -- let !newAnns = addAnnotationsForPretty [] parsedOrig mempty - let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn $ GHC.unLoc parsedOrig - -- let comments = map tokComment $ GHC.sortRealLocated priorComments - let comments = concatMap tokComment priorComments + let priorComments = GHC.priorComments $ GHC.epAnnComments $ GHC.hsmodAnn + $ GHC.hsmodExt $ GHC.unLoc parsedOrig + let comments = map tokComment priorComments let pragmas = filter (\(Comment c _ _ _) -> isPrefixOf "{-#" c ) comments let pragmaStr = intercalate "\n" $ map commentContents pragmas let !printed = pragmaStr ++ "\n" ++ exactPrint parsedOrig - -- let !printed = pragmaStr ++ "\n" ++ (showSDoc_ $ GHC.ppr parsedOrig) parseString libdir origFile printed parsedOrig diff --git a/tests/Test/Transform.hs b/tests/Test/Transform.hs --- a/tests/Test/Transform.hs +++ b/tests/Test/Transform.hs @@ -423,12 +423,11 @@ let newDecl' = setEntryDP (makeDeltaAst newDecl) (DifferentLine 1 5) doAddLocal = do - -- decls0 <- hsDecls (makeDeltaAst lp) decls0 <- hsDecls lp [de1'',d2] <- balanceCommentsList decls0 let de1 = captureMatchLineSpacing de1'' - let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms) _) _)) = de1 + let L _ (ValD _ (FunBind _ _ (MG _ (L _ ms)))) = de1 let [ma1,_ma2] = ms (de1',_) <- modifyValD (getLocA ma1) de1 $ \_m decls -> do @@ -619,8 +618,8 @@ [L li imp1,imp2] = hsmodImports p n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) - v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1))) - v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2))) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) impHiding = L (SrcSpanAnn (EpAnn (Anchor (realSrcSpan l0) m0) (AnnList Nothing (Just (AddEpAnn AnnOpenP d1)) @@ -628,7 +627,7 @@ [(AddEpAnn AnnHiding d1)] []) emptyComments) l0) [v1,v2] - imp1' = imp1 { ideclHiding = Just (True,impHiding)} + imp1' = imp1 { ideclImportList = Just (EverythingBut,impHiding)} p' = p { hsmodImports = [L li imp1',imp2]} return (L l p') @@ -644,7 +643,7 @@ l2 <- uniqueSrcSpanT let [L li imp1] = hsmodImports p - Just (_,L lh ns) = ideclHiding imp1 + Just (_,L lh ns) = ideclImportList imp1 lh' = (SrcSpanAnn (EpAnn (Anchor (realSrcSpan (locA lh)) m1) (AnnList Nothing (Just (AddEpAnn AnnOpenP d1)) @@ -654,11 +653,11 @@ emptyComments) (locA lh)) n1 = L (noAnnSrcSpanDP0 l1) (mkVarUnqual (mkFastString "n1")) n2 = L (noAnnSrcSpanDP0 l2) (mkVarUnqual (mkFastString "n2")) - v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName n1))) - v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName n2))) + v1 = L (addComma $ noAnnSrcSpanDP0 l1) (IEVar noExtField (L (noAnnSrcSpanDP0 l1) (IEName noExtField n1))) + v2 = L ( noAnnSrcSpanDP0 l2) (IEVar noExtField (L (noAnnSrcSpanDP0 l2) (IEName noExtField n2))) L ln n = last ns n' = L (addComma ln) n - imp1' = imp1 { ideclHiding = Just (True,L lh' (init ns ++ [n',v1,v2]))} + imp1' = imp1 { ideclImportList = Just (EverythingBut, L lh' (init ns ++ [n',v1,v2]))} p' = p { hsmodImports = [L li imp1']} return (L l p') diff --git a/tests/examples/ghc94/Haddock.hs b/tests/examples/ghc94/Haddock.hs deleted file mode 100644 --- a/tests/examples/ghc94/Haddock.hs +++ /dev/null @@ -1,408 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-} ------------------------------------------------------------------------------ --- | --- Module : Test --- Copyright : (c) Simon Marlow 2002 --- License : BSD-style --- --- Maintainer : libraries@haskell.org --- Stability : provisional --- Portability : portable --- --- This module illustrates & tests most of the features of Haddock. --- Testing references from the description: 'T', 'f', 'g', 'Visible.visible'. --- ------------------------------------------------------------------------------ - --- This is plain comment, ignored by Haddock. - -module Haddock ( - - -- Section headings are introduced with '-- *': - -- * Type declarations - - -- Subsection headings are introduced with '-- **' and so on. - -- ** Data types - T(..), T2, T3(..), T4(..), T5(..), T6(..), - N1(..), N2(..), N3(..), N4, N5(..), N6(..), N7(..), - - -- ** Records - R(..), R1(..), - - -- | test that we can export record selectors on their own: - p, q, u, - - -- * Class declarations - C(a,b), D(..), E, F(..), - - -- | Test that we can export a class method on its own: - a, - - -- * Function types - f, g, - - -- * Auxiliary stuff - - -- $aux1 - - -- $aux2 - - -- $aux3 - - -- $aux4 - - -- $aux5 - - -- $aux6 - - -- $aux7 - - -- $aux8 - - -- $aux9 - - -- $aux10 - - -- $aux11 - - -- $aux12 - - -- | This is some inline documentation in the export list - -- - -- > a code block using bird-tracks - -- > each line must begin with > (which isn't significant unless it - -- > is at the beginning of the line). - - -- * A hidden module - module Hidden, - - -- * A visible module - module Visible, - - {-| nested-style doc comments -} - - -- * Existential \/ Universal types - Ex(..), - - -- * Type signatures with argument docs - k, l, m, o, - - -- * A section - -- and without an intervening comma: - -- ** A subsection - -{-| - > a literal line - - $ a non /literal/ line $ --} - - f', - ) where - -import Hidden -import Visible - --- | This comment applies to the /following/ declaration --- and it continues until the next non-comment line -data T a b - = A Int (Maybe Float) -- ^ This comment describes the 'A' constructor - | -- | This comment describes the 'B' constructor - B (T a b, T Int Float) -- ^ - --- | An abstract data declaration -data T2 a b = T2 a b - --- | A data declaration with no documentation annotations on the constructors -data T3 a b = A1 a | B1 b - --- A data declaration with no documentation annotations at all -data T4 a b = A2 a | B2 b - --- A data declaration documentation on the constructors only -data T5 a b - = A3 a -- ^ documents 'A3' - | B3 b -- ^ documents 'B3' - --- | Testing alternative comment styles -data T6 - -- | This is the doc for 'A4' - = A4 - | B4 - | -- ^ This is the doc for 'B4' - - -- | This is the doc for 'C4' - C4 - --- | A newtype -newtype N1 a = N1 a - --- | A newtype with a fieldname -newtype N2 a b = N2 {n :: a b} - --- | A newtype with a fieldname, documentation on the field -newtype N3 a b = N3 {n3 :: a b -- ^ this is the 'n3' field - } - --- | An abstract newtype - we show this one as data rather than newtype because --- the difference isn\'t visible to the programmer for an abstract type. -newtype N4 a b = N4 a - -newtype N5 a b = N5 {n5 :: a b -- ^ no docs on the datatype or the constructor - } - -newtype N6 a b = N6 {n6 :: a b - } - -- ^ docs on the constructor only - --- | docs on the newtype and the constructor -newtype N7 a b = N7 {n7 :: a b - } - -- ^ The 'N7' constructor - - -class (D a) => C a where - -- |this is a description of the 'a' method - a :: IO a - b :: [a] - -- ^ this is a description of the 'b' method - c :: a -- c is hidden in the export list - --- ^ This comment applies to the /previous/ declaration (the 'C' class) - -class D a where - d :: T a b - e :: (a,a) --- ^ This is a class declaration with no separate docs for the methods - -instance D Int where - d = undefined - e = undefined - --- instance with a qualified class name -instance Test.D Float where - d = undefined - e = undefined - -class E a where - ee :: a --- ^ This is a class declaration with no methods (or no methods exported) - --- This is a class declaration with no documentation at all -class F a where - ff :: a - --- | This is the documentation for the 'R' record, which has four fields, --- 'p', 'q', 'r', and 's'. -data R = - -- | This is the 'C1' record constructor, with the following fields: - C1 { p :: Int -- ^ This comment applies to the 'p' field - , q :: forall a . a->a -- ^ This comment applies to the 'q' field - , -- | This comment applies to both 'r' and 's' - r,s :: Int - } - | C2 { t :: T1 -> (T2 Int Int)-> (T3 Bool Bool) -> (T4 Float Float) -> T5 () (), - u,v :: Int - } - -- ^ This is the 'C2' record constructor, also with some fields: - --- | Testing different record commenting styles -data R1 - -- | This is the 'C3' record constructor - = C3 { - -- | The 's1' record selector - s1 :: Int - -- | The 's2' record selector - , s2 :: Int - , s3 :: Int -- NOTE: In the original examples/Test.hs in Haddock, there is an extra "," here. - -- Since GHC doesn't allow that, I have removed it in this file. - -- ^ The 's3' record selector - } - --- These section headers are only used when there is no export list to --- give the structure of the documentation: - --- * This is a section header (level 1) --- ** This is a section header (level 2) --- *** This is a section header (level 3) - -{-| -In a comment string we can refer to identifiers in scope with -single quotes like this: 'T', and we can refer to modules by -using double quotes: "Foo". We can add emphasis /like this/. - - * This is a bulleted list - - - This is the next item (different kind of bullet) - - (1) This is an ordered list - - 2. This is the next item (different kind of bullet) - -@ - This is a block of code, which can include other markup: 'R' - formatting - is - significant -@ - -> this is another block of code - -We can also include URLs in documentation: . --} - -f :: C a => a -> Int - --- | we can export foreign declarations too -foreign import ccall "header.h" g :: Int -> IO CInt - --- | this doc string has a parse error in it: \' -h :: Int -h = 42 - - --- $aux1 This is some documentation that is attached to a name ($aux1) --- rather than a source declaration. The documentation may be --- referred to in the export list using its name. --- --- @ code block in named doc @ - --- $aux2 This is some documentation that is attached to a name ($aux2) - --- $aux3 --- @ code block on its own in named doc @ - --- $aux4 --- --- @ code block on its own in named doc (after newline) @ - -{- $aux5 a nested, named doc comment - - with a paragraph, - - @ and a code block @ --} - --- some tests for various arrangements of code blocks: - -{- $aux6 ->test ->test1 - -@ test2 - test3 -@ --} - -{- $aux7 -@ -test1 -test2 -@ --} - -{- $aux8 ->test3 ->test4 --} - -{- $aux9 -@ -test1 -test2 -@ - ->test3 ->test4 --} - -{- $aux10 ->test3 ->test4 - -@ -test1 -test2 -@ --} - --- This one is currently wrong (Haddock 0.4). The @...@ part is --- interpreted as part of the bird-tracked code block. -{- $aux11 -aux11: - ->test3 ->test4 - -@ -test1 -test2 -@ --} - --- $aux12 --- > foo --- --- > bar --- - --- | A data-type using existential\/universal types -data Ex a - = forall b . C b => Ex1 b - | forall b . Ex2 b - | forall b . C a => Ex3 b -- NOTE: I have added "forall b" here make GHC accept this file - | Ex4 (forall a . a -> a) - --- | This is a function with documentation for each argument -k :: T () () -- ^ This argument has type 'T' - -> (T2 Int Int) -- ^ This argument has type 'T2 Int Int' - -> (T3 Bool Bool -> T4 Float Float) -- ^ This argument has type @T3 Bool Bool -> T4 Float Float@ - -> T5 () () -- ^ This argument has a very long description that should - -- hopefully cause some wrapping to happen when it is finally - -- rendered by Haddock in the generated HTML page. - -> IO () -- ^ This is the result type - --- This function has arg docs but no docs for the function itself -l :: (Int, Int, Float) -- ^ takes a triple - -> Int -- ^ returns an 'Int' - --- | This function has some arg docs -m :: R - -> N1 () -- ^ one of the arguments - -> IO Int -- ^ and the return value - --- | This function has some arg docs but not a return value doc - --- can't use the original name ('n') with GHC -newn :: R -- ^ one of the arguments, an 'R' - -> N1 () -- ^ one of the arguments - -> IO Int -newn = undefined - - --- | A foreign import with argument docs -foreign import ccall unsafe "header.h" - o :: Float -- ^ The input float - -> IO Float -- ^ The output float - --- | We should be able to escape this: \#\#\# - --- p :: Int --- can't use the above original definition with GHC -newp :: Int -newp = undefined - --- | a function with a prime can be referred to as 'f'' --- but f' doesn't get link'd 'f\'' -f' :: Int - - --- Add some definitions here so that this file can be compiled with GHC - -data T1 -f = undefined -f' = undefined -type CInt = Int -k = undefined -l = undefined -m = undefined diff --git a/tests/examples/ghc94/Haddock1.hs b/tests/examples/ghc94/Haddock1.hs deleted file mode 100644 --- a/tests/examples/ghc94/Haddock1.hs +++ /dev/null @@ -1,23 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-redundant-constraints -haddock #-} --- | Haddock comment, --- coming before the module -module Haddock1 ( - - -- | This is some inline documentation in the export list - -- - -- > a code block using bird-tracks - -- > each line must begin with > (which isn't significant unless it - -- > is at the beginning of the line). - f - - {-| nested-style doc comments -} - , g - - ) where - --- | Haddock before imports -import Data.List - --- | Haddock before decl -f = undefined -g = undefined diff --git a/tests/examples/ghc96/ContinuationIO.hs b/tests/examples/ghc96/ContinuationIO.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/ContinuationIO.hs @@ -0,0 +1,3 @@ +module ContinuationIO{-(module ContinuationIO, module DialogueIO)-} where + +stdin = "stdin" diff --git a/tests/examples/ghc96/Lib.hs b/tests/examples/ghc96/Lib.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/Lib.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE DataKinds, TypeData #-} +module T22315a.Lib where + +data TermLevel = Mk +type data TypeLevel = Mk + +class C (a :: TypeLevel) +instance C Mk where + +foo :: C a => proxy a -> () +foo _ = () + diff --git a/tests/examples/ghc96/Main.hs b/tests/examples/ghc96/Main.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/Main.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE OverloadedLabels, FlexibleContexts, OverloadedStrings, RecursiveDo, TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +module Main where + + +main :: IO () +main = do + Gtk.applicationNew (Just "de.weltraumschlangen.reflex-test") [] + >>= maybe + (die "Failed to initialize GTK") + ( \application -> do + ret <- runReflexGtk application (Just argv) $ do + runGtk $ do + #add mainWindow + #packStart outerBox + + ) + + + -- #add mainWindow + -- #packStart outerBox diff --git a/tests/examples/ghc96/T11671_run.hs b/tests/examples/ghc96/T11671_run.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/T11671_run.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedLabels #-} +{-# LANGUAGE MagicHash #-} + +import Data.Foldable (traverse_) +import Data.Proxy (Proxy(..)) +import GHC.OverloadedLabels (IsLabel(..)) +import GHC.TypeLits (KnownSymbol, symbolVal) +import GHC.Prim (Addr#) + +instance KnownSymbol symbol => IsLabel symbol String where + fromLabel = symbolVal (Proxy :: Proxy symbol) + +(#), (#.) :: String -> Int -> String +(#) _ i = show i +_ #. i = show i + +f :: Addr# -> Int -> String +f _ i = show i + +main :: IO () +main = traverse_ putStrLn + [ #a + , #number17 + , #do + , #type + , #Foo + , #3 + , #"199.4" + , #17a23b + , #f'a' + , #'a' + , #' + , #''notTHSplice + , #"..." + , #привет + , #こんにちは + , #"3" + , #":" + , #"Foo" + , #"The quick brown fox" + , #"\"" + , (++) #hello#world + , (++) #"hello"#"world" + , #"hello"# 1 -- equivalent to `(fromLabel @"hello") # 1` + , f "hello"#2 -- equivalent to `f ("hello"# :: Addr#) 2` + ] diff --git a/tests/examples/ghc96/T22315b.hs b/tests/examples/ghc96/T22315b.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/T22315b.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE TypeData #-} +module T22315b where + +data TermLevel = Mk +type data TypeLevel = Mk + +mk = Mk + +type Mk2 = Mk + diff --git a/tests/examples/ghc96/T22332a.hs b/tests/examples/ghc96/T22332a.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/T22332a.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeData, DataKinds, TypeFamilies #-} +module Main where + +import Type.Reflection +import Data.Type.Equality + +data Proxy a +type data X1 = T -- defines type constructor T +data X2 = T -- defines type constructor 'T + +data family F p + +newtype instance F (Proxy T) = ID (forall a. a -> a) +newtype instance F (Proxy 'T) = UC (forall a b. a -> b) + +-- This should fail at runtime because these are different types +eq :: T :~~: 'T +Just eq = eqTypeRep typeRep typeRep + +p :: a :~~: b -> F (Proxy a) :~: F (Proxy b) +p HRefl = Refl + +uc :: a -> b +uc = case castWith (p eq) (ID id) of UC a -> a + +main :: IO () +main = print (uc 'a' :: Int) + diff --git a/tests/examples/ghc96/T22500.hs b/tests/examples/ghc96/T22500.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/T22500.hs @@ -0,0 +1,10 @@ +-- Check that a quoted data type declaration is printed correctly +{-# LANGUAGE TemplateHaskellQuotes, TypeData #-} + +module Main where + +import Language.Haskell.TH +import Language.Haskell.TH.Ppr + +main = putStrLn . pprint =<< runQ [d| type data Nat = Zero | Succ Nat |] + diff --git a/tests/examples/ghc96/TDDataConstructor.hs b/tests/examples/ghc96/TDDataConstructor.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/TDDataConstructor.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE TypeData #-} +module TDDataConstructor where + +type data P = MkP +data Prom = P + diff --git a/tests/examples/ghc96/TDExistential.hs b/tests/examples/ghc96/TDExistential.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/TDExistential.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE TypeFamilies #-} +module TDExistential where + +import Data.Kind (Type) + +-- example from GHC User's Guide 6.4.10.6 + +type data Ex :: Type where + MkEx :: forall a. a -> Ex + +type family UnEx (ex :: Ex) :: k +type instance UnEx (MkEx x) = x + diff --git a/tests/examples/ghc96/TDGADT.hs b/tests/examples/ghc96/TDGADT.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/TDGADT.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE TypeData #-} +module TDGADT where + +import Data.Kind (Type) + +type data Nat = Zero | Succ Nat + +-- type level GADT +type data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +type X = VCons Bool (VCons Int VNil) + diff --git a/tests/examples/ghc96/TDGoodConsConstraints.hs b/tests/examples/ghc96/TDGoodConsConstraints.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/TDGoodConsConstraints.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE GADTs #-} +module TDGoodConsConstraints where + +import Data.Kind (Type) +import Data.Type.Equality + +type data Foo :: Type -> Type where + MkFoo1 :: a ~ Int => Foo a + MkFoo2 :: a ~~ Int => Foo a + diff --git a/tests/examples/ghc96/TDVector.hs b/tests/examples/ghc96/TDVector.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/TDVector.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE TypeData #-} +{-# LANGUAGE MonoLocalBinds #-} +module TDVector where + +import Data.Kind (Type) + +type data Nat = Zero | Succ Nat + +type data List a = Nil | Cons a (List a) + +type data Pair a b = MkPair a b + +type data Sum a b = L a | R b + +data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +instance Functor (Vec n) where + fmap _ VNil = VNil + fmap f (VCons x xs) = VCons (f x) (fmap f xs) + diff --git a/tests/examples/ghc96/TD_TH_splice.hs b/tests/examples/ghc96/TD_TH_splice.hs new file mode 100644 --- /dev/null +++ b/tests/examples/ghc96/TD_TH_splice.hs @@ -0,0 +1,19 @@ +-- Check that splicing in a quoted declaration has the same effect as +-- giving the declaration directly. +{-# LANGUAGE TemplateHaskell, TypeData, GADTs #-} + +module TD_TH_splice where + +import Data.Kind (Type) + +-- splice should be equivalent to giving the declaration directly +$( [d| type data Nat = Zero | Succ Nat |] ) + +data Vec :: Nat -> Type -> Type where + VNil :: Vec Zero a + VCons :: a -> Vec n a -> Vec (Succ n) a + +instance Functor (Vec n) where + fmap _ VNil = VNil + fmap f (VCons x xs) = VCons (f x) (fmap f xs) +