diff options
author | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2022-06-23 11:50:37 +0300 |
---|---|---|
committer | Vladislav Zavialov <vlad.z.4096@gmail.com> | 2022-10-23 00:11:50 +0300 |
commit | 11fe42d89d37539bd90f31ca47547922b3fc84ae (patch) | |
tree | 52aaeb001808eeeafb4b7bad6d19d7d5e658581c | |
parent | 1937016b7834338eef12be19caefc8e37a90cd29 (diff) | |
download | haskell-11fe42d89d37539bd90f31ca47547922b3fc84ae.tar.gz |
Class layout info (#19623)
Updates the haddock submodule.
28 files changed, 252 insertions, 148 deletions
diff --git a/compiler/GHC/Hs.hs b/compiler/GHC/Hs.hs index fcea4fc332..c327ff1fd4 100644 --- a/compiler/GHC/Hs.hs +++ b/compiler/GHC/Hs.hs @@ -68,7 +68,7 @@ import Data.Data hiding ( Fixity ) data XModulePs = XModulePs { hsmodAnn :: EpAnn AnnsModule, - hsmodLayout :: LayoutInfo, + hsmodLayout :: LayoutInfo GhcPs, -- ^ Layout info for the module. -- For incomplete modules (e.g. the output of parseHeader), it is NoLayoutInfo. hsmodDeprecMessage :: Maybe (LocatedP (WarningTxt GhcPs)), diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index e1e368a76b..d296f2b0a6 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -353,7 +353,8 @@ data DataDeclRn = DataDeclRn , tcdFVs :: NameSet } deriving Data -type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey, LayoutInfo) -- See Note [Class LayoutInfo] +type instance XClassDecl GhcPs = (EpAnn [AddEpAnn], AnnSortKey) + -- TODO:AZ:tidy up AnnSortKey above type instance XClassDecl GhcRn = NameSet -- FVs type instance XClassDecl GhcTc = NameSet -- FVs diff --git a/compiler/GHC/Hs/Extension.hs b/compiler/GHC/Hs/Extension.hs index 922288650f..8e73f60b85 100644 --- a/compiler/GHC/Hs/Extension.hs +++ b/compiler/GHC/Hs/Extension.hs @@ -11,6 +11,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilyDependencies #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE UndecidableSuperClasses #-} -- for IsPass; see Note [NoGhcTc] {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module Language.Haskell.Syntax.Extension @@ -27,6 +28,7 @@ import GHC.Prelude import GHC.TypeLits (KnownSymbol, symbolVal) import Data.Data hiding ( Fixity ) +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name import GHC.Types.Name.Reader @@ -258,3 +260,5 @@ instance KnownSymbol tok => Outputable (HsToken tok) where instance (KnownSymbol tok, KnownSymbol utok) => Outputable (HsUniToken tok utok) where ppr HsNormalTok = text (symbolVal (Proxy :: Proxy tok)) ppr HsUnicodeTok = text (symbolVal (Proxy :: Proxy utok)) + +deriving instance Typeable p => Data (LayoutInfo (GhcPass p)) diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index fd1cd5d3ae..2a4f66f057 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -925,17 +925,17 @@ maybemodwarning :: { Maybe (LocatedP (WarningTxt GhcPs)) } body :: { (AnnList ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo) } + ,LayoutInfo GhcPs) } : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2) - , snd $2, ExplicitBraces) } + , snd $2, explicitBraces $1 $3) } | vocurly top close { (AnnList Nothing Nothing Nothing [] (fst $2) , snd $2, VirtualBraces (getVOCURLY $1)) } body2 :: { (AnnList ,([LImportDecl GhcPs], [LHsDecl GhcPs]) - ,LayoutInfo) } + ,LayoutInfo GhcPs) } : '{' top '}' { (AnnList Nothing (Just $ moc $1) (Just $ mcc $3) [] (fst $2) - , snd $2, ExplicitBraces) } + , snd $2, explicitBraces $1 $3) } | missing_module_keyword top close { (AnnList Nothing Nothing Nothing [] [], snd $2, VirtualBraces leftmostColumn) } @@ -1712,9 +1712,9 @@ decls_cls :: { Located ([AddEpAnn],OrdList (LHsDecl GhcPs)) } -- Reversed decllist_cls :: { Located ([AddEpAnn] , OrdList (LHsDecl GhcPs) - , LayoutInfo) } -- Reversed + , LayoutInfo GhcPs) } -- Reversed : '{' decls_cls '}' { sLL $1 $> (moc $1:mcc $3:(fst $ unLoc $2) - ,snd $ unLoc $2, ExplicitBraces) } + ,snd $ unLoc $2, explicitBraces $1 $3) } | vocurly decls_cls close { let { L l (anns, decls) = $2 } in L l (anns, decls, VirtualBraces (getVOCURLY $1)) } @@ -1722,7 +1722,7 @@ decllist_cls -- where_cls :: { Located ([AddEpAnn] ,(OrdList (LHsDecl GhcPs)) -- Reversed - ,LayoutInfo) } + ,LayoutInfo GhcPs) } -- No implicit parameters -- May have type declarations : 'where' decllist_cls { sLL $1 $> (mj AnnWhere $1:(fstOf3 $ unLoc $2) @@ -4409,6 +4409,9 @@ hsUniTok t@(L l _) = L (mkTokenLocation l) (if isUnicode t then HsUnicodeTok else HsNormalTok) +explicitBraces :: Located Token -> Located Token -> LayoutInfo GhcPs +explicitBraces t1 t2 = ExplicitBraces (hsTok t1) (hsTok t2) + -- ------------------------------------- addTrailingCommaFBind :: MonadP m => Fbind b -> SrcSpan -> m (Fbind b) diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 99e8fd10c8..02a4723f6f 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -193,7 +193,7 @@ mkClassDecl :: SrcSpan -> Located (Maybe (LHsContext GhcPs), LHsType GhcPs) -> Located (a,[LHsFunDep GhcPs]) -> OrdList (LHsDecl GhcPs) - -> LayoutInfo + -> LayoutInfo GhcPs -> [AddEpAnn] -> P (LTyClDecl GhcPs) @@ -204,7 +204,8 @@ mkClassDecl loc' (L _ (mcxt, tycl_hdr)) fds where_cls layoutInfo annsIn ; tyvars <- checkTyVars (text "class") whereDots cls tparams ; cs <- getCommentsFor (locA loc) -- Get any remaining comments ; let anns' = addAnns (EpAnn (spanAsAnchor $ locA loc) annsIn emptyComments) ann cs - ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey, layoutInfo) + ; return (L loc (ClassDecl { tcdCExt = (anns', NoAnnSortKey) + , tcdLayout = layoutInfo , tcdCtxt = mcxt , tcdLName = cls, tcdTyVars = tyvars , tcdFixity = fixity diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 2675921b04..706423c099 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -340,7 +340,7 @@ In this case, we should produce four HsDecl items (pseudo-code): The inputs to addHaddockInterleaveItems are: - * layout_info :: LayoutInfo + * layout_info :: LayoutInfo GhcPs In the example above, note that the indentation level inside the module is 2 spaces. It would be represented as layout_info = VirtualBraces 2. @@ -372,7 +372,7 @@ The inputs to addHaddockInterleaveItems are: addHaddockInterleaveItems :: forall a. HasHaddock a - => LayoutInfo + => LayoutInfo GhcPs -> (PsLocated HdkComment -> Maybe a) -- Get a documentation item -> [a] -- Unprocessed (non-documentation) items -> HdkA [a] -- Documentation items & processed non-documentation items @@ -389,7 +389,7 @@ addHaddockInterleaveItems layout_info get_doc_item = go with_layout_info :: HdkA a -> HdkA a with_layout_info = case layout_info of NoLayoutInfo -> id - ExplicitBraces -> id + ExplicitBraces{} -> id VirtualBraces n -> let loc_range = mempty { loc_range_col = ColumnFrom (n+1) } in hoistHdkA (inLocRange loc_range) @@ -498,7 +498,7 @@ instance HasHaddock (HsDecl GhcPs) where -- -- ^ Comment on the second method -- addHaddock (TyClD _ decl) - | ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout), + | ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout, tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs, tcdSigs, tcdMeths, tcdATs, tcdATDefs } <- decl = do @@ -509,7 +509,7 @@ instance HasHaddock (HsDecl GhcPs) where flattenBindsAndSigs (tcdMeths, tcdSigs, tcdATs, tcdATDefs, [], []) pure $ let (tcdMeths', tcdSigs', tcdATs', tcdATDefs', _, tcdDocs) = partitionBindsAndSigs where_cls' - decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey, tcdLayout) + decl' = ClassDecl { tcdCExt = (x, NoAnnSortKey), tcdLayout , tcdCtxt, tcdLName, tcdTyVars, tcdFixity, tcdFDs , tcdSigs = tcdSigs' , tcdMeths = tcdMeths' @@ -1309,10 +1309,10 @@ reportExtraDocs = * * ********************************************************************* -} -mkDocHsDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) +mkDocHsDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LHsDecl GhcPs) mkDocHsDecl layout_info a = fmap (DocD noExtField) <$> mkDocDecl layout_info a -mkDocDecl :: LayoutInfo -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) +mkDocDecl :: LayoutInfo GhcPs -> PsLocated HdkComment -> Maybe (LDocDecl GhcPs) mkDocDecl layout_info (L l_comment hdk_comment) | indent_mismatch = Nothing | otherwise = @@ -1346,7 +1346,7 @@ mkDocDecl layout_info (L l_comment hdk_comment) -- -- ^ indent mismatch indent_mismatch = case layout_info of NoLayoutInfo -> False - ExplicitBraces -> False + ExplicitBraces{} -> False VirtualBraces n -> n /= srcSpanStartCol (psRealSpan l_comment) mkDocIE :: PsLocated HdkComment -> Maybe (LIE GhcPs) diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index 6748d60a56..17124a9000 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -1839,7 +1839,8 @@ rnTyClDecl (DataDecl , tcdDataDefn = defn' , tcdDExt = rn_info }, fvs) } } -rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, +rnTyClDecl (ClassDecl { tcdLayout = layout, + tcdCtxt = context, tcdLName = lcls, tcdTyVars = tyvars, tcdFixity = fixity, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, tcdATs = ats, tcdATDefs = at_defs, @@ -1893,7 +1894,8 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, ; let all_fvs = meth_fvs `plusFV` stuff_fvs `plusFV` fv_at_defs ; docs' <- traverse rnLDocDecl docs - ; return (ClassDecl { tcdCtxt = context', tcdLName = lcls', + ; return (ClassDecl { tcdLayout = rnLayoutInfo layout, + tcdCtxt = context', tcdLName = lcls', tcdTyVars = tyvars', tcdFixity = fixity, tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', tcdATs = ats', tcdATDefs = at_defs', @@ -1902,6 +1904,11 @@ rnTyClDecl (ClassDecl { tcdCtxt = context, tcdLName = lcls, where cls_doc = ClassDeclCtx lcls +rnLayoutInfo :: LayoutInfo GhcPs -> LayoutInfo GhcRn +rnLayoutInfo (ExplicitBraces ob cb) = ExplicitBraces ob cb +rnLayoutInfo (VirtualBraces n) = VirtualBraces n +rnLayoutInfo NoLayoutInfo = NoLayoutInfo + -- Does the data type declaration include a CUSK? data_decl_has_cusk :: LHsQTyVars (GhcPass p) -> NewOrData -> Bool -> Maybe (LHsKind (GhcPass p')) -> RnM Bool data_decl_has_cusk tyvars new_or_data no_rhs_kvs kind_sig = do diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 47e8b5758c..02ecec08fb 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -328,7 +328,7 @@ cvtDec (ClassD ctxt cl tvs fds decs) <+> text "are not allowed:") $$ (Outputable.ppr adts')) ; returnJustLA $ TyClD noExtField $ - ClassDecl { tcdCExt = (noAnn, NoAnnSortKey, NoLayoutInfo) + ClassDecl { tcdCExt = (noAnn, NoAnnSortKey), tcdLayout = NoLayoutInfo , tcdCtxt = mkHsContextMaybe cxt', tcdLName = tc', tcdTyVars = tvs' , tcdFixity = Prefix , tcdFDs = fds', tcdSigs = Hs.mkClassOpSigs sigs' diff --git a/compiler/GHC/Types/SrcLoc.hs b/compiler/GHC/Types/SrcLoc.hs index 1f6d285b38..b0a6568220 100644 --- a/compiler/GHC/Types/SrcLoc.hs +++ b/compiler/GHC/Types/SrcLoc.hs @@ -16,6 +16,7 @@ module GHC.Types.SrcLoc ( -- ** Constructing SrcLoc mkSrcLoc, mkRealSrcLoc, mkGeneralSrcLoc, + leftmostColumn, noSrcLoc, -- "I'm sorry, I haven't a clue" generatedSrcLoc, -- Code generated within the compiler @@ -104,11 +105,6 @@ module GHC.Types.SrcLoc ( mkSrcSpanPs, combineRealSrcSpans, psLocatedToLocated, - - -- * Layout information - LayoutInfo(..), - leftmostColumn - ) where import GHC.Prelude @@ -241,6 +237,10 @@ mkSrcLoc x line col = RealSrcLoc (mkRealSrcLoc x line col) Strict.Nothing mkRealSrcLoc :: FastString -> Int -> Int -> RealSrcLoc mkRealSrcLoc x line col = SrcLoc (LexicalFastString x) line col +-- | Indentation level is 1-indexed, so the leftmost column is 1. +leftmostColumn :: Int +leftmostColumn = 1 + getBufPos :: SrcLoc -> Strict.Maybe BufPos getBufPos (RealSrcLoc _ mbpos) = mbpos getBufPos (UnhelpfulLoc _) = Strict.Nothing @@ -886,33 +886,3 @@ psSpanEnd (PsSpan r b) = PsLoc (realSrcSpanEnd r) (bufSpanEnd b) mkSrcSpanPs :: PsSpan -> SrcSpan mkSrcSpanPs (PsSpan r b) = RealSrcSpan r (Strict.Just b) - --- | Layout information for declarations. -data LayoutInfo = - - -- | Explicit braces written by the user. - -- - -- @ - -- class C a where { foo :: a; bar :: a } - -- @ - ExplicitBraces - | - -- | Virtual braces inserted by the layout algorithm. - -- - -- @ - -- class C a where - -- foo :: a - -- bar :: a - -- @ - VirtualBraces - !Int -- ^ Layout column (indentation level, begins at 1) - | - -- | Empty or compiler-generated blocks do not have layout information - -- associated with them. - NoLayoutInfo - - deriving (Eq, Ord, Show, Data) - --- | Indentation level is 1-indexed, so the leftmost column is 1. -leftmostColumn :: Int -leftmostColumn = 1 diff --git a/compiler/Language/Haskell/Syntax.hs b/compiler/Language/Haskell/Syntax.hs index 82e9f5558d..d23b840af8 100644 --- a/compiler/Language/Haskell/Syntax.hs +++ b/compiler/Language/Haskell/Syntax.hs @@ -25,6 +25,7 @@ module Language.Haskell.Syntax ( module Language.Haskell.Syntax.Module.Name, module Language.Haskell.Syntax.Pat, module Language.Haskell.Syntax.Type, + module Language.Haskell.Syntax.Concrete, module Language.Haskell.Syntax.Extension, ModuleName(..), HsModule(..) ) where @@ -35,6 +36,7 @@ import Language.Haskell.Syntax.Expr import Language.Haskell.Syntax.ImpExp import Language.Haskell.Syntax.Module.Name import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Type diff --git a/compiler/Language/Haskell/Syntax/Concrete.hs b/compiler/Language/Haskell/Syntax/Concrete.hs new file mode 100644 index 0000000000..982eac3216 --- /dev/null +++ b/compiler/Language/Haskell/Syntax/Concrete.hs @@ -0,0 +1,63 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE DeriveDataTypeable #-} + +-- | Bits of concrete syntax (tokens, layout). + +module Language.Haskell.Syntax.Concrete + ( LHsToken, LHsUniToken, + HsToken(HsTok), + HsUniToken(HsNormalTok, HsUnicodeTok), + LayoutInfo(ExplicitBraces, VirtualBraces, NoLayoutInfo) + ) where + +import GHC.Prelude +import GHC.TypeLits (Symbol, KnownSymbol) +import Data.Data +import Language.Haskell.Syntax.Extension + +type LHsToken tok p = XRec p (HsToken tok) +type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) + +-- | A token stored in the syntax tree. For example, when parsing a +-- let-expression, we store @HsToken "let"@ and @HsToken "in"@. +-- The locations of those tokens can be used to faithfully reproduce +-- (exactprint) the original program text. +data HsToken (tok :: Symbol) = HsTok + +-- | With @UnicodeSyntax@, there might be multiple ways to write the same +-- token. For example an arrow could be either @->@ or @→@. This choice must be +-- recorded in order to exactprint such tokens, so instead of @HsToken "->"@ we +-- introduce @HsUniToken "->" "→"@. +-- +-- See also @IsUnicodeSyntax@ in @GHC.Parser.Annotation@; we do not use here to +-- avoid a dependency. +data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok + +deriving instance KnownSymbol tok => Data (HsToken tok) +deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) + +-- | Layout information for declarations. +data LayoutInfo pass = + + -- | Explicit braces written by the user. + -- + -- @ + -- class C a where { foo :: a; bar :: a } + -- @ + ExplicitBraces !(LHsToken "{" pass) !(LHsToken "}" pass) + | + -- | Virtual braces inserted by the layout algorithm. + -- + -- @ + -- class C a where + -- foo :: a + -- bar :: a + -- @ + VirtualBraces + !Int -- ^ Layout column (indentation level, begins at 1) + | + -- | Empty or compiler-generated blocks do not have layout information + -- associated with them. + NoLayoutInfo diff --git a/compiler/Language/Haskell/Syntax/Decls.hs b/compiler/Language/Haskell/Syntax/Decls.hs index af8c0bb1e9..012304edf4 100644 --- a/compiler/Language/Haskell/Syntax/Decls.hs +++ b/compiler/Language/Haskell/Syntax/Decls.hs @@ -97,8 +97,9 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr -- Because Expr imports Decls via HsBracket import Language.Haskell.Syntax.Binds -import Language.Haskell.Syntax.Type +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension +import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Basic (Role) import GHC.Types.Basic (TopLevelFlag, OverlapMode, RuleName, Activation) @@ -457,6 +458,8 @@ data TyClDecl pass -- 'GHC.Parser.Annotation.AnnRarrow' -- For details on above see Note [exact print annotations] in GHC.Parser.Annotation | ClassDecl { tcdCExt :: XClassDecl pass, -- ^ Post renamer, FVs + tcdLayout :: !(LayoutInfo pass), -- ^ Explicit or virtual braces + -- See Note [Class LayoutInfo] tcdCtxt :: Maybe (LHsContext pass), -- ^ Context... tcdLName :: LIdP pass, -- ^ Name of the class tcdTyVars :: LHsQTyVars pass, -- ^ Class type variables diff --git a/compiler/Language/Haskell/Syntax/Expr.hs b/compiler/Language/Haskell/Syntax/Expr.hs index cc1504a9ea..5a22e35c74 100644 --- a/compiler/Language/Haskell/Syntax/Expr.hs +++ b/compiler/Language/Haskell/Syntax/Expr.hs @@ -26,6 +26,7 @@ import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Decls import Language.Haskell.Syntax.Pat import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type import Language.Haskell.Syntax.Binds diff --git a/compiler/Language/Haskell/Syntax/Extension.hs b/compiler/Language/Haskell/Syntax/Extension.hs index 4bdb3ce3cb..9ad16c0cd7 100644 --- a/compiler/Language/Haskell/Syntax/Extension.hs +++ b/compiler/Language/Haskell/Syntax/Extension.hs @@ -5,7 +5,6 @@ {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE EmptyCase #-} {-# LANGUAGE EmptyDataDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} @@ -22,8 +21,6 @@ module Language.Haskell.Syntax.Extension where -- This module captures the type families to precisely identify the extension -- points for GHC.Hs syntax -import GHC.TypeLits (Symbol, KnownSymbol) - #if MIN_VERSION_GLASGOW_HASKELL(9,3,0,0) import Data.Type.Equality (type (~)) #endif @@ -731,27 +728,3 @@ type family NoGhcTc (p :: Type) -- ===================================================================== -- End of Type family definitions -- ===================================================================== - - - --- ===================================================================== --- Token information - -type LHsToken tok p = XRec p (HsToken tok) - -data HsToken (tok :: Symbol) = HsTok - -deriving instance KnownSymbol tok => Data (HsToken tok) - -type LHsUniToken tok utok p = XRec p (HsUniToken tok utok) - --- With UnicodeSyntax, there might be multiple ways to write the same token. --- For example an arrow could be either "->" or "→". This choice must be --- recorded in order to exactprint such tokens, --- so instead of HsToken "->" we introduce HsUniToken "->" "→". --- --- See also IsUnicodeSyntax in GHC.Parser.Annotation; we do not use here to --- avoid a dependency. -data HsUniToken (tok :: Symbol) (utok :: Symbol) = HsNormalTok | HsUnicodeTok - -deriving instance (KnownSymbol tok, KnownSymbol utok) => Data (HsUniToken tok utok) diff --git a/compiler/Language/Haskell/Syntax/Pat.hs b/compiler/Language/Haskell/Syntax/Pat.hs index 95abde9ce0..66b9708bfe 100644 --- a/compiler/Language/Haskell/Syntax/Pat.hs +++ b/compiler/Language/Haskell/Syntax/Pat.hs @@ -36,6 +36,7 @@ import {-# SOURCE #-} Language.Haskell.Syntax.Expr (SyntaxExpr, LHsExpr, HsUntyp -- friends: import Language.Haskell.Syntax.Basic import Language.Haskell.Syntax.Lit +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import Language.Haskell.Syntax.Type diff --git a/compiler/Language/Haskell/Syntax/Type.hs b/compiler/Language/Haskell/Syntax/Type.hs index 4cb8b6ee0f..24e2ceeecc 100644 --- a/compiler/Language/Haskell/Syntax/Type.hs +++ b/compiler/Language/Haskell/Syntax/Type.hs @@ -57,6 +57,7 @@ module Language.Haskell.Syntax.Type ( import {-# SOURCE #-} Language.Haskell.Syntax.Expr ( HsUntypedSplice ) +import Language.Haskell.Syntax.Concrete import Language.Haskell.Syntax.Extension import GHC.Types.Name.Reader ( RdrName ) diff --git a/compiler/ghc.cabal.in b/compiler/ghc.cabal.in index ebb39582a6..e502506d89 100644 --- a/compiler/ghc.cabal.in +++ b/compiler/ghc.cabal.in @@ -810,6 +810,7 @@ Library Language.Haskell.Syntax Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds + Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension diff --git a/testsuite/tests/count-deps/CountDepsAst.stdout b/testsuite/tests/count-deps/CountDepsAst.stdout index 51fb5ec96e..f632445612 100644 --- a/testsuite/tests/count-deps/CountDepsAst.stdout +++ b/testsuite/tests/count-deps/CountDepsAst.stdout @@ -295,6 +295,7 @@ GHC.Utils.Trace Language.Haskell.Syntax Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds +Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension diff --git a/testsuite/tests/count-deps/CountDepsParser.stdout b/testsuite/tests/count-deps/CountDepsParser.stdout index e9c2420d71..85623b21a7 100644 --- a/testsuite/tests/count-deps/CountDepsParser.stdout +++ b/testsuite/tests/count-deps/CountDepsParser.stdout @@ -302,6 +302,7 @@ GHC.Utils.Trace Language.Haskell.Syntax Language.Haskell.Syntax.Basic Language.Haskell.Syntax.Binds +Language.Haskell.Syntax.Concrete Language.Haskell.Syntax.Decls Language.Haskell.Syntax.Expr Language.Haskell.Syntax.Extension diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index 257d03eb20..212f3f9bec 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -49,7 +49,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:(5,1)-(6,16) } @@ -58,9 +58,9 @@ ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:5:12-16 }))] (EpaComments [])) - (NoAnnSortKey) - (VirtualBraces - (3))) + (NoAnnSortKey)) + (VirtualBraces + (3)) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:5:7-8 }) @@ -186,7 +186,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:(9,1)-(10,16) } @@ -195,9 +195,9 @@ ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:9:12-16 }))] (EpaComments [])) - (NoAnnSortKey) - (VirtualBraces - (3))) + (NoAnnSortKey)) + (VirtualBraces + (3)) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:9:7-8 }) @@ -321,7 +321,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:(13,1)-(14,16) } @@ -330,9 +330,9 @@ ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:13:12-16 }))] (EpaComments [])) - (NoAnnSortKey) - (VirtualBraces - (3))) + (NoAnnSortKey)) + (VirtualBraces + (3)) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:13:7-8 }) @@ -459,7 +459,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:(17,1)-(20,16) } @@ -468,9 +468,9 @@ ,(AddEpAnn AnnWhere (EpaSpan { T17544.hs:17:12-16 }))] (EpaComments [])) - (NoAnnSortKey) - (VirtualBraces - (3))) + (NoAnnSortKey)) + (VirtualBraces + (3)) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:17:7-8 }) @@ -648,7 +648,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:22:1-30 } @@ -659,8 +659,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:22:30 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T17544.hs:22:18 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T17544.hs:22:30 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:22:7-8 }) @@ -917,7 +925,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:28:1-30 } @@ -928,8 +936,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:28:30 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T17544.hs:28:18 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T17544.hs:28:30 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:28:7-8 }) @@ -1186,7 +1202,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:34:1-30 } @@ -1197,8 +1213,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:34:30 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T17544.hs:34:18 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T17544.hs:34:30 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:34:7-8 }) @@ -1455,7 +1479,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:40:1-30 } @@ -1466,8 +1490,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:40:30 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T17544.hs:40:18 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T17544.hs:40:30 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:40:7-8 }) @@ -1724,7 +1756,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:46:1-30 } @@ -1735,8 +1767,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:46:30 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T17544.hs:46:18 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T17544.hs:46:30 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:46:7-8 }) @@ -1993,7 +2033,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544.hs:52:1-32 } @@ -2004,8 +2044,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T17544.hs:52:32 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T17544.hs:52:19 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T17544.hs:52:32 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544.hs:52:7-9 }) diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr index efc2c927ae..28f3f4ef63 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -269,7 +269,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T17544_kw.hs:(21,1)-(24,18) } @@ -278,9 +278,9 @@ ,(AddEpAnn AnnWhere (EpaSpan { T17544_kw.hs:23:3-7 }))] (EpaComments [])) - (NoAnnSortKey) - (VirtualBraces - (5))) + (NoAnnSortKey)) + (VirtualBraces + (5)) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T17544_kw.hs:21:7-9 }) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index d3b7566f5d..cd5c002a6a 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -1050,6 +1050,8 @@ (ClassDecl {NameSet: []} + (VirtualBraces + (3)) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { DumpRenamedAst.hs:27:7 }) diff --git a/testsuite/tests/parser/should_compile/DumpSemis.stderr b/testsuite/tests/parser/should_compile/DumpSemis.stderr index 9147e29ec4..faa926b6c4 100644 --- a/testsuite/tests/parser/should_compile/DumpSemis.stderr +++ b/testsuite/tests/parser/should_compile/DumpSemis.stderr @@ -1048,7 +1048,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { DumpSemis.hs:(28,1)-(29,23) } @@ -1057,9 +1057,9 @@ ,(AddEpAnn AnnWhere (EpaSpan { DumpSemis.hs:28:40-44 }))] (EpaComments [])) - (NoAnnSortKey) - (VirtualBraces - (3))) + (NoAnnSortKey)) + (VirtualBraces + (3)) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { DumpSemis.hs:28:7-19 }) @@ -2112,3 +2112,5 @@ (NoExtField)))))]))))))] (EmptyLocalBinds (NoExtField)))))])))))])) + + diff --git a/testsuite/tests/parser/should_compile/T20452.stderr b/testsuite/tests/parser/should_compile/T20452.stderr index 8cbc6e13c2..0c2982dd9c 100644 --- a/testsuite/tests/parser/should_compile/T20452.stderr +++ b/testsuite/tests/parser/should_compile/T20452.stderr @@ -227,7 +227,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T20452.hs:8:1-85 } @@ -238,8 +238,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:8:85 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T20452.hs:8:84 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T20452.hs:8:85 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T20452.hs:8:7-12 }) @@ -413,7 +421,7 @@ (TyClD (NoExtField) (ClassDecl - ((,,) + ((,) (EpAnn (Anchor { T20452.hs:9:1-85 } @@ -424,8 +432,16 @@ ,(AddEpAnn AnnCloseC (EpaSpan { T20452.hs:9:85 }))] (EpaComments [])) - (NoAnnSortKey) - (ExplicitBraces)) + (NoAnnSortKey)) + (ExplicitBraces + (L + (TokenLoc + (EpaSpan { T20452.hs:9:84 })) + (HsTok)) + (L + (TokenLoc + (EpaSpan { T20452.hs:9:85 })) + (HsTok))) (Nothing) (L (SrcSpanAnn (EpAnnNotUsed) { T20452.hs:9:7-12 }) diff --git a/testsuite/tests/perf/compiler/hard_hole_fits.stderr b/testsuite/tests/perf/compiler/hard_hole_fits.stderr index 9565092d29..fcdde2ee2d 100644 --- a/testsuite/tests/perf/compiler/hard_hole_fits.stderr +++ b/testsuite/tests/perf/compiler/hard_hole_fits.stderr @@ -180,7 +180,7 @@ hard_hole_fits.hs:23:38: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] hwcb :: Language.Haskell.Syntax.Type.LHsWcType (Language.Haskell.Syntax.Extension.NoGhcTc GhcPs) (bound at hard_hole_fits.hs:23:30) - at :: Language.Haskell.Syntax.Extension.LHsToken "@" GhcPs + at :: Language.Haskell.Syntax.Concrete.LHsToken "@" GhcPs (bound at hard_hole_fits.hs:23:27) gl :: LHsExpr GhcPs (bound at hard_hole_fits.hs:23:24) xate :: Language.Haskell.Syntax.Extension.XAppTypeE GhcPs @@ -239,10 +239,10 @@ hard_hole_fits.hs:26:30: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] • Found hole: _ :: Int • In an equation for ‘testMe’: testMe (HsPar xp gl ab ac) = _ • Relevant bindings include - ac :: Language.Haskell.Syntax.Extension.LHsToken ")" GhcPs + ac :: Language.Haskell.Syntax.Concrete.LHsToken ")" GhcPs (bound at hard_hole_fits.hs:26:24) ab :: LHsExpr GhcPs (bound at hard_hole_fits.hs:26:21) - gl :: Language.Haskell.Syntax.Extension.LHsToken "(" GhcPs + gl :: Language.Haskell.Syntax.Concrete.LHsToken "(" GhcPs (bound at hard_hole_fits.hs:26:18) xp :: Language.Haskell.Syntax.Extension.XPar GhcPs (bound at hard_hole_fits.hs:26:15) @@ -407,11 +407,11 @@ hard_hole_fits.hs:34:39: warning: [GHC-88464] [-Wtyped-holes (in -Wdefault)] testMe (HsLet xl tkLet gl tkIn gl') = _ • Relevant bindings include gl' :: LHsExpr GhcPs (bound at hard_hole_fits.hs:34:32) - tkIn :: Language.Haskell.Syntax.Extension.LHsToken "in" GhcPs + tkIn :: Language.Haskell.Syntax.Concrete.LHsToken "in" GhcPs (bound at hard_hole_fits.hs:34:27) gl :: Language.Haskell.Syntax.Binds.HsLocalBinds GhcPs (bound at hard_hole_fits.hs:34:24) - tkLet :: Language.Haskell.Syntax.Extension.LHsToken "let" GhcPs + tkLet :: Language.Haskell.Syntax.Concrete.LHsToken "let" GhcPs (bound at hard_hole_fits.hs:34:18) xl :: Language.Haskell.Syntax.Extension.XLet GhcPs (bound at hard_hole_fits.hs:34:15) diff --git a/utils/check-exact/ExactPrint.hs b/utils/check-exact/ExactPrint.hs index cfa50a9e3b..d2005c6733 100644 --- a/utils/check-exact/ExactPrint.hs +++ b/utils/check-exact/ExactPrint.hs @@ -3417,17 +3417,17 @@ exactTransStmt an by using GroupForm = do -- --------------------------------------------------------------------- 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 @@ -3459,7 +3459,8 @@ instance ExactPrint (TyClDecl GhcPs) where -- ----------------------------------- - exact (ClassDecl {tcdCExt = (an, sortKey, lo), + exact (ClassDecl {tcdCExt = (an, sortKey), + tcdLayout = lo, tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFixity = fixity, tcdFDs = fds, @@ -3472,7 +3473,8 @@ instance ExactPrint (TyClDecl GhcPs) where (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', @@ -3498,7 +3500,8 @@ instance ExactPrint (TyClDecl GhcPs) where 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', diff --git a/utils/check-ppr/Main.hs b/utils/check-ppr/Main.hs index 9758889052..29505817b6 100644 --- a/utils/check-ppr/Main.hs +++ b/utils/check-ppr/Main.hs @@ -110,7 +110,7 @@ eraseLayoutInfo = everywhere go where go :: forall a. Typeable a => a -> a go x = - case eqT @a @LayoutInfo of + case eqT @a @(LayoutInfo GhcPs) of Nothing -> x Just Refl -> NoLayoutInfo diff --git a/utils/haddock b/utils/haddock -Subproject 57b7493ba60bc4f4cf6b57b900b0c46fe8d8666 +Subproject 9bede9364033d6167212d86c800bf8e6cc4f579 |