diff options
Diffstat (limited to 'compiler/rename')
| -rw-r--r-- | compiler/rename/RnEnv.hs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnNames.hs | 13 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 120 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.hs | 22 |
4 files changed, 72 insertions, 87 deletions
diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index 57b427b0de..42a159f3d4 100644 --- a/compiler/rename/RnEnv.hs +++ b/compiler/rename/RnEnv.hs @@ -2123,6 +2123,8 @@ checkTupSize tup_size ************************************************************************ -} +-- AZ:TODO: Change these all to be Name instead of RdrName. +-- Merge TcType.UserTypeContext in to it. data HsDocContext = TypeSigCtx SDoc | PatCtx @@ -2135,7 +2137,7 @@ data HsDocContext | TySynCtx (Located RdrName) | TyFamilyCtx (Located RdrName) | FamPatCtx (Located RdrName) -- The patterns of a type/data family instance - | ConDeclCtx [Located RdrName] + | ConDeclCtx [Located Name] | ClassDeclCtx (Located RdrName) | ExprWithTySigCtx | TypBrCtx diff --git a/compiler/rename/RnNames.hs b/compiler/rename/RnNames.hs index 3ee1e695a4..81ae70b05a 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -610,11 +610,22 @@ getLocalNonValBinders fixity_env mk_fld_env :: HsDataDefn RdrName -> [Name] -> [FieldLabel] -> [(Name, [FieldLabel])] mk_fld_env d names flds = concatMap find_con_flds (dd_cons d) where - find_con_flds (L _ (ConDecl { con_names = rdrs + find_con_flds (L _ (ConDeclH98 { con_name = rdrs , con_details = RecCon cdflds })) = map (\ (L _ rdr) -> ( find_con_name rdr , concatMap find_con_decl_flds (unLoc cdflds))) + [rdrs] -- AZ:TODO remove map + find_con_flds (L _ (ConDeclGADT + { con_names = rdrs + , con_type = (HsIB { hsib_body = res_ty})})) + = map (\ (L _ rdr) -> ( find_con_name rdr + , concatMap find_con_decl_flds cdflds)) rdrs + where + (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + cdflds = case tau of + L _ (HsFunTy (L _ (HsRecTy flds)) _) -> flds + _ -> [] find_con_flds _ = [] find_con_name rdr diff --git a/compiler/rename/RnSource.hs b/compiler/rename/RnSource.hs index 6d32ddc268..1579400fc2 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -1308,8 +1308,8 @@ rnDataDefn doc (HsDataDefn { dd_ND = new_or_data, dd_cType = cType } where h98_style = case condecls of -- Note [Stupid theta] - L _ (ConDecl { con_res = ResTyGADT {} }) : _ -> False - _ -> True + L _ (ConDeclGADT {}) : _ -> False + _ -> True rn_derivs Nothing = return (Nothing, emptyFVs) @@ -1520,7 +1520,7 @@ depAnalTyClDecls ds_w_fvs DataDecl { tcdLName = L _ data_name , tcdDataDefn = HsDataDefn { dd_cons = cons } } -> do L _ dc <- cons - return $ zip (map unLoc $ con_names dc) (repeat data_name) + return $ zip (map unLoc $ getConNames dc) (repeat data_name) _ -> [] {- @@ -1572,29 +1572,6 @@ modules), we get better error messages, too. \subsection{Support code for type/data declarations} * * ********************************************************* - -Note [Quantification in data constructor declarations] -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ -Four cases, afer renaming - * ResTyH98 - - data T a = forall b. MkT { x :: b -> a } - The 'b' is explicitly declared; - con_qvars = [b] - - - data T a = MkT { x :: a -> b } - Do *not* implicitly quantify over 'b'; it is - simply out of scope. con_qvars = [] - - * ResTyGADT - - data T a where { MkT :: forall b. (b -> a) -> T a } - con_qvars = [a,b] - - - data T a where { MkT :: (b -> a) -> T a } - con_qvars = [a,b], by implicit quantification - of the type signature - It is uncomfortable that we add implicitly-bound - type variables to the HsQTyVars, which usually - only has explicitly-bound type variables -} --------------- @@ -1609,75 +1586,61 @@ rnConDecls :: [LConDecl RdrName] -> RnM ([LConDecl Name], FreeVars) rnConDecls = mapFvRn (wrapLocFstM rnConDecl) rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name, FreeVars) -rnConDecl decl@(ConDecl { con_names = names, con_qvars = qtvs - , con_cxt = lcxt@(L loc cxt), con_details = details - , con_res = res_ty, con_doc = mb_doc - , con_explicit = explicit }) - = do { mapM_ (addLocM checkConName) names - ; new_names <- mapM lookupLocatedTopBndrRn names +rnConDecl decl@(ConDeclH98 { con_name = name, con_qvars = qtvs + , con_cxt = mcxt, con_details = details + , con_doc = mb_doc }) + = do { _ <- addLocM checkConName name + ; new_name <- lookupLocatedTopBndrRn name + ; let doc = ConDeclCtx [new_name] ; mb_doc' <- rnMbLHsDoc mb_doc - ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) res_ty + ; let (kvs, qtvs') = get_con_qtvs qtvs (hsConDeclArgTys details) ; bindHsQTyVars doc Nothing kvs qtvs' $ \new_tyvars -> do - { (new_context, fvs1) <- rnContext doc lcxt - ; (new_details, fvs2) <- rnConDeclDetails (unLoc $ head new_names) doc details - ; (new_details', new_res_ty, fvs3) - <- rnConResult doc (map unLoc new_names) new_details res_ty - ; traceRn (text "rnConDecl" <+> ppr names <+> vcat + { (new_context, fvs1) <- case mcxt of + Nothing -> return (Nothing,emptyFVs) + Just lcxt -> do { (lctx',fvs) <- rnContext doc lcxt + ; return (Just lctx',fvs) } + ; (new_details, fvs2) <- rnConDeclDetails (unLoc new_name) doc details + ; let (new_details',fvs3) = (new_details,emptyFVs) + ; traceRn (text "rnConDecl" <+> ppr name <+> vcat [ text "free_kvs:" <+> ppr kvs , text "qtvs:" <+> ppr qtvs , text "qtvs':" <+> ppr qtvs' ]) ; let all_fvs = fvs1 `plusFV` fvs2 `plusFV` fvs3 ; warnUnusedForAlls (inHsDocContext doc) (hsQTvBndrs new_tyvars) all_fvs - ; return (decl { con_names = new_names, con_qvars = new_tyvars + ; let new_tyvars' = case qtvs of + Nothing -> Nothing + Just _ -> Just new_tyvars + ; return (decl { con_name = new_name, con_qvars = new_tyvars' , con_cxt = new_context, con_details = new_details' - , con_res = new_res_ty, con_doc = mb_doc' }, + , con_doc = mb_doc' }, all_fvs) }} where - doc = ConDeclCtx names + cxt = maybe [] unLoc mcxt get_rdr_tvs tys = extractHsTysRdrTyVars (cxt ++ tys) - get_con_qtvs :: LHsQTyVars RdrName -> [LHsType RdrName] - -> ResType (LHsType RdrName) + get_con_qtvs :: Maybe (LHsQTyVars RdrName) -> [LHsType RdrName] -> ([RdrName], LHsQTyVars RdrName) - get_con_qtvs qtvs arg_tys ResTyH98 - | explicit -- data T = forall a. MkT (a -> a) - = (free_kvs, qtvs) - | otherwise -- data T = MkT (a -> a) + get_con_qtvs Nothing _arg_tys = ([], mkHsQTvs []) + get_con_qtvs (Just qtvs) arg_tys + = (free_kvs, qtvs) where (free_kvs, _) = get_rdr_tvs arg_tys - get_con_qtvs qtvs arg_tys (ResTyGADT _ ty) - | explicit -- data T x where { MkT :: forall a. a -> T a } - = (free_kvs, qtvs) - | otherwise -- data T x where { MkT :: a -> T a } - = (free_kvs, mkHsQTvs (userHsTyVarBndrs loc free_tvs)) - where - (free_kvs, free_tvs) = get_rdr_tvs (ty : arg_tys) - -rnConResult :: HsDocContext -> [Name] - -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) - -> ResType (LHsType RdrName) - -> RnM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), - ResType (LHsType Name), FreeVars) -rnConResult _ _ details ResTyH98 = return (details, ResTyH98, emptyFVs) -rnConResult doc _con details (ResTyGADT ls ty) - = do { (ty', fvs) <- rnLHsType doc ty - ; let (arg_tys, res_ty) = splitHsFunType ty' - -- We can finally split it up, - -- now the renamer has dealt with fixities - -- See Note [Sorting out the result type] in RdrHsSyn - - ; case details of - InfixCon {} -> pprPanic "rnConResult" (ppr ty) - -- See Note [Sorting out the result type] in RdrHsSyn - - RecCon {} -> do { unless (null arg_tys) - (addErr (badRecResTy doc)) - ; return (details, ResTyGADT ls res_ty, fvs) } - - PrefixCon {} -> return (PrefixCon arg_tys, ResTyGADT ls res_ty, fvs)} +rnConDecl decl@(ConDeclGADT { con_names = names, con_type = ty + , con_doc = mb_doc }) + = do { mapM_ (addLocM checkConName) names + ; new_names <- mapM lookupLocatedTopBndrRn names + ; let doc = ConDeclCtx new_names + ; mb_doc' <- rnMbLHsDoc mb_doc + + ; (ty', fvs) <- rnHsSigType doc ty + ; traceRn (text "rnConDecl" <+> ppr names <+> vcat + [ text "fvs:" <+> ppr fvs ]) + ; return (decl { con_names = new_names, con_type = ty' + , con_doc = mb_doc' }, + fvs) } rnConDeclDetails :: Name @@ -1701,9 +1664,6 @@ rnConDeclDetails con doc (RecCon (L l fields)) ; return (RecCon (L l new_fields), fvs) } ------------------------------------------------- -badRecResTy :: HsDocContext -> SDoc -badRecResTy ctxt = withHsDocContext ctxt $ - ptext (sLit "Malformed constructor signature") -- | Brings pattern synonym names and also pattern synonym selectors -- from record pattern synonyms into scope. diff --git a/compiler/rename/RnTypes.hs b/compiler/rename/RnTypes.hs index 49b707c370..b716ee0721 100644 --- a/compiler/rename/RnTypes.hs +++ b/compiler/rename/RnTypes.hs @@ -363,6 +363,14 @@ rnHsTyKi _ doc (HsBangTy b ty) = do { (ty', fvs) <- rnLHsType doc ty ; return (HsBangTy b ty', fvs) } +rnHsTyKi _ doc@(ConDeclCtx names) (HsRecTy flds) + = do { + -- AZ:reviewers: is there a monadic version of concatMap? + flss <- mapM (lookupConstructorFields . unLoc) names + ; let fls = concat flss + ; (flds', fvs) <- rnConDeclFields fls doc flds + ; return (HsRecTy flds', fvs) } + rnHsTyKi _ doc ty@(HsRecTy flds) = do { addErr (hang (ptext (sLit "Record syntax is illegal here:")) 2 (ppr ty)) @@ -1200,14 +1208,18 @@ extractDataDefnKindVars (HsDataDefn { dd_ctxt = ctxt, dd_kindSig = ksig extract_mb (extract_sig_tys . unLoc) derivs $ foldr (extract_con . unLoc) ([],[]) cons where - extract_con (ConDecl { con_res = ResTyGADT {} }) acc = acc - extract_con (ConDecl { con_res = ResTyH98, con_qvars = qvs - , con_cxt = ctxt, con_details = details }) acc - = extract_hs_tv_bndrs (hsQTvBndrs qvs) acc $ - extract_lctxt ctxt $ + extract_con (ConDeclGADT { }) acc = acc + extract_con (ConDeclH98 { con_qvars = qvs + , con_cxt = ctxt, con_details = details }) acc + = extract_hs_tv_bndrs (maybe [] hsQTvBndrs qvs) acc $ + extract_mlctxt ctxt $ extract_ltys (hsConDeclArgTys details) ([],[]) +extract_mlctxt :: Maybe (LHsContext RdrName) -> FreeKiTyVars -> FreeKiTyVars +extract_mlctxt Nothing = mempty +extract_mlctxt (Just ctxt) = extract_lctxt ctxt + extract_lctxt :: LHsContext RdrName -> FreeKiTyVars -> FreeKiTyVars extract_lctxt ctxt = extract_ltys (unLoc ctxt) |