diff options
Diffstat (limited to 'compiler/GHC/Types/Id/Info.hs')
| -rw-r--r-- | compiler/GHC/Types/Id/Info.hs | 59 |
1 files changed, 43 insertions, 16 deletions
diff --git a/compiler/GHC/Types/Id/Info.hs b/compiler/GHC/Types/Id/Info.hs index 2b6785117d..9ee20a841a 100644 --- a/compiler/GHC/Types/Id/Info.hs +++ b/compiler/GHC/Types/Id/Info.hs @@ -8,9 +8,11 @@ Haskell. [WDP 94/11]) -} - -{-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE BinaryLiterals #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} {-# OPTIONS_GHC -Wno-incomplete-record-updates #-} @@ -18,7 +20,7 @@ module GHC.Types.Id.Info ( -- * The IdDetails type IdDetails(..), pprIdDetails, coVarDetails, isCoVarDetails, JoinArity, isJoinIdDetails_maybe, - RecSelParent(..), + RecSelParent(..), recSelParentName, recSelFirstConName, -- * The IdInfo type IdInfo, -- Abstract @@ -95,6 +97,7 @@ import GHC.Types.Var.Set import GHC.Types.Basic import GHC.Core.DataCon import GHC.Core.TyCon +import GHC.Core.Type (mkTyConApp) import GHC.Core.PatSyn import GHC.Types.ForeignCall import GHC.Unit.Module @@ -105,11 +108,11 @@ import GHC.Utils.Outputable import GHC.Utils.Panic import GHC.Utils.Panic.Plain import GHC.Stg.InferTags.TagSig +import GHC.StgToCmm.Types (LambdaFormInfo) +import Data.Data ( Data ) import Data.Word -import GHC.StgToCmm.Types (LambdaFormInfo) - -- infixl so you can say (id `set` a `set` b) infixl 1 `setRuleInfo`, `setArityInfo`, @@ -138,8 +141,9 @@ data IdDetails -- | The 'Id' for a record selector | RecSelId - { sel_tycon :: RecSelParent - , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: + { sel_tycon :: RecSelParent + , sel_fieldLabel :: FieldLabel + , sel_naughty :: Bool -- True <=> a "naughty" selector which can't actually exist, for example @x@ in: -- data T = forall a. MkT { x :: a } } -- See Note [Naughty record selectors] in GHC.Tc.TyCl @@ -273,17 +277,40 @@ some applied arguments as we won't inline the wrapper/apply their rule if there are unapplied occurrences like `map f xs`. -} --- | Recursive Selector Parent -data RecSelParent = RecSelData TyCon | RecSelPatSyn PatSyn deriving Eq - -- Either `TyCon` or `PatSyn` depending - -- on the origin of the record selector. - -- For a data type family, this is the - -- /instance/ 'TyCon' not the family 'TyCon' +-- | Parent of a record selector function. +-- +-- Either the parent 'TyCon' or 'PatSyn' depending +-- on the origin of the record selector. +-- +-- For a data family, this is the /instance/ 'TyCon', +-- **not** the family 'TyCon'. +data RecSelParent + -- | Parent of a data constructor record field. + -- + -- For a data family, this is the /instance/ 'TyCon'. + = RecSelData TyCon + -- | Parent of a pattern synonym record field: + -- the 'PatSyn' itself. + | RecSelPatSyn PatSyn + deriving (Eq, Data) + +recSelParentName :: RecSelParent -> Name +recSelParentName (RecSelData tc) = tyConName tc +recSelParentName (RecSelPatSyn ps) = patSynName ps + +recSelFirstConName :: RecSelParent -> Name +recSelFirstConName (RecSelData tc) = dataConName $ head $ tyConDataCons tc +recSelFirstConName (RecSelPatSyn ps) = patSynName ps instance Outputable RecSelParent where ppr p = case p of - RecSelData ty_con -> ppr ty_con - RecSelPatSyn ps -> ppr ps + RecSelData tc + | Just (parent_tc, tys) <- tyConFamInst_maybe tc + -> ppr (mkTyConApp parent_tc tys) + | otherwise + -> ppr tc + RecSelPatSyn ps + -> ppr ps -- | Just a synonym for 'CoVarId'. Written separately so it can be -- exported in the hs-boot file. @@ -307,7 +334,7 @@ pprIdDetails VanillaId = empty pprIdDetails other = brackets (pp other) where pp VanillaId = panic "pprIdDetails" - pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) + pp (WorkerLikeId dmds) = text "StrictWorker" <> parens (ppr dmds) pp (DataConWorkId _) = text "DataCon" pp (DataConWrapId _) = text "DataConWrapper" pp (ClassOpId {}) = text "ClassOp" |