diff options
Diffstat (limited to 'compiler/GHC/Hs')
| -rw-r--r-- | compiler/GHC/Hs/Binds.hs | 53 | ||||
| -rw-r--r-- | compiler/GHC/Hs/ImpExp.hs | 57 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Instances.hs | 5 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Type.hs | 10 | ||||
| -rw-r--r-- | compiler/GHC/Hs/Utils.hs | 6 |
5 files changed, 75 insertions, 56 deletions
diff --git a/compiler/GHC/Hs/Binds.hs b/compiler/GHC/Hs/Binds.hs index 270dc97364..201eb06255 100644 --- a/compiler/GHC/Hs/Binds.hs +++ b/compiler/GHC/Hs/Binds.hs @@ -1230,57 +1230,48 @@ pprMinimalSig (L _ bf) = ppr (fmap unLoc bf) -} -- | Haskell Pattern Synonym Details -type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField (LIdP pass)] --- The Void argument to HsConDetails here is a reflection of the fact that --- type applications are not allowed in declarations of pattern synonyms at present. +type HsPatSynDetails pass = HsConDetails Void (LIdP pass) [RecordPatSynField pass] -- See Note [Record PatSyn Fields] -- | Record Pattern Synonym Field -data RecordPatSynField fld - = RecordPatSynField { - recordPatSynSelectorId :: fld -- Selector name visible in rest of the file - , recordPatSynPatVar :: fld - -- Filled in by renamer, the name used internally - -- by the pattern - } deriving (Data, Functor) - +data RecordPatSynField pass + = RecordPatSynField + { recordPatSynField :: FieldOcc pass + -- ^ Field label visible in rest of the file + , recordPatSynPatVar :: LIdP pass + -- ^ Filled in by renamer, the name used internally by the pattern + } {- Note [Record PatSyn Fields] +~~~~~~~~~~~~~~~~~~~~~~~~~~~ Consider the following two pattern synonyms. -pattern P x y = ([x,True], [y,'v']) -pattern Q{ x, y } =([x,True], [y,'v']) + pattern P x y = ([x,True], [y,'v']) + pattern Q{ x, y } =([x,True], [y,'v']) In P, we just have two local binders, x and y. In Q, we have local binders but also top-level record selectors -x :: ([Bool], [Char]) -> Bool and similarly for y. + x :: ([Bool], [Char]) -> Bool + y :: ([Bool], [Char]) -> Char + +Both are recorded in the `RecordPatSynField`s for `x` and `y`: +* recordPatSynField: the top-level record selector +* recordPatSynPatVar: the local `x`, bound only in the RHS of the pattern synonym. It would make sense to support record-like syntax -pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) + pattern Q{ x=x1, y=y1 } = ([x1,True], [y1,'v']) -when we have a different name for the local and top-level binder -the distinction between the two names clear +when we have a different name for the local and top-level binder, +making the distinction between the two names clear. -} -instance Outputable a => Outputable (RecordPatSynField a) where - ppr (RecordPatSynField { recordPatSynSelectorId = v }) = ppr v - -instance Foldable RecordPatSynField where - foldMap f (RecordPatSynField { recordPatSynSelectorId = visible - , recordPatSynPatVar = hidden }) - = f visible `mappend` f hidden - -instance Traversable RecordPatSynField where - traverse f (RecordPatSynField { recordPatSynSelectorId =visible - , recordPatSynPatVar = hidden }) - = (\ sel_id pat_var -> RecordPatSynField { recordPatSynSelectorId = sel_id - , recordPatSynPatVar = pat_var }) - <$> f visible <*> f hidden +instance Outputable (RecordPatSynField a) where + ppr (RecordPatSynField { recordPatSynField = v }) = ppr v -- | Haskell Pattern Synonym Direction diff --git a/compiler/GHC/Hs/ImpExp.hs b/compiler/GHC/Hs/ImpExp.hs index 0aec281312..33c32aa7f7 100644 --- a/compiler/GHC/Hs/ImpExp.hs +++ b/compiler/GHC/Hs/ImpExp.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveDataTypeable #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} -- Wrinkle in Note [Trees That Grow] -- in module GHC.Hs.Extension @@ -20,7 +22,7 @@ import GHC.Unit.Module ( ModuleName, IsBootInterface(..) ) import GHC.Hs.Doc ( HsDocString ) import GHC.Types.Name.Occurrence ( HasOccName(..), isTcOcc, isSymOcc ) import GHC.Types.SourceText ( SourceText(..), StringLiteral(..), pprWithSourceText ) -import GHC.Types.FieldLabel ( FieldLbl(..) ) +import GHC.Types.FieldLabel ( FieldLabel ) import GHC.Utils.Outputable import GHC.Utils.Panic @@ -229,7 +231,6 @@ data IE pass (LIEWrappedName (IdP pass)) IEWildcard [LIEWrappedName (IdP pass)] - [XRec pass (FieldLbl (IdP pass))] -- ^ Imported or exported Thing With given imported or exported -- -- The thing is a Class/Type and the imported or exported things are @@ -256,46 +257,61 @@ data IE pass type instance XIEVar (GhcPass _) = NoExtField type instance XIEThingAbs (GhcPass _) = NoExtField type instance XIEThingAll (GhcPass _) = NoExtField -type instance XIEThingWith (GhcPass _) = NoExtField type instance XIEModuleContents (GhcPass _) = NoExtField type instance XIEGroup (GhcPass _) = NoExtField type instance XIEDoc (GhcPass _) = NoExtField type instance XIEDocNamed (GhcPass _) = NoExtField type instance XXIE (GhcPass _) = NoExtCon +-- See Note [IEThingWith] +type instance XIEThingWith (GhcPass 'Renamed) = [Located FieldLabel] +type instance XIEThingWith (GhcPass 'Parsed) = NoExtField +type instance XIEThingWith (GhcPass 'Typechecked) = NoExtField + + -- | Imported or Exported Wildcard data IEWildcard = NoIEWildcard | IEWildcard Int deriving (Eq, Data) {- Note [IEThingWith] ~~~~~~~~~~~~~~~~~~ - A definition like + {-# LANGUAGE DuplicateRecordFields #-} module M ( T(MkT, x) ) where data T = MkT { x :: Int } -gives rise to +gives rise to this in the output of the parser: + + IEThingWith NoExtField T [MkT, x] NoIEWildcard + +But in the renamer we need to attach the correct field label, +because the selector Name is mangled (see Note [FieldLabel] in +GHC.Types.FieldLabel). Hence we change this to: + + IEThingWith [FieldLabel "x" True $sel:x:MkT)] T [MkT] NoIEWildcard - IEThingWith T [MkT] [FieldLabel "x" False x)] (without DuplicateRecordFields) - IEThingWith T [MkT] [FieldLabel "x" True $sel:x:MkT)] (with DuplicateRecordFields) +using the TTG extension field to store the list of fields in renamed syntax +only. (Record fields always appear in this list, regardless of whether +DuplicateRecordFields was in use at the definition site or not.) See Note [Representing fields in AvailInfo] in GHC.Types.Avail for more details. -} ieName :: IE (GhcPass p) -> IdP (GhcPass p) -ieName (IEVar _ (L _ n)) = ieWrappedName n -ieName (IEThingAbs _ (L _ n)) = ieWrappedName n -ieName (IEThingWith _ (L _ n) _ _ _) = ieWrappedName n -ieName (IEThingAll _ (L _ n)) = ieWrappedName n +ieName (IEVar _ (L _ n)) = ieWrappedName n +ieName (IEThingAbs _ (L _ n)) = ieWrappedName n +ieName (IEThingWith _ (L _ n) _ _) = ieWrappedName n +ieName (IEThingAll _ (L _ n)) = ieWrappedName n ieName _ = panic "ieName failed pattern match!" ieNames :: IE (GhcPass p) -> [IdP (GhcPass p)] -ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] -ieNames (IEThingWith _ (L _ n) _ ns _) = ieWrappedName n - : map (ieWrappedName . unLoc) ns +ieNames (IEVar _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAbs _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingAll _ (L _ n) ) = [ieWrappedName n] +ieNames (IEThingWith _ (L _ n) _ ns) = ieWrappedName n + : map (ieWrappedName . unLoc) ns +-- NB the above case does not include names of field selectors ieNames (IEModuleContents {}) = [] ieNames (IEGroup {}) = [] ieNames (IEDoc {}) = [] @@ -321,10 +337,9 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where ppr (IEVar _ var) = ppr (unLoc var) ppr (IEThingAbs _ thing) = ppr (unLoc thing) ppr (IEThingAll _ thing) = hcat [ppr (unLoc thing), text "(..)"] - ppr (IEThingWith _ thing wc withs flds) + ppr (IEThingWith flds thing wc withs) = ppr (unLoc thing) <> parens (fsep (punctuate comma - (ppWiths ++ - map (ppr . flLabel . unLoc) flds))) + (ppWiths ++ ppFields) )) where ppWiths = case wc of @@ -333,6 +348,10 @@ instance OutputableBndrId p => Outputable (IE (GhcPass p)) where IEWildcard pos -> let (bs, as) = splitAt pos (map (ppr . unLoc) withs) in bs ++ [text ".."] ++ as + ppFields = + case ghcPass @p of + GhcRn -> map ppr flds + _ -> [] ppr (IEModuleContents _ mod') = text "module" <+> ppr mod' ppr (IEGroup _ n _) = text ("<IEGroup: " ++ show n ++ ">") diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index 7515c37fb5..3098f3a935 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -69,6 +69,11 @@ deriving instance Data (ABExport GhcPs) deriving instance Data (ABExport GhcRn) deriving instance Data (ABExport GhcTc) +-- deriving instance DataId p => Data (RecordPatSynField p) +deriving instance Data (RecordPatSynField GhcPs) +deriving instance Data (RecordPatSynField GhcRn) +deriving instance Data (RecordPatSynField GhcTc) + -- deriving instance (DataIdLR pL pR) => Data (PatSynBind pL pR) deriving instance Data (PatSynBind GhcPs GhcPs) deriving instance Data (PatSynBind GhcPs GhcRn) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index 1b1e56b314..2c64d7a491 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1898,9 +1898,13 @@ type LFieldOcc pass = XRec pass (FieldOcc pass) -- | Field Occurrence -- --- Represents an *occurrence* of an unambiguous field. We store --- both the 'RdrName' the user originally wrote, and after the --- renamer, the selector function. +-- Represents an *occurrence* of an unambiguous field. This may or may not be a +-- binding occurrence (e.g. this type is used in 'ConDeclField' and +-- 'RecordPatSynField' which bind their fields, but also in 'HsRecField' for +-- record construction and patterns, which do not). +-- +-- We store both the 'RdrName' the user originally wrote, and after the renamer, +-- the selector function. data FieldOcc pass = FieldOcc { extFieldOcc :: XCFieldOcc pass , rdrNameFieldOcc :: Located RdrName -- ^ See Note [Located RdrNames] in "GHC.Hs.Expr" diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 0051eaa2c9..e414269413 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1192,17 +1192,17 @@ hsForeignDeclsBinders foreign_decls ------------------- -hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [IdP (GhcPass p)] +hsPatSynSelectors :: IsPass p => HsValBinds (GhcPass p) -> [FieldOcc (GhcPass p)] -- ^ Collects record pattern-synonym selectors only; the pattern synonym -- names are collected by 'collectHsValBinders'. hsPatSynSelectors (ValBinds _ _ _) = panic "hsPatSynSelectors" hsPatSynSelectors (XValBindsLR (NValBinds binds _)) = foldr addPatSynSelector [] . unionManyBags $ map snd binds -addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [IdP p] -> [IdP p] +addPatSynSelector :: forall p. UnXRec p => LHsBind p -> [FieldOcc p] -> [FieldOcc p] addPatSynSelector bind sels | PatSynBind _ (PSB { psb_args = RecCon as }) <- unXRec @p bind - = map (unXRec @p . recordPatSynSelectorId) as ++ sels + = map recordPatSynField as ++ sels | otherwise = sels getPatSynBinds :: forall id. UnXRec id |