summaryrefslogtreecommitdiff
path: root/compiler/GHC/Rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/GHC/Rename')
-rw-r--r--compiler/GHC/Rename/HsType.hs29
-rw-r--r--compiler/GHC/Rename/Module.hs66
-rw-r--r--compiler/GHC/Rename/Names.hs2
-rw-r--r--compiler/GHC/Rename/Utils.hs2
4 files changed, 60 insertions, 39 deletions
diff --git a/compiler/GHC/Rename/HsType.hs b/compiler/GHC/Rename/HsType.hs
index bbcd5244af..5d1da01b37 100644
--- a/compiler/GHC/Rename/HsType.hs
+++ b/compiler/GHC/Rename/HsType.hs
@@ -35,7 +35,7 @@ module GHC.Rename.HsType (
FreeKiTyVars, filterInScopeM,
extractHsTyRdrTyVars, extractHsTyRdrTyVarsKindVars,
extractHsTysRdrTyVars, extractRdrKindSigVars,
- extractConDeclGADTDetailsTyVars, extractDataDefnKindVars,
+ extractConGadtSigBodyTyVars, extractDataDefnKindVars,
extractHsOuterTvBndrs, extractHsTyArgRdrKiTyVars,
nubL, nubN
) where
@@ -1903,14 +1903,21 @@ 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
+-- | Extracts free type and kind variables from the argument and result types
+-- in a GADT constructor, returning variable occurrences in left-to-right
+-- order. See @Note [Ordering of implicit variables]@.
+extractConGadtSigBodyTyVars :: ConGadtSigBody GhcPs -> FreeKiTyVars
+extractConGadtSigBodyTyVars body = case body of
+ PrefixConGADT body' -> extract_prefix_con_gadt_sig_body body'
+ RecConGADT (L _ flds) _ res -> extract_ltys (map (cd_fld_type . unLoc) flds) $
+ extractHsTyRdrTyVars res
+
+extract_prefix_con_gadt_sig_body :: PrefixConGadtSigBody GhcPs -> FreeKiTyVars
+extract_prefix_con_gadt_sig_body prefix_body = go prefix_body []
+ where
+ go :: PrefixConGadtSigBody GhcPs -> FreeKiTyVars -> FreeKiTyVars
+ go (PCGSRes res_ty) acc = extract_lty res_ty acc
+ go (PCGSAnonArg arg body) acc = extract_scaled_lty arg (go body acc)
-- | Get type/kind variables mentioned in the kind signature, preserving
-- left-to-right order:
@@ -1926,10 +1933,6 @@ 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
diff --git a/compiler/GHC/Rename/Module.hs b/compiler/GHC/Rename/Module.hs
index 29937ea5f0..6b152bcb57 100644
--- a/compiler/GHC/Rename/Module.hs
+++ b/compiler/GHC/Rename/Module.hs
@@ -2352,8 +2352,7 @@ rnConDecl decl@(ConDeclH98 { con_name = name, con_ex_tvs = ex_tvs
rnConDecl (ConDeclGADT { con_names = names
, con_bndrs = L l outer_bndrs
, con_mb_cxt = mcxt
- , con_g_args = args
- , con_res_ty = res_ty
+ , con_body = body
, con_doc = mb_doc })
= do { mapM_ (addLocMA checkConName) names
; new_names <- mapM (lookupLocatedTopConstructorRnN) names
@@ -2366,31 +2365,22 @@ rnConDecl (ConDeclGADT { con_names = names
implicit_bndrs =
extractHsOuterTvBndrs outer_bndrs $
extractHsTysRdrTyVars (hsConDeclTheta mcxt) $
- extractConDeclGADTDetailsTyVars args $
- extractHsTysRdrTyVars [res_ty] []
+ extractConGadtSigBodyTyVars body
; let ctxt = ConDeclCtx new_names
; bindHsOuterTyVarBndrs ctxt Nothing implicit_bndrs outer_bndrs $ \outer_bndrs' ->
do { (new_cxt, fvs1) <- rnMbContext ctxt mcxt
- ; (new_args, fvs2) <- rnConDeclGADTDetails (unLoc (head new_names)) ctxt args
- ; (new_res_ty, fvs3) <- rnLHsType ctxt res_ty
+ ; (new_body, fvs2) <- rnConGadtSigBody (unLoc (head new_names)) ctxt body
- -- Ensure that there are no nested `forall`s or contexts, per
- -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)
- -- in GHC.Hs.Type.
- ; addNoNestedForallsContextsErr ctxt
- (text "GADT constructor type signature") new_res_ty
-
- ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3
+ ; let all_fvs = fvs1 `plusFV` fvs2
; traceRn "rnConDecl (ConDeclGADT)"
(ppr names $$ ppr outer_bndrs')
; new_mb_doc <- traverse rnLHsDoc mb_doc
; return (ConDeclGADT { con_g_ext = noAnn, con_names = new_names
, con_bndrs = L l outer_bndrs', con_mb_cxt = new_cxt
- , con_g_args = new_args, con_res_ty = new_res_ty
- , con_doc = new_mb_doc },
+ , con_body = new_body, con_doc = new_mb_doc },
all_fvs) } }
rnMbContext :: HsDocContext -> Maybe (LHsContext GhcPs)
@@ -2415,17 +2405,32 @@ rnConDeclH98Details con doc (RecCon flds)
= do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
; return (RecCon new_flds, fvs) }
-rnConDeclGADTDetails ::
+rnConGadtSigBody ::
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 arr)
- = do { (new_flds, fvs) <- rnRecConDeclFields con doc flds
- ; return (RecConGADT new_flds arr, fvs) }
+ -> ConGadtSigBody GhcPs
+ -> RnM (ConGadtSigBody GhcRn, FreeVars)
+rnConGadtSigBody _ doc (PrefixConGADT body)
+ = do { (new_body, fvs) <- rnPrefixConGadtSigBody doc body
+ ; return (PrefixConGADT new_body, fvs) }
+rnConGadtSigBody con doc (RecConGADT flds arr res_ty)
+ = do { (new_flds, fvs1) <- rnRecConDeclFields con doc flds
+ ; (new_res_ty, fvs2) <- rnGADTResultTy doc res_ty
+ ; return (RecConGADT new_flds arr new_res_ty, fvs1 `plusFV` fvs2) }
+
+rnPrefixConGadtSigBody ::
+ HsDocContext
+ -> PrefixConGadtSigBody GhcPs
+ -> RnM (PrefixConGadtSigBody GhcRn, FreeVars)
+rnPrefixConGadtSigBody doc = go
+ where
+ go (PCGSRes res_ty) = do
+ (new_res_ty, fvs) <- rnGADTResultTy doc res_ty
+ pure (PCGSRes new_res_ty, fvs)
+ go (PCGSAnonArg arg_ty body) = do
+ (new_arg_ty, fvs1) <- rnScaledLHsType doc arg_ty
+ (new_body, fvs2) <- go body
+ pure (PCGSAnonArg new_arg_ty new_body, fvs1 `plusFV` fvs2)
rnRecConDeclFields ::
Name
@@ -2439,6 +2444,19 @@ rnRecConDeclFields con doc (L l fields)
-- since that is done by GHC.Rename.Names.extendGlobalRdrEnvRn
; pure (L l new_fields, fvs) }
+rnGADTResultTy ::
+ HsDocContext
+ -> LHsType GhcPs
+ -> RnM (LHsType GhcRn, FreeVars)
+rnGADTResultTy doc res_ty
+ = do { (new_res_ty, fvs) <- rnLHsType doc res_ty
+ -- Ensure that there are no nested `forall`s or contexts, per
+ -- Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)
+ -- in Language.Haskell.Syntax.Decls.
+ ; addNoNestedForallsContextsErr doc
+ (text "GADT constructor type signature") new_res_ty
+ ; pure (new_res_ty, fvs) }
+
-------------------------------------------------
-- | Brings pattern synonym names and also pattern synonym selectors
diff --git a/compiler/GHC/Rename/Names.hs b/compiler/GHC/Rename/Names.hs
index 3a4cb78820..7b473a532e 100644
--- a/compiler/GHC/Rename/Names.hs
+++ b/compiler/GHC/Rename/Names.hs
@@ -978,7 +978,7 @@ getLocalNonValBinders fixity_env
= [( find_con_name rdr
, concatMap find_con_decl_flds (unLoc cdflds) )]
find_con_flds (L _ (ConDeclGADT { con_names = rdrs
- , con_g_args = RecConGADT flds _ }))
+ , con_body = RecConGADT flds _ _ }))
= [ ( find_con_name rdr
, concatMap find_con_decl_flds (unLoc flds))
| L _ rdr <- rdrs ]
diff --git a/compiler/GHC/Rename/Utils.hs b/compiler/GHC/Rename/Utils.hs
index 597af3d778..796853ae82 100644
--- a/compiler/GHC/Rename/Utils.hs
+++ b/compiler/GHC/Rename/Utils.hs
@@ -278,7 +278,7 @@ Note [No nested foralls or contexts in instance types] in GHC.Hs.Type).
--
-- * In GADT constructor types (in 'rnConDecl').
-- See @Note [GADT abstract syntax] (Wrinkle: No nested foralls or contexts)@
--- in "GHC.Hs.Type".
+-- in "Language.Haskell.Syntax.Decls".
--
-- * In instance declaration types (in 'rnClsIntDecl' and 'rnSrcDerivDecl' in
-- "GHC.Rename.Module" and 'renameSig' in "GHC.Rename.Bind").
View Lorry Controller Status