diff options
22 files changed, 331 insertions, 196 deletions
diff --git a/compiler/GHC/Hs/Decls.hs b/compiler/GHC/Hs/Decls.hs index 51f1e2a127..2024b61b81 100644 --- a/compiler/GHC/Hs/Decls.hs +++ b/compiler/GHC/Hs/Decls.hs @@ -74,8 +74,8 @@ module GHC.Hs.Decls ( CImportSpec(..), -- ** Data-constructor declarations ConDecl(..), LConDecl, - HsConDeclDetails, hsConDeclArgTys, hsConDeclTheta, - getConNames, getConArgs, + HsConDeclH98Details, HsConDeclGADTDetails(..), hsConDeclTheta, + getConNames, getRecConArgs_maybe, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations @@ -1476,9 +1476,9 @@ data ConDecl pass -- Whether or not there is an /explicit/ forall, we still -- need to capture the implicitly-bound type/kind variables - , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; never InfixCon - , con_res_ty :: LHsType pass -- ^ Result type + , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) + , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix + , con_res_ty :: LHsType pass -- ^ Result type , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. @@ -1495,7 +1495,7 @@ data ConDecl pass -- False => con_ex_tvs is empty , con_ex_tvs :: [LHsTyVarBndr Specificity pass] -- ^ Existentials only , con_mb_cxt :: Maybe (LHsContext pass) -- ^ User-written context (if any) - , con_args :: HsConDeclDetails pass -- ^ Arguments; can be InfixCon + , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix , con_doc :: Maybe LHsDocString -- ^ A possible Haddock comment. @@ -1626,27 +1626,35 @@ or contexts in two parts: quantification occurs after a visible argument type. -} --- | Haskell data Constructor Declaration Details -type HsConDeclDetails pass +-- | The arguments in a Haskell98-style data constructor. +type HsConDeclH98Details pass = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass]) +-- | The arguments in a GADT constructor. Unlike Haskell98-style constructors, +-- GADT constructors cannot be declared with infix syntax. As a result, we do +-- not use 'HsConDetails' here, as 'InfixCon' would be an unrepresentable +-- state. (There is a notion of infix GADT constructors for the purposes of +-- derived Show instances—see Note [Infix GADT constructors] in +-- GHC.Tc.TyCl—but that is an orthogonal concern.) +data HsConDeclGADTDetails pass + = PrefixConGADT [HsScaled pass (LBangType pass)] + | RecConGADT (XRec pass [LConDeclField pass]) + getConNames :: ConDecl GhcRn -> [Located Name] getConNames ConDeclH98 {con_name = name} = [name] getConNames ConDeclGADT {con_names = names} = names -getConArgs :: ConDecl GhcRn -> HsConDeclDetails GhcRn -getConArgs d = con_args d - -hsConDeclArgTys :: HsConDeclDetails (GhcPass p) -> [HsScaled (GhcPass p) (LBangType (GhcPass p))] -hsConDeclArgTys (PrefixCon tys) = tys -hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] -hsConDeclArgTys (RecCon flds) = map (hsLinear . cd_fld_type . unLoc) (unLoc flds) - -- Remark: with the record syntax, constructors have all their argument - -- linear, despite the fact that projections do not make sense on linear - -- constructors. The design here is that the record projection themselves are - -- typed to take an unrestricted argument (that is the record itself is - -- unrestricted). By the transfer property, projections are then correct in - -- that all the non-projected fields have multiplicity Many, and can be dropped. +-- | Return @'Just' fields@ if a data constructor declaration uses record +-- syntax (i.e., 'RecCon'), where @fields@ are the field selectors. +-- Otherwise, return 'Nothing'. +getRecConArgs_maybe :: ConDecl GhcRn -> Maybe (Located [LConDeclField GhcRn]) +getRecConArgs_maybe (ConDeclH98{con_args = args}) = case args of + PrefixCon{} -> Nothing + RecCon flds -> Just flds + InfixCon{} -> Nothing +getRecConArgs_maybe (ConDeclGADT{con_g_args = args}) = case args of + PrefixConGADT{} -> Nothing + RecConGADT flds -> Just flds hsConDeclTheta :: Maybe (LHsContext (GhcPass p)) -> [LHsType (GhcPass p)] hsConDeclTheta Nothing = [] @@ -1726,15 +1734,14 @@ pprConDecl (ConDeclH98 { con_name = L _ con cxt = fromMaybe noLHsContext mcxt pprConDecl (ConDeclGADT { con_names = cons, con_qvars = qvars - , con_mb_cxt = mcxt, con_args = args + , con_mb_cxt = mcxt, con_g_args = args , con_res_ty = res_ty, con_doc = doc }) = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> (sep [pprHsForAll (mkHsForAllInvisTele qvars) cxt, ppr_arrow_chain (get_args args ++ [ppr res_ty]) ]) where - get_args (PrefixCon args) = map ppr args - get_args (RecCon fields) = [pprConDeclFields (unLoc fields)] - get_args (InfixCon {}) = pprPanic "pprConDecl:GADT" (ppr cons) + get_args (PrefixConGADT args) = map ppr args + get_args (RecConGADT fields) = [pprConDeclFields (unLoc fields)] cxt = fromMaybe noLHsContext mcxt diff --git a/compiler/GHC/Hs/Instances.hs b/compiler/GHC/Hs/Instances.hs index e1f3d29f21..76ce16948b 100644 --- a/compiler/GHC/Hs/Instances.hs +++ b/compiler/GHC/Hs/Instances.hs @@ -173,6 +173,11 @@ deriving instance Data (ConDecl GhcPs) deriving instance Data (ConDecl GhcRn) deriving instance Data (ConDecl GhcTc) +-- deriving instance DataIdLR p p => Data (HsConDeclGADTDetails p) +deriving instance Data (HsConDeclGADTDetails GhcPs) +deriving instance Data (HsConDeclGADTDetails GhcRn) +deriving instance Data (HsConDeclGADTDetails GhcTc) + -- deriving instance DataIdLR p p => Data (TyFamInstDecl p) deriving instance Data (TyFamInstDecl GhcPs) deriving instance Data (TyFamInstDecl GhcRn) diff --git a/compiler/GHC/Hs/Type.hs b/compiler/GHC/Hs/Type.hs index ed3b20a0ec..db6508d581 100644 --- a/compiler/GHC/Hs/Type.hs +++ b/compiler/GHC/Hs/Type.hs @@ -1102,9 +1102,22 @@ instance OutputableBndrId p => Outputable (ConDeclField (GhcPass p)) where ppr (ConDeclField _ fld_n fld_ty _) = ppr fld_n <+> dcolon <+> ppr fld_ty --- HsConDetails is used for patterns/expressions *and* for data type --- declarations --- | Haskell Constructor Details +-- | Describes the arguments to a data constructor. This is a common +-- representation for several constructor-related concepts, including: +-- +-- * The arguments in a Haskell98-style constructor declaration +-- (see 'HsConDeclH98Details' in "GHC.Hs.Decls"). +-- +-- * The arguments in constructor patterns in @case@/function definitions +-- (see 'HsConPatDetails' in "GHC.Hs.Pat"). +-- +-- * The left-hand side arguments in a pattern synonym binding +-- (see 'HsPatSynDetails' in "GHC.Hs.Binds"). +-- +-- One notable exception is the arguments in a GADT constructor, which uses +-- a separate data type entirely (see 'HsConDeclGADTDetails' in +-- "GHC.Hs.Decls"). This is because GADT constructors cannot be declared with +-- infix syntax, unlike the concepts above (#18844). data HsConDetails arg rec = PrefixCon [arg] -- C p1 p2 p3 | RecCon rec -- C { x = p1, y = p2 } diff --git a/compiler/GHC/Hs/Utils.hs b/compiler/GHC/Hs/Utils.hs index 8252d91249..da55ebf89e 100644 --- a/compiler/GHC/Hs/Utils.hs +++ b/compiler/GHC/Hs/Utils.hs @@ -1259,29 +1259,36 @@ hsConDeclsBinders cons in case unLoc r of -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) - ConDeclGADT { con_names = names, con_args = args } + ConDeclGADT { con_names = names, con_g_args = args } -> (map (L loc . unLoc) names ++ ns, flds ++ fs) where - (remSeen', flds) = get_flds remSeen args + (remSeen', flds) = get_flds_gadt remSeen args (ns, fs) = go remSeen' rs ConDeclH98 { con_name = name, con_args = args } -> ([L loc (unLoc name)] ++ ns, flds ++ fs) where - (remSeen', flds) = get_flds remSeen args + (remSeen', flds) = get_flds_h98 remSeen args (ns, fs) = go remSeen' rs - get_flds :: Seen p -> HsConDeclDetails (GhcPass p) + get_flds_h98 :: Seen p -> HsConDeclH98Details (GhcPass p) + -> (Seen p, [LFieldOcc (GhcPass p)]) + get_flds_h98 remSeen (RecCon flds) = get_flds remSeen flds + get_flds_h98 remSeen _ = (remSeen, []) + + get_flds_gadt :: Seen p -> HsConDeclGADTDetails (GhcPass p) + -> (Seen p, [LFieldOcc (GhcPass p)]) + get_flds_gadt remSeen (RecConGADT flds) = get_flds remSeen flds + get_flds_gadt remSeen _ = (remSeen, []) + + get_flds :: Seen p -> Located [LConDeclField (GhcPass p)] -> (Seen p, [LFieldOcc (GhcPass p)]) - get_flds remSeen (RecCon flds) - = (remSeen', fld_names) + get_flds remSeen flds = (remSeen', fld_names) where fld_names = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` unLoc . rdrNameFieldOcc . unLoc) v | v <- fld_names] - get_flds remSeen _ - = (remSeen, []) {- diff --git a/compiler/GHC/HsToCore/Docs.hs b/compiler/GHC/HsToCore/Docs.hs index 2a82c986e3..38162298c4 100644 --- a/compiler/GHC/HsToCore/Docs.hs +++ b/compiler/GHC/HsToCore/Docs.hs @@ -189,7 +189,7 @@ subordinates instMap decl = case decl of , conArgDocs c) | c <- cons, cname <- getConNames c ] fields = [ (extFieldOcc n, maybeToList $ fmap unLoc doc, M.empty) - | RecCon flds <- map getConArgs cons + | Just flds <- map getRecConArgs_maybe cons , (L _ (ConDeclField _ ns _ doc)) <- (unLoc flds) , (L _ n) <- ns ] derivs = [ (instName, [unLoc doc], M.empty) @@ -216,22 +216,30 @@ subordinates instMap decl = case decl of _ -> Nothing -- | Extract constructor argument docs from inside constructor decls. -conArgDocs :: ConDecl GhcRn -> Map Int (HsDocString) -conArgDocs con = case getConArgs con of - PrefixCon args -> go 0 (map (unLoc . hsScaledThing) args ++ ret) - InfixCon arg1 arg2 -> go 0 ([unLoc (hsScaledThing arg1), - unLoc (hsScaledThing arg2)] ++ ret) - RecCon _ -> go 1 ret +conArgDocs :: ConDecl GhcRn -> Map Int HsDocString +conArgDocs (ConDeclH98{con_args = args}) = + h98ConArgDocs args +conArgDocs (ConDeclGADT{con_g_args = args, con_res_ty = res_ty}) = + gadtConArgDocs args (unLoc res_ty) + +h98ConArgDocs :: HsConDeclH98Details GhcRn -> Map Int HsDocString +h98ConArgDocs con_args = case con_args of + PrefixCon args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args + InfixCon arg1 arg2 -> con_arg_docs 0 [ unLoc (hsScaledThing arg1) + , unLoc (hsScaledThing arg2) ] + RecCon _ -> M.empty + +gadtConArgDocs :: HsConDeclGADTDetails GhcRn -> HsType GhcRn -> Map Int HsDocString +gadtConArgDocs con_args res_ty = case con_args of + PrefixConGADT args -> con_arg_docs 0 $ map (unLoc . hsScaledThing) args ++ [res_ty] + RecConGADT _ -> con_arg_docs 1 [res_ty] + +con_arg_docs :: Int -> [HsType GhcRn] -> Map Int HsDocString +con_arg_docs n = M.fromList . catMaybes . zipWith f [n..] where - go n = M.fromList . catMaybes . zipWith f [n..] - where - f n (HsDocTy _ _ lds) = Just (n, unLoc lds) - f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds) - f _ _ = Nothing - - ret = case con of - ConDeclGADT { con_res_ty = res_ty } -> [ unLoc res_ty ] - _ -> [] + f n (HsDocTy _ _ lds) = Just (n, unLoc lds) + f n (HsBangTy _ _ (L _ (HsDocTy _ _ lds))) = Just (n, unLoc lds) + f _ _ = Nothing isValD :: HsDecl a -> Bool isValD (ValD _ _) = True diff --git a/compiler/GHC/HsToCore/Quote.hs b/compiler/GHC/HsToCore/Quote.hs index fb2b78141b..b22d45d182 100644 --- a/compiler/GHC/HsToCore/Quote.hs +++ b/compiler/GHC/HsToCore/Quote.hs @@ -877,7 +877,7 @@ repC (L _ (ConDeclH98 { con_name = con , con_forall = (L _ False) , con_mb_cxt = Nothing , con_args = args })) - = repDataCon con args + = repH98DataCon con args repC (L _ (ConDeclH98 { con_name = con , con_forall = L _ is_existential @@ -885,7 +885,7 @@ repC (L _ (ConDeclH98 { con_name = con , con_mb_cxt = mcxt , con_args = args })) = do { addHsTyVarBinds con_tvs $ \ ex_bndrs -> - do { c' <- repDataCon con args + do { c' <- repH98DataCon con args ; ctxt' <- repMbContext mcxt ; if not is_existential && isNothing mcxt then return c' @@ -897,7 +897,7 @@ repC (L _ (ConDeclGADT { con_g_ext = imp_tvs , con_names = cons , con_qvars = exp_tvs , con_mb_cxt = mcxt - , con_args = args + , con_g_args = args , con_res_ty = res_ty })) | null imp_tvs && null exp_tvs -- No implicit or explicit variables , Nothing <- mcxt -- No context @@ -2589,49 +2589,51 @@ repImplicitParamBind (MkC n) (MkC e) = rep2 implicitParamBindDName [n, e] repCtxt :: Core [(M TH.Pred)] -> MetaM (Core (M TH.Cxt)) repCtxt (MkC tys) = rep2 cxtName [tys] -repDataCon :: Located Name - -> HsConDeclDetails GhcRn - -> MetaM (Core (M TH.Con)) -repDataCon con details +repH98DataCon :: Located Name + -> HsConDeclH98Details GhcRn + -> MetaM (Core (M TH.Con)) +repH98DataCon con details = do con' <- lookupLOcc con -- See Note [Binders and occurrences] - repConstr details Nothing [con'] + case details of + PrefixCon ps -> do + arg_tys <- repPrefixConArgs ps + rep2 normalCName [unC con', unC arg_tys] + InfixCon st1 st2 -> do + arg1 <- repBangTy (hsScaledThing st1) + arg2 <- repBangTy (hsScaledThing st2) + rep2 infixCName [unC arg1, unC con', unC arg2] + RecCon ips -> do + arg_vtys <- repRecConArgs ips + rep2 recCName [unC con', unC arg_vtys] repGadtDataCons :: [Located Name] - -> HsConDeclDetails GhcRn + -> HsConDeclGADTDetails GhcRn -> LHsType GhcRn -> MetaM (Core (M TH.Con)) repGadtDataCons cons details res_ty = do cons' <- mapM lookupLOcc cons -- See Note [Binders and occurrences] - repConstr details (Just res_ty) cons' - --- Invariant: --- * for plain H98 data constructors second argument is Nothing and third --- argument is a singleton list --- * for GADTs data constructors second argument is (Just return_type) and --- third argument is a non-empty list -repConstr :: HsConDeclDetails GhcRn - -> Maybe (LHsType GhcRn) - -> [Core TH.Name] - -> MetaM (Core (M TH.Con)) -repConstr (PrefixCon ps) Nothing [con] - = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) - rep2 normalCName [unC con, unC arg_tys] - -repConstr (PrefixCon ps) (Just res_ty) cons - = do arg_tys <- repListM bangTypeTyConName repBangTy (map hsScaledThing ps) - res_ty' <- repLTy res_ty - rep2 gadtCName [ unC (nonEmptyCoreList cons), unC arg_tys, unC res_ty'] - -repConstr (RecCon ips) resTy cons - = do args <- concatMapM rep_ip (unLoc ips) - arg_vtys <- coreListM varBangTypeTyConName args - case resTy of - Nothing -> rep2 recCName [unC (head cons), unC arg_vtys] - Just res_ty -> do + case details of + PrefixConGADT ps -> do + arg_tys <- repPrefixConArgs ps res_ty' <- repLTy res_ty - rep2 recGadtCName [unC (nonEmptyCoreList cons), unC arg_vtys, + rep2 gadtCName [ unC (nonEmptyCoreList cons'), unC arg_tys, unC res_ty'] + RecConGADT ips -> do + arg_vtys <- repRecConArgs ips + res_ty' <- repLTy res_ty + rep2 recGadtCName [unC (nonEmptyCoreList cons'), unC arg_vtys, unC res_ty'] +-- Desugar the arguments in a data constructor declared with prefix syntax. +repPrefixConArgs :: [HsScaled GhcRn (LHsType GhcRn)] + -> MetaM (Core [M TH.BangType]) +repPrefixConArgs ps = repListM bangTypeTyConName repBangTy (map hsScaledThing ps) + +-- Desugar the arguments in a data constructor declared with record syntax. +repRecConArgs :: Located [LConDeclField GhcRn] + -> MetaM (Core [M TH.VarBangType]) +repRecConArgs ips = do + args <- concatMapM rep_ip (unLoc ips) + coreListM varBangTypeTyConName args where rep_ip (L _ ip) = mapM (rep_one_ip (cd_fld_type ip)) (cd_fld_names ip) @@ -2640,16 +2642,6 @@ repConstr (RecCon ips) resTy cons ; MkC ty <- repBangTy t ; rep2 varBangTypeName [v,ty] } -repConstr (InfixCon st1 st2) Nothing [con] - = do arg1 <- repBangTy (hsScaledThing st1) - arg2 <- repBangTy (hsScaledThing st2) - rep2 infixCName [unC arg1, unC con, unC arg2] - -repConstr (InfixCon {}) (Just _) _ = - panic "repConstr: infix GADT constructor should be in a PrefixCon" -repConstr _ _ _ = - panic "repConstr: invariant violated" - ------------ Types ------------------- repTForall :: Core [(M (TH.TyVarBndr TH.Specificity))] -> Core (M TH.Cxt) -> Core (M TH.Type) diff --git a/compiler/GHC/Iface/Ext/Ast.hs b/compiler/GHC/Iface/Ext/Ast.hs index f13cbf30b3..c06373eb62 100644 --- a/compiler/GHC/Iface/Ext/Ast.hs +++ b/compiler/GHC/Iface/Ext/Ast.hs @@ -1321,6 +1321,10 @@ instance (ToHie arg, ToHie rec) => ToHie (HsConDetails arg rec) where toHie (RecCon rec) = toHie rec toHie (InfixCon a b) = concatM [ toHie a, toHie b] +instance ToHie (HsConDeclGADTDetails GhcRn) where + toHie (PrefixConGADT args) = toHie args + toHie (RecConGADT rec) = toHie rec + instance HiePass p => ToHie (Located (HsCmdTop (GhcPass p))) where toHie (L span top) = concatM $ makeNode top span : case top of HsCmdTop _ cmd -> @@ -1532,7 +1536,7 @@ instance ToHie a => ToHie (HsScaled GhcRn a) where instance ToHie (Located (ConDecl GhcRn)) where toHie (L span decl) = concatM $ makeNode decl span : case decl of ConDeclGADT { con_names = names, con_qvars = exp_vars, con_g_ext = imp_vars - , con_mb_cxt = ctx, con_args = args, con_res_ty = typ } -> + , con_mb_cxt = ctx, con_g_args = args, con_res_ty = typ } -> [ toHie $ map (C (Decl ConDec $ getRealSpan span)) names , concatM $ [ bindingsOnly bindings , toHie $ tvScopes resScope NoScope exp_vars ] @@ -1543,7 +1547,9 @@ instance ToHie (Located (ConDecl GhcRn)) where where rhsScope = combineScopes argsScope tyScope ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope args + argsScope = case args of + PrefixConGADT xs -> scaled_args_scope xs + RecConGADT x -> mkLScope x tyScope = mkLScope typ resScope = ResolvedScopes [ctxScope, rhsScope] bindings = map (C $ TyVarBind (mkScope (loc exp_vars)) resScope) imp_vars @@ -1557,13 +1563,12 @@ instance ToHie (Located (ConDecl GhcRn)) where where rhsScope = combineScopes ctxScope argsScope ctxScope = maybe NoScope mkLScope ctx - argsScope = condecl_scope dets - where condecl_scope :: HsConDeclDetails (GhcPass p) -> Scope - condecl_scope args = case args of - PrefixCon xs -> foldr combineScopes NoScope $ map (mkLScope . hsScaledThing) xs - InfixCon a b -> combineScopes (mkLScope (hsScaledThing a)) - (mkLScope (hsScaledThing b)) - RecCon x -> mkLScope x + argsScope = case dets of + PrefixCon xs -> scaled_args_scope xs + InfixCon a b -> scaled_args_scope [a, b] + RecCon x -> mkLScope x + where scaled_args_scope :: [HsScaled GhcRn (LHsType GhcRn)] -> Scope + scaled_args_scope = foldr combineScopes NoScope . map (mkLScope . hsScaledThing) instance ToHie (Located [Located (ConDeclField GhcRn)]) where toHie (L span decls) = concatM $ diff --git a/compiler/GHC/Parser.y b/compiler/GHC/Parser.y index 90d8ed10c8..10727e1e17 100644 --- a/compiler/GHC/Parser.y +++ b/compiler/GHC/Parser.y @@ -2330,7 +2330,7 @@ forall :: { Located ([AddAnn], Maybe [LHsTyVarBndr Specificity GhcPs]) } : 'forall' tv_bndrs '.' { sLL $1 $> ([mu AnnForall $1,mj AnnDot $3], Just $2) } | {- empty -} { noLoc ([], Nothing) } -constr_stuff :: { Located (Located RdrName, HsConDeclDetails GhcPs) } +constr_stuff :: { Located (Located RdrName, HsConDeclH98Details GhcPs) } : infixtype {% fmap (mapLoc (\b -> (dataConBuilderCon b, dataConBuilderDetails b))) (runPV $1) } diff --git a/compiler/GHC/Parser/PostProcess.hs b/compiler/GHC/Parser/PostProcess.hs index 20a8f179d1..8e85c9493e 100644 --- a/compiler/GHC/Parser/PostProcess.hs +++ b/compiler/GHC/Parser/PostProcess.hs @@ -611,7 +611,7 @@ recordPatSynErr loc pat = addFatalError $ Error (ErrRecordSyntaxInPatSynDecl pat) [] loc mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr Specificity GhcPs] - -> Maybe (LHsContext GhcPs) -> HsConDeclDetails GhcPs + -> Maybe (LHsContext GhcPs) -> HsConDeclH98Details GhcPs -> ConDecl GhcPs mkConDeclH98 name mb_forall mb_cxt args @@ -636,17 +636,17 @@ mkGadtDecl :: [Located RdrName] mkGadtDecl names ty = do let (args, res_ty, anns) | L _ (HsFunTy _ _w (L loc (HsRecTy _ rf)) res_ty) <- body_ty - = (RecCon (L loc rf), res_ty, []) + = (RecConGADT (L loc rf), res_ty, []) | otherwise = let (arg_types, res_type, anns) = splitHsFunType body_ty - in (PrefixCon arg_types, res_type, anns) + in (PrefixConGADT arg_types, res_type, anns) pure ( ConDeclGADT { con_g_ext = noExtField , con_names = names , con_forall = L (getLoc ty) $ isJust mtvs , con_qvars = fromMaybe [] mtvs , con_mb_cxt = mcxt - , con_args = args + , con_g_args = args , con_res_ty = res_ty , con_doc = Nothing } , anns ) @@ -1618,7 +1618,7 @@ dataConBuilderCon :: DataConBuilder -> Located RdrName dataConBuilderCon (PrefixDataConBuilder _ dc) = dc dataConBuilderCon (InfixDataConBuilder _ dc _) = dc -dataConBuilderDetails :: DataConBuilder -> HsConDeclDetails GhcPs +dataConBuilderDetails :: DataConBuilder -> HsConDeclH98Details GhcPs -- Detect when the record syntax is used: -- data T = MkT { ... } diff --git a/compiler/GHC/Parser/PostProcess/Haddock.hs b/compiler/GHC/Parser/PostProcess/Haddock.hs index 7959db5a7c..0837cac70e 100644 --- a/compiler/GHC/Parser/PostProcess/Haddock.hs +++ b/compiler/GHC/Parser/PostProcess/Haddock.hs @@ -690,22 +690,21 @@ instance HasHaddock (Located (ConDecl GhcPs)) where addHaddock (L l_con_decl con_decl) = extendHdkA l_con_decl $ case con_decl of - ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_args, con_res_ty } -> do + ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_g_args, con_res_ty } -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. con_doc' <- discardHasInnerDocs $ getConDoc (getLoc (head con_names)) - con_args' <- - case con_args of - PrefixCon ts -> PrefixCon <$> addHaddock ts - RecCon (L l_rec flds) -> do + con_g_args' <- + case con_g_args of + PrefixConGADT ts -> PrefixConGADT <$> addHaddock ts + RecConGADT (L l_rec flds) -> do -- discardHasInnerDocs is ok because we don't need this info for GADTs. flds' <- traverse (discardHasInnerDocs . addHaddockConDeclField) flds - pure $ RecCon (L l_rec flds') - InfixCon _ _ -> panic "ConDeclGADT InfixCon" + pure $ RecConGADT (L l_rec flds') con_res_ty' <- addHaddock con_res_ty pure $ L l_con_decl $ ConDeclGADT { con_g_ext, con_names, con_forall, con_qvars, con_mb_cxt, con_doc = con_doc', - con_args = con_args', + con_g_args = con_g_args', con_res_ty = con_res_ty' } ConDeclH98 { con_ext, con_name, con_forall, con_ex_tvs, con_mb_cxt, con_args } -> addConTrailingDoc (srcSpanEnd l_con_decl) $ diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs index 6deee41fea..ac92e300b5 100644 --- a/compiler/GHC/Rename/HsType.hs +++ b/compiler/GHC/Rename/HsType.hs @@ -29,9 +29,9 @@ module GHC.Rename.HsType ( rnImplicitBndrs, bindSigTyVarsFV, bindHsQTyVars, FreeKiTyVars, extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars, - extractHsTysRdrTyVars, extractRdrKindSigVars, extractDataDefnKindVars, + extractHsTysRdrTyVars, extractRdrKindSigVars, + extractConDeclGADTDetailsTyVars, extractDataDefnKindVars, extractHsTvBndrs, extractHsTyArgRdrKiTyVars, - extractHsScaledTysRdrTyVars, forAllOrNothing, nubL ) where @@ -1747,9 +1747,6 @@ extractHsTyArgRdrKiTyVars args extractHsTyRdrTyVars :: LHsType GhcPs -> FreeKiTyVars extractHsTyRdrTyVars ty = extract_lty ty [] -extractHsScaledTysRdrTyVars :: [HsScaled GhcPs (LHsType GhcPs)] -> FreeKiTyVars -> FreeKiTyVars -extractHsScaledTysRdrTyVars args acc = foldr (\(HsScaled m ty) -> extract_lty ty . extract_hs_arrow m) acc args - -- | Extracts the free type/kind variables from the kind signature of a HsType. -- This is used to implicitly quantify over @k@ in @type T = Nothing :: Maybe k@. -- The left-to-right order of variables is preserved. @@ -1787,6 +1784,15 @@ extractRdrKindSigVars (L _ resultSig) = case resultSig of TyVarSig _ (L _ (KindedTyVar _ _ _ k)) -> extractHsTyRdrTyVars k _ -> [] +-- | Extracts free type and kind variables from an argument in a GADT +-- constructor, returning variable occurrences in left-to-right order. +-- See @Note [Ordering of implicit variables]@. +extractConDeclGADTDetailsTyVars :: + HsConDeclGADTDetails GhcPs -> FreeKiTyVars -> FreeKiTyVars +extractConDeclGADTDetailsTyVars con_args = case con_args of + PrefixConGADT args -> extract_scaled_ltys args + RecConGADT (L _ flds) -> extract_ltys $ map (cd_fld_type . unLoc) $ flds + -- | Get type/kind variables mentioned in the kind signature, preserving -- left-to-right order: -- @@ -1801,6 +1807,14 @@ extractDataDefnKindVars (HsDataDefn { dd_kindSig = ksig }) extract_lctxt :: LHsContext GhcPs -> FreeKiTyVars -> FreeKiTyVars extract_lctxt ctxt = extract_ltys (unLoc ctxt) +extract_scaled_ltys :: [HsScaled GhcPs (LHsType GhcPs)] + -> FreeKiTyVars -> FreeKiTyVars +extract_scaled_ltys args acc = foldr extract_scaled_lty acc args + +extract_scaled_lty :: HsScaled GhcPs (LHsType GhcPs) + -> FreeKiTyVars -> FreeKiTyVars +extract_scaled_lty (HsScaled m ty) acc = extract_lty ty $ extract_hs_arrow m acc + extract_ltys :: [LHsType GhcPs] -> FreeKiTyVars -> FreeKiTyVars extract_ltys tys acc = foldr extract_lty acc tys diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs index dbca13302c..f815cd5c4a 100644 --- a/compiler/GHC/Rename/Module.hs +++ b/compiler/GHC/Rename/Module.hs @@ -2181,7 +2181,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs ; bindLHsTyVarBndrs ctxt WarnUnusedForalls Nothing ex_tvs $ \ new_ex_tvs -> do { (new_context, fvs1) <- rnMbContext ctxt mcxt - ; (new_args, fvs2) <- rnConDeclDetails (unLoc new_name) ctxt args + ; (new_args, fvs2) <- rnConDeclH98Details (unLoc new_name) ctxt args ; let all_fvs = fvs1 `plusFV` fvs2 ; traceRn "rnConDecl (ConDeclH98)" (ppr name <+> vcat [ text "ex_tvs:" <+> ppr ex_tvs @@ -2198,15 +2198,12 @@ rnConDecl decl@(ConDeclGADT { con_names = names , con_forall = forall@(L _ explicit_forall) , con_qvars = explicit_tkvs , con_mb_cxt = mcxt - , con_args = args + , con_g_args = args , con_res_ty = res_ty , con_doc = mb_doc }) = do { mapM_ (addLocM checkConName) names ; new_names <- mapM lookupLocatedTopBndrRn names - ; let theta = hsConDeclTheta mcxt - arg_tys = hsConDeclArgTys args - -- We must ensure that we extract the free tkvs in left-to-right -- order of their appearance in the constructor type. -- That order governs the order the implicitly-quantified type @@ -2214,9 +2211,9 @@ rnConDecl decl@(ConDeclGADT { con_names = names -- See #14808. ; implicit_bndrs <- forAllOrNothing explicit_forall $ extractHsTvBndrs explicit_tkvs - $ extractHsTysRdrTyVars theta - $ extractHsScaledTysRdrTyVars arg_tys - $ extractHsTysRdrTyVars [res_ty] [] + $ extractHsTysRdrTyVars (hsConDeclTheta mcxt) + $ extractConDeclGADTDetailsTyVars args + $ extractHsTyRdrTyVars res_ty ; let ctxt = ConDeclCtx new_names @@ -2224,7 +2221,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names bindLHsTyVarBndrs ctxt WarnUnusedForalls Nothing explicit_tkvs $ \ explicit_tkvs -> do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt - ; (new_args, fvs2) <- rnConDeclDetails (unLoc (head new_names)) ctxt args + ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty -- Ensure that there are no nested `forall`s or contexts, per @@ -2239,7 +2236,7 @@ rnConDecl decl@(ConDeclGADT { con_names = names (ppr names $$ ppr implicit_tkvs $$ ppr explicit_tkvs) ; return (decl { con_g_ext = implicit_tkvs, con_names = new_names , con_qvars = explicit_tkvs, con_mb_cxt = new_cxt - , con_args = new_args, con_res_ty = new_res_ty + , con_g_args = new_args, con_res_ty = new_res_ty , con_doc = mb_doc , con_forall = forall }, -- Remove when #18311 is fixed all_fvs) } } @@ -2250,27 +2247,45 @@ rnMbContext _ Nothing = return (Nothing, emptyFVs) rnMbContext doc (Just cxt) = do { (ctx',fvs) <- rnContext doc cxt ; return (Just ctx',fvs) } -rnConDeclDetails - :: Name +rnConDeclH98Details :: + Name -> HsDocContext - -> HsConDetails (HsScaled GhcPs (LHsType GhcPs)) (Located [LConDeclField GhcPs]) - -> RnM ((HsConDetails (HsScaled GhcRn (LHsType GhcRn))) (Located [LConDeclField GhcRn]), - FreeVars) -rnConDeclDetails _ doc (PrefixCon tys) + -> HsConDeclH98Details GhcPs + -> RnM (HsConDeclH98Details GhcRn, FreeVars) +rnConDeclH98Details _ doc (PrefixCon tys) = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys ; return (PrefixCon new_tys, fvs) } - -rnConDeclDetails _ doc (InfixCon ty1 ty2) +rnConDeclH98Details _ doc (InfixCon ty1 ty2) = do { (new_ty1, fvs1) <- rnScaledLHsType doc ty1 ; (new_ty2, fvs2) <- rnScaledLHsType doc ty2 ; return (InfixCon new_ty1 new_ty2, fvs1 `plusFV` fvs2) } +rnConDeclH98Details con doc (RecCon flds) + = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds + ; return (RecCon new_flds, fvs) } -rnConDeclDetails con doc (RecCon (L l fields)) +rnConDeclGADTDetails :: + Name + -> HsDocContext + -> HsConDeclGADTDetails GhcPs + -> RnM (HsConDeclGADTDetails GhcRn, FreeVars) +rnConDeclGADTDetails _ doc (PrefixConGADT tys) + = do { (new_tys, fvs) <- mapFvRn (rnScaledLHsType doc) tys + ; return (PrefixConGADT new_tys, fvs) } +rnConDeclGADTDetails con doc (RecConGADT flds) + = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds + ; return (RecConGADT new_flds, fvs) } + +rnRecConDeclFields :: + Name + -> HsDocContext + -> Located [LConDeclField GhcPs] + -> RnM (Located [LConDeclField GhcRn], FreeVars) +rnRecConDeclFields con doc (L l fields) = do { fls <- lookupConstructorFields con ; (new_fields, fvs) <- rnConDeclFields doc fls fields -- No need to check for duplicate fields -- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn - ; return (RecCon (L l new_fields), fvs) } + ; pure (L l new_fields, fvs) } ------------------------------------------------- diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs index 5115d058d7..ac8117e4a1 100644 --- a/compiler/GHC/Rename/Names.hs +++ b/compiler/GHC/Rename/Names.hs @@ -775,7 +775,7 @@ getLocalNonValBinders fixity_env = [( find_con_name rdr , concatMap find_con_decl_flds (unLoc cdflds) )] find_con_flds (L _ (ConDeclGADT { con_names = rdrs - , con_args = RecCon flds })) + , con_g_args = RecConGADT flds })) = [ ( find_con_name rdr , concatMap find_con_decl_flds (unLoc flds)) | L _ rdr <- rdrs ] diff --git a/compiler/GHC/Tc/TyCl.hs b/compiler/GHC/Tc/TyCl.hs index da07c4a01f..3983113554 100644 --- a/compiler/GHC/Tc/TyCl.hs +++ b/compiler/GHC/Tc/TyCl.hs @@ -1574,7 +1574,7 @@ kcTyClDecl (FamDecl _ (FamilyDecl { fdInfo = fd_info })) fam_tc ------------------- --- Type check the types of the arguments to a data constructor. +-- Kind-check the types of the arguments to a data constructor. -- This includes doing kind unification if the type is a newtype. -- See Note [Implementation of UnliftedNewtypes] for why we need -- the first two arguments. @@ -1587,6 +1587,21 @@ kcConArgTys new_or_data res_kind arg_tys = do -- See Note [Implementation of UnliftedNewtypes], STEP 2 } +-- Kind-check the types of arguments to a Haskell98 data constructor. +kcConH98Args :: NewOrData -> Kind -> HsConDeclH98Details GhcRn -> TcM () +kcConH98Args new_or_data res_kind con_args = case con_args of + PrefixCon tys -> kcConArgTys new_or_data res_kind tys + InfixCon ty1 ty2 -> kcConArgTys new_or_data res_kind [ty1, ty2] + RecCon (L _ flds) -> kcConArgTys new_or_data res_kind $ + map (hsLinear . cd_fld_type . unLoc) flds + +-- Kind-check the types of arguments to a GADT data constructor. +kcConGADTArgs :: NewOrData -> Kind -> HsConDeclGADTDetails GhcRn -> TcM () +kcConGADTArgs new_or_data res_kind con_args = case con_args of + PrefixConGADT tys -> kcConArgTys new_or_data res_kind tys + RecConGADT (L _ flds) -> kcConArgTys new_or_data res_kind $ + map (hsLinear . cd_fld_type . unLoc) flds + kcConDecls :: NewOrData -> Kind -- The result kind signature -> [LConDecl GhcRn] -- The data constructors @@ -1615,14 +1630,14 @@ kcConDecl new_or_data res_kind (ConDeclH98 discardResult $ bindExplicitTKBndrs_Tv ex_tvs $ do { _ <- tcHsMbContext ex_ctxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) + ; kcConH98Args new_or_data res_kind args -- We don't need to check the telescope here, -- because that's done in tcConDecl } kcConDecl new_or_data res_kind (ConDeclGADT { con_names = names, con_qvars = explicit_tkv_nms, con_mb_cxt = cxt - , con_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms }) + , con_g_args = args, con_res_ty = res_ty, con_g_ext = implicit_tkv_nms }) = -- Even though the GADT-style data constructor's type is closed, -- we must still kind-check the type, because that may influence -- the inferred kind of the /type/ constructor. Example: @@ -1636,7 +1651,7 @@ kcConDecl new_or_data res_kind (ConDeclGADT bindExplicitTKBndrs_Tv explicit_tkv_nms $ -- Why "_Tv"? See Note [Kind-checking for GADTs] do { _ <- tcHsMbContext cxt - ; kcConArgTys new_or_data res_kind (hsConDeclArgTys args) + ; kcConGADTArgs new_or_data res_kind args ; _ <- tcHsOpenType res_ty ; return () } @@ -3207,7 +3222,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs res_kind res_tmpl new_or_data bindExplicitTKBndrs_Skol explicit_tkv_nms $ do { ctxt <- tcHsMbContext hs_ctxt ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConArgs exp_kind hs_args + ; btys <- tcConH98Args exp_kind hs_args ; field_lbls <- lookupConstructorFields name ; let (arg_tys, stricts) = unzip btys ; return (ctxt, arg_tys, field_lbls, stricts) @@ -3277,7 +3292,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data (ConDeclGADT { con_g_ext = implicit_tkv_nms , con_names = names , con_qvars = explicit_tkv_nms - , con_mb_cxt = cxt, con_args = hs_args + , con_mb_cxt = cxt, con_g_args = hs_args , con_res_ty = hs_res_ty }) = addErrCtxt (dataConCtxtName names) $ do { traceTc "tcConDecl 1 gadt" (ppr names) @@ -3294,7 +3309,7 @@ tcConDecl rep_tycon tag_map tmpl_bndrs _res_kind res_tmpl new_or_data -- See Note [Datatype return kinds] ; let exp_kind = getArgExpKind new_or_data res_kind - ; btys <- tcConArgs exp_kind hs_args + ; btys <- tcConGADTArgs exp_kind hs_args ; let (arg_tys, stricts) = unzip btys ; field_lbls <- lookupConstructorFields name ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) @@ -3373,48 +3388,50 @@ getArgExpKind NewType res_ki = TheKind res_ki getArgExpKind DataType _ = OpenKind tcConIsInfixH98 :: Name - -> HsConDetails a b + -> HsConDeclH98Details GhcRn -> TcM Bool tcConIsInfixH98 _ details = case details of - InfixCon {} -> return True - _ -> return False + InfixCon{} -> return True + RecCon{} -> return False + PrefixCon{} -> return False tcConIsInfixGADT :: Name - -> HsConDetails (HsScaled GhcRn (LHsType GhcRn)) r + -> HsConDeclGADTDetails GhcRn -> TcM Bool tcConIsInfixGADT con details = case details of - InfixCon {} -> return True - RecCon {} -> return False - PrefixCon arg_tys -- See Note [Infix GADT constructors] + RecConGADT{} -> return False + PrefixConGADT arg_tys -- See Note [Infix GADT constructors] | isSymOcc (getOccName con) , [_ty1,_ty2] <- map hsScaledThing arg_tys -> do { fix_env <- getFixityEnv ; return (con `elemNameEnv` fix_env) } | otherwise -> return False -tcConArgs :: ContextKind -- expected kind of arguments - -- always OpenKind for datatypes, but unlifted newtypes - -- might have a specific kind - -> HsConDeclDetails GhcRn - -> TcM [(Scaled TcType, HsSrcBang)] -tcConArgs exp_kind (PrefixCon btys) +tcConH98Args :: ContextKind -- expected kind of arguments + -- always OpenKind for datatypes, but unlifted newtypes + -- might have a specific kind + -> HsConDeclH98Details GhcRn + -> TcM [(Scaled TcType, HsSrcBang)] +tcConH98Args exp_kind (PrefixCon btys) = mapM (tcConArg exp_kind) btys -tcConArgs exp_kind (InfixCon bty1 bty2) +tcConH98Args exp_kind (InfixCon bty1 bty2) = do { bty1' <- tcConArg exp_kind bty1 ; bty2' <- tcConArg exp_kind bty2 ; return [bty1', bty2'] } -tcConArgs exp_kind (RecCon fields) +tcConH98Args exp_kind (RecCon fields) + = tcRecConDeclFields exp_kind fields + +tcConGADTArgs :: ContextKind -- expected kind of arguments + -- always OpenKind for datatypes, but unlifted newtypes + -- might have a specific kind + -> HsConDeclGADTDetails GhcRn + -> TcM [(Scaled TcType, HsSrcBang)] +tcConGADTArgs exp_kind (PrefixConGADT btys) = mapM (tcConArg exp_kind) btys - where - -- We need a one-to-one mapping from field_names to btys - combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) - (unLoc fields) - explode (ns,ty) = zip ns (repeat ty) - exploded = concatMap explode combined - (_,btys) = unzip exploded - +tcConGADTArgs exp_kind (RecConGADT fields) + = tcRecConDeclFields exp_kind fields tcConArg :: ContextKind -- expected kind for args; always OpenKind for datatypes, -- but might be an unlifted type with UnliftedNewtypes @@ -3426,6 +3443,19 @@ tcConArg exp_kind (HsScaled w bty) ; traceTc "tcConArg 2" (ppr bty) ; return (Scaled w' arg_ty, getBangStrictness bty) } +tcRecConDeclFields :: ContextKind + -> Located [LConDeclField GhcRn] + -> TcM [(Scaled TcType, HsSrcBang)] +tcRecConDeclFields exp_kind fields + = mapM (tcConArg exp_kind) btys + where + -- We need a one-to-one mapping from field_names to btys + combined = map (\(L _ f) -> (cd_fld_names f,hsLinear (cd_fld_type f))) + (unLoc fields) + explode (ns,ty) = zip ns (repeat ty) + exploded = concatMap explode combined + (_,btys) = unzip exploded + tcDataConMult :: HsArrow GhcRn -> TcM Mult tcDataConMult arr@(HsUnrestrictedArrow _) = do -- See Note [Function arrows in GADT constructors] diff --git a/compiler/GHC/ThToHs.hs b/compiler/GHC/ThToHs.hs index 2ff30da251..0130989940 100644 --- a/compiler/GHC/ThToHs.hs +++ b/compiler/GHC/ThToHs.hs @@ -622,7 +622,7 @@ cvtConstr (GadtC c strtys ty) = do { c' <- mapM cNameL c ; args <- mapM cvt_arg strtys ; ty' <- cvtType ty - ; returnL $ mk_gadt_decl c' (PrefixCon $ map hsLinear args) ty'} + ; returnL $ mk_gadt_decl c' (PrefixConGADT $ map hsLinear args) ty'} cvtConstr (RecGadtC [] _varstrtys _ty) = failWith (text "RecGadtC must have at least one constructor name") @@ -631,9 +631,9 @@ cvtConstr (RecGadtC c varstrtys ty) = do { c' <- mapM cNameL c ; ty' <- cvtType ty ; rec_flds <- mapM cvt_id_arg varstrtys - ; returnL $ mk_gadt_decl c' (RecCon $ noLoc rec_flds) ty' } + ; returnL $ mk_gadt_decl c' (RecConGADT $ noLoc rec_flds) ty' } -mk_gadt_decl :: [Located RdrName] -> HsConDeclDetails GhcPs -> LHsType GhcPs +mk_gadt_decl :: [Located RdrName] -> HsConDeclGADTDetails GhcPs -> LHsType GhcPs -> ConDecl GhcPs mk_gadt_decl names args res_ty = ConDeclGADT { con_g_ext = noExtField @@ -641,7 +641,7 @@ mk_gadt_decl names args res_ty , con_forall = noLoc False , con_qvars = [] , con_mb_cxt = Nothing - , con_args = args + , con_g_args = args , con_res_ty = res_ty , con_doc = Nothing } diff --git a/docs/users_guide/9.2.1-notes.rst b/docs/users_guide/9.2.1-notes.rst index b691fc0537..aa495444db 100644 --- a/docs/users_guide/9.2.1-notes.rst +++ b/docs/users_guide/9.2.1-notes.rst @@ -43,14 +43,52 @@ Compiler - ``Void#`` is now a type synonym for the unboxed tuple ``(# #)``. Code using ``Void#`` now has to enable :extension:`UnboxedTuples`. +``ghc`` library +~~~~~~~~~~~~~ + +- The ``con_args`` field of ``ConDeclGADT`` has been renamed to ``con_g_args``. + This is because the type of ``con_g_args`` is now different from the type of + the ``con_args`` field in ``ConDeclH98``: :: + + data ConDecl pass + = ConDeclGADT + { ... + , con_g_args :: HsConDeclGADTDetails pass -- ^ Arguments; never infix + , ... + } + + | ConDeclH98 + { ... + , con_args :: HsConDeclH98Details pass -- ^ Arguments; can be infix + , ... + } + + Where: :: + + -- Introduced in GHC 9.2; was called `HsConDeclDetails` in previous versions of GHC + type HsConDeclH98Details pass + = HsConDetails (HsScaled pass (LBangType pass)) (XRec pass [LConDeclField pass]) + + -- Introduced in GHC 9.2 + data HsConDeclGADTDetails pass + = PrefixConGADT [HsScaled pass (LBangType pass)] + | RecConGADT (XRec pass [LConDeclField pass]) + + Unlike Haskell98-style constructors, GADT constructors cannot be declared + using infix syntax, which is why ``HsConDeclGADTDetails`` lacks an + ``InfixConGADT`` constructor. + + As a result of all this, the ``con_args`` field is now partial, so using + ``con_args`` as a top-level field selector is discouraged. + ``base`` library ~~~~~~~~~~~~~~~~ -- It's possible now to promote the ``Natural`` type: :: - +- It's possible now to promote the ``Natural`` type: :: + data Coordinate = Mk2D Natural Natural type MyCoordinate = Mk2D 1 10 - + The separate kind ``Nat`` is removed and now it is just a type synonym for ``Natural``. As a consequence, one must enable ``TypeSynonymInstances`` in order to define instances for ``Nat``. diff --git a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr index 9af02d8c66..2e5452129b 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544.stderr @@ -386,7 +386,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT []) ({ T17544.hs:25:13-18 } (HsAppTy @@ -522,7 +522,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT []) ({ T17544.hs:31:13-18 } (HsAppTy @@ -658,7 +658,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT []) ({ T17544.hs:37:13-18 } (HsAppTy @@ -794,7 +794,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT []) ({ T17544.hs:43:13-18 } (HsAppTy @@ -930,7 +930,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT []) ({ T17544.hs:49:13-18 } (HsAppTy @@ -1066,7 +1066,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT []) ({ T17544.hs:55:14-20 } (HsAppTy 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 ccba2caf27..d1ff09f56c 100644 --- a/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr +++ b/testsuite/tests/haddock/should_compile_flag_haddock/T17544_kw.stderr @@ -39,7 +39,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT []) ({ T17544_kw.hs:16:18-20 } (HsTyVar @@ -83,7 +83,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT [(HsScaled (HsUnrestrictedArrow (NormalSyntax)) diff --git a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr index 599d369ff5..e869299a76 100644 --- a/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr +++ b/testsuite/tests/parser/should_compile/DumpRenamedAst.stderr @@ -374,7 +374,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT [(HsScaled (HsUnrestrictedArrow (NormalSyntax)) diff --git a/testsuite/tests/parser/should_compile/T15323.stderr b/testsuite/tests/parser/should_compile/T15323.stderr index 0e2734dd48..8539599660 100644 --- a/testsuite/tests/parser/should_compile/T15323.stderr +++ b/testsuite/tests/parser/should_compile/T15323.stderr @@ -72,7 +72,7 @@ ({ T15323.hs:6:35 } (Unqual {OccName: v}))))))))])) - (PrefixCon + (PrefixConGADT []) ({ T15323.hs:6:41-54 } (HsAppTy diff --git a/testsuite/tests/printer/T18791.stderr b/testsuite/tests/printer/T18791.stderr index 09aee04678..e245ef0fbe 100644 --- a/testsuite/tests/printer/T18791.stderr +++ b/testsuite/tests/printer/T18791.stderr @@ -39,7 +39,7 @@ (False)) [] (Nothing) - (PrefixCon + (PrefixConGADT [(HsScaled (HsUnrestrictedArrow (NormalSyntax)) @@ -61,4 +61,6 @@ ({ <no location info> } [])))))] (Nothing) - (Nothing)))
\ No newline at end of file + (Nothing))) + + diff --git a/utils/haddock b/utils/haddock -Subproject 87a9f86d1ad7de67ff011311905ecf76578b26e +Subproject 3cce1bdee8c61bb6daa089059e12435178f5077 |