diff options
| -rw-r--r-- | compiler/deSugar/DsMeta.hs | 89 | ||||
| -rw-r--r-- | compiler/hsSyn/Convert.hs | 17 | ||||
| -rw-r--r-- | compiler/hsSyn/HsDecls.hs | 133 | ||||
| -rw-r--r-- | compiler/hsSyn/HsTypes.hs | 4 | ||||
| -rw-r--r-- | compiler/hsSyn/HsUtils.hs | 19 | ||||
| -rw-r--r-- | compiler/parser/Parser.y | 12 | ||||
| -rw-r--r-- | compiler/parser/RdrHsSyn.hs | 72 | ||||
| -rw-r--r-- | compiler/rename/RnEnv.hs | 4 | ||||
| -rw-r--r-- | compiler/rename/RnNames.hs | 11 | ||||
| -rw-r--r-- | compiler/rename/RnSource.hs | 120 | ||||
| -rw-r--r-- | compiler/rename/RnTypes.hs | 22 | ||||
| -rw-r--r-- | compiler/typecheck/TcHsType.hs | 9 | ||||
| -rw-r--r-- | compiler/typecheck/TcRnDriver.hs | 2 | ||||
| -rw-r--r-- | compiler/typecheck/TcTyClsDecls.hs | 191 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/annotations/T10399.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/annotations/all.T | 2 | ||||
| -rw-r--r-- | testsuite/tests/ghc-api/landmines/landmines.stdout | 2 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_compile/T5331.stderr | 2 | ||||
| -rw-r--r-- | testsuite/tests/rename/should_fail/T7943.stderr | 6 | ||||
| m--------- | utils/haddock | 0 |
20 files changed, 390 insertions, 329 deletions
diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs index 8d701af329..48c412659a 100644 --- a/compiler/deSugar/DsMeta.hs +++ b/compiler/deSugar/DsMeta.hs @@ -58,6 +58,7 @@ import ForeignCall import Util import Maybes import MonadUtils +import RdrHsSyn ( gadtDeclDetails ) import Data.ByteString ( unpack ) import Control.Monad @@ -302,7 +303,7 @@ repDataDefn tc bndrs opt_tys tv_names _cs -> failWithDs (ptext (sLit "Multiple constructors for newtype:") <+> pprQuotedList - (con_names $ unLoc $ head cons)) + (getConNames $ unLoc $ head cons)) } DataType -> do { consL <- concatMapM (repC tv_names) cons ; cons1 <- coreList conQTyConName consL @@ -623,26 +624,48 @@ repAnnProv ModuleAnnProvenance ------------------------------------------------------- repC :: [Name] -> LConDecl Name -> DsM [Core TH.ConQ] -repC _ (L _ (ConDecl { con_names = con, con_qvars = con_tvs, con_cxt = L _ [] - , con_details = details, con_res = ResTyH98 })) - | null (hsQTvBndrs con_tvs) - = do { con1 <- mapM lookupLOcc con -- See Note [Binders and occurrences] +repC _ (L _ (ConDeclH98 { con_name = con + , con_qvars = Nothing, con_cxt = Nothing + , con_details = details })) + = do { con1 <- mapM lookupLOcc [con] -- See Note [Binders and occurrences] ; mapM (\c -> repConstr c details) con1 } -repC tvs (L _ (ConDecl { con_names = cons - , con_qvars = con_tvs, con_cxt = L _ ctxt - , con_details = details - , con_res = res_ty })) - = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty +repC _ (L _ (ConDeclH98 { con_name = con + , con_qvars = mcon_tvs, con_cxt = mcxt + , con_details = details })) + = do { let (eq_ctxt, con_tv_subst) = ([], []) + ; let con_tvs = fromMaybe (HsQTvs [] []) mcon_tvs + ; let ctxt = unLoc $ fromMaybe (noLoc []) mcxt ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) (hsq_kvs con_tvs) , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) (hsq_tvs con_tvs) } - ; binds <- mapM dupBinder con_tv_subst + ; let binds = [] ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs - do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences] - ; c' <- mapM (\c -> repConstr c details) cons1 + do { con1 <- lookupLOcc con -- See Note [Binders and occurrences] + ; c' <- repConstr con1 details ; ctxt' <- repContext (eq_ctxt ++ ctxt) + ; if (null (hsq_kvs ex_tvs) && null (hsq_tvs ex_tvs) && null (eq_ctxt ++ ctxt)) + then return c' + else rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ [unC c']) } + ; return [b] + } +repC tvs (L _ (ConDeclGADT { con_names = cons + , con_type = res_ty@(HsIB { hsib_kvs = con_kvs, hsib_tvs = con_tvns }) })) + = do { (eq_ctxt, con_tv_subst) <- mkGadtCtxt tvs res_ty + ; let con_tvs = map (noLoc . UserTyVar . noLoc) con_tvns + ; let ex_tvs = HsQTvs { hsq_kvs = filterOut (in_subst con_tv_subst) con_kvs + , hsq_tvs = filterOut (in_subst con_tv_subst . hsLTyVarName) con_tvs } + + ; binds <- mapM dupBinder con_tv_subst + ; b <- dsExtendMetaEnv (mkNameEnv binds) $ -- Binds some of the con_tvs + addTyVarBinds ex_tvs $ \ ex_bndrs -> -- Binds the remaining con_tvs + do { cons1 <- mapM lookupLOcc cons -- See Note [Binders and occurrences] + ; let (details,res_ty',_,_) = gadtDeclDetails res_ty + ; let doc = ptext (sLit "In the constructor for ") <+> ppr (head cons) + ; (hs_details,_res_ty) <- update_con_result doc details res_ty' + ; c' <- mapM (\c -> repConstr c hs_details) cons1 + ; ctxt' <- repContext eq_ctxt ; rep2 forallCName ([unC ex_bndrs, unC ctxt'] ++ (map unC c')) } ; return [b] } @@ -651,8 +674,37 @@ in_subst :: [(Name,Name)] -> Name -> Bool in_subst [] _ = False in_subst ((n',_):ns) n = n==n' || in_subst ns n +update_con_result :: SDoc + -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -- Original details + -> LHsType Name -- The original result type + -> DsM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), + LHsType Name) +update_con_result doc details ty + = do { 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 "update_con_result" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn + + RecCon {} -> do { unless (null arg_tys) + (failWithDs (badRecResTy doc)) + -- AZ: This error used to be reported during + -- renaming, will now be reported in type + -- checking. Is this a problem? + ; return (details, res_ty) } + + PrefixCon {} -> return (PrefixCon arg_tys, res_ty)} + where + badRecResTy :: SDoc -> SDoc + badRecResTy ctxt = ctxt <+> + ptext (sLit "Malformed constructor signature") + mkGadtCtxt :: [Name] -- Tyvars of the data type - -> ResType (LHsType Name) + -> LHsSigType Name -> DsM (HsContext Name, [(Name,Name)]) -- Given a data type in GADT syntax, figure out the equality -- context, so that we can represent it with an explicit @@ -666,16 +718,16 @@ mkGadtCtxt :: [Name] -- Tyvars of the data type -- (b~[e], c~e), [d->a] -- -- This function is fiddly, but not really hard -mkGadtCtxt _ ResTyH98 - = return ([], []) -mkGadtCtxt data_tvs (ResTyGADT _ res_ty) - | Just (_, tys) <- hsTyGetAppHead_maybe res_ty +mkGadtCtxt data_tvs res_ty + | Just (_, tys) <- hsTyGetAppHead_maybe ty , data_tvs `equalLength` tys = return (go [] [] (data_tvs `zip` tys)) | otherwise = failWithDs (ptext (sLit "Malformed constructor result type:") <+> ppr res_ty) where + (_,ty',_,_) = gadtDeclDetails res_ty + (_arg_tys,ty) = splitHsFunType ty' go cxt subst [] = (cxt, subst) go cxt subst ((data_tv, ty) : rest) | Just con_tv <- is_hs_tyvar ty @@ -692,7 +744,6 @@ mkGadtCtxt data_tvs (ResTyGADT _ res_ty) is_hs_tyvar (L _ (HsParTy ty)) = is_hs_tyvar ty is_hs_tyvar _ = Nothing - repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) repBangTy ty = do MkC s <- rep2 str [] diff --git a/compiler/hsSyn/Convert.hs b/compiler/hsSyn/Convert.hs index 1fc4f09ad9..ec13c4e216 100644 --- a/compiler/hsSyn/Convert.hs +++ b/compiler/hsSyn/Convert.hs @@ -45,7 +45,7 @@ import Control.Applicative (Applicative(..)) import Data.Char ( chr ) import Data.Word ( Word8 ) -import Data.Maybe( catMaybes ) +import Data.Maybe( catMaybes, fromMaybe ) import Language.Haskell.TH as TH hiding (sigP) import Language.Haskell.TH.Syntax as TH @@ -423,13 +423,13 @@ cvtConstr (NormalC c strtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; tys' <- mapM cvt_arg strtys - ; returnL $ mkSimpleConDecl c' Nothing cxt' (PrefixCon tys') } + ; returnL $ mkConDeclH98 c' Nothing cxt' (PrefixCon tys') } cvtConstr (RecC c varstrtys) = do { c' <- cNameL c ; cxt' <- returnL [] ; args' <- mapM cvt_id_arg varstrtys - ; returnL $ mkSimpleConDecl c' Nothing cxt' + ; returnL $ mkConDeclH98 c' Nothing cxt' (RecCon (noLoc args')) } cvtConstr (InfixC st1 c st2) @@ -437,15 +437,18 @@ cvtConstr (InfixC st1 c st2) ; cxt' <- returnL [] ; st1' <- cvt_arg st1 ; st2' <- cvt_arg st2 - ; returnL $ mkSimpleConDecl c' Nothing cxt' (InfixCon st1' st2') } + ; returnL $ mkConDeclH98 c' Nothing cxt' (InfixCon st1' st2') } cvtConstr (ForallC tvs ctxt con) = do { tvs' <- cvtTvs tvs ; L loc ctxt' <- cvtContext ctxt ; L _ con' <- cvtConstr con - ; returnL $ con' { con_qvars = mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (con_qvars con')) - , con_explicit = True - , con_cxt = L loc (ctxt' ++ (unLoc $ con_cxt con')) } } + ; let qvars = case (tvs,con_qvars con') of + ([],Nothing) -> Nothing + _ -> + Just $ mkHsQTvs (hsQTvBndrs tvs' ++ hsQTvBndrs (fromMaybe (HsQTvs PlaceHolder []) (con_qvars con'))) + ; returnL $ con' { con_qvars = qvars + , con_cxt = Just $ L loc (ctxt' ++ unLoc (fromMaybe (noLoc []) (con_cxt con'))) } } cvt_arg :: (TH.Strict, TH.Type) -> CvtM (LHsType RdrName) cvt_arg (NotStrict, ty) = cvtType ty diff --git a/compiler/hsSyn/HsDecls.hs b/compiler/hsSyn/HsDecls.hs index b8612ed2be..981a59f95f 100644 --- a/compiler/hsSyn/HsDecls.hs +++ b/compiler/hsSyn/HsDecls.hs @@ -60,8 +60,9 @@ module HsDecls ( noForeignImportCoercionYet, noForeignExportCoercionYet, CImportSpec(..), -- ** Data-constructor declarations - ConDecl(..), LConDecl, ResType(..), + ConDecl(..), LConDecl, HsConDeclDetails, hsConDeclArgTys, + getConNames, -- ** Document comments DocDecl(..), LDocDecl, docDeclDoc, -- ** Deprecations @@ -106,6 +107,7 @@ import SrcLoc import FastString import Bag +import Data.Maybe ( fromMaybe ) import Data.Data hiding (TyCon,Fixity) #if __GLASGOW_HASKELL__ < 709 import Data.Foldable ( Foldable ) @@ -956,9 +958,9 @@ data HsDataDefn name -- The payload of a data type defn -- ^ Data constructors -- -- For @data T a = T1 | T2 a@ - -- the 'LConDecl's all have 'ResTyH98'. + -- the 'LConDecl's all have 'ConDeclH98'. -- For @data T a where { T1 :: T a }@ - -- the 'LConDecls' all have 'ResTyGADT'. + -- the 'LConDecls' all have 'ConDeclGADT'. dd_derivs :: HsDeriving name -- ^ Optional 'deriving' claues @@ -1020,71 +1022,47 @@ type LConDecl name = Located (ConDecl name) -- For details on above see note [Api annotations] in ApiAnnotation data ConDecl name - = ConDecl - { con_names :: [Located name] - -- ^ Constructor names. This is used for the DataCon itself, and for - -- the user-callable wrapper Id. - -- It is a list to deal with GADT constructors of the form - -- T1, T2, T3 :: <payload> - - , con_explicit :: Bool - -- ^ Is there an user-written forall? - -- For ResTyH98, "explicit" means something like: - -- data T = forall a. MkT { x :: a -> a } - -- For ResTyGADT, "explicit" means something like - -- data T where { MkT :: forall a. <blah> } - - , con_qvars :: LHsQTyVars name - -- ^ Type variables. Depending on 'con_res' this describes the - -- following entities - -- - -- - ResTyH98: the constructor's *existential* type variables + = ConDeclGADT + { con_names :: [Located name] + , con_type :: LHsSigType name + -- ^ The type after the ‘::’ + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } + + | ConDeclH98 + { con_name :: Located name + + , con_qvars :: Maybe (LHsQTyVars name) + -- User-written forall (if any), and its implicit + -- kind variables + -- Non-Nothing needs -XExistentialQuantification -- e.g. data T a = forall b. MkT b (b->a) -- con_qvars = {b} - -- - -- - ResTyGADT: *all* the constructor's quantified type variables - -- e.g. data T a where - -- MkT :: forall a b. b -> (b->a) -> T a - -- con_qvars = {a,b} - -- - -- If con_explicit is False, then con_qvars is irrelevant - -- until after renaming. - , con_cxt :: LHsContext name - -- ^ The context. This /does not/ include the \"stupid theta\" which - -- lives only in the 'TyData' decl. + , con_cxt :: Maybe (LHsContext name) + -- ^ User-written context (if any) - , con_details :: HsConDeclDetails name - -- ^ The main payload + , con_details :: HsConDeclDetails name + -- ^ Arguments - , con_res :: ResType (LHsType name) - -- ^ Result type of the constructor - - , con_doc :: Maybe LHsDocString - -- ^ A possible Haddock comment. - } deriving (Typeable) + , con_doc :: Maybe LHsDocString + -- ^ A possible Haddock comment. + } deriving (Typeable) deriving instance (DataId name) => Data (ConDecl name) type HsConDeclDetails name = HsConDetails (LBangType name) (Located [LConDeclField name]) +getConNames :: ConDecl name -> [Located name] +getConNames (ConDeclH98 {con_name = name}) = [name] +getConNames (ConDeclGADT {con_names = names}) = names + hsConDeclArgTys :: HsConDeclDetails name -> [LBangType name] hsConDeclArgTys (PrefixCon tys) = tys hsConDeclArgTys (InfixCon ty1 ty2) = [ty1,ty2] hsConDeclArgTys (RecCon flds) = map (cd_fld_type . unLoc) (unLoc flds) -data ResType ty - = ResTyH98 -- Constructor was declared using Haskell 98 syntax - | ResTyGADT SrcSpan ty -- Constructor was declared using GADT-style syntax, - -- and here is its result type, and the SrcSpan - -- of the original sigtype, for API Annotations - deriving (Data, Typeable) - -instance Outputable ty => Outputable (ResType ty) where - -- Debugging only - ppr ResTyH98 = ptext (sLit "ResTyH98") - ppr (ResTyGADT _ ty) = ptext (sLit "ResTyGADT") <+> ppr ty - pp_data_defn :: OutputableBndr name => (HsContext name -> SDoc) -- Printing the header -> HsDataDefn name @@ -1115,7 +1093,7 @@ instance Outputable NewOrData where ppr DataType = ptext (sLit "data") pp_condecls :: OutputableBndr name => [LConDecl name] -> SDoc -pp_condecls cs@(L _ ConDecl{ con_res = ResTyGADT _ _ } : _) -- In GADT syntax +pp_condecls cs@(L _ ConDeclGADT{} : _) -- In GADT syntax = hang (ptext (sLit "where")) 2 (vcat (map ppr cs)) pp_condecls cs -- In H98 syntax = equals <+> sep (punctuate (ptext (sLit " |")) (map ppr cs)) @@ -1124,50 +1102,27 @@ instance (OutputableBndr name) => Outputable (ConDecl name) where ppr = pprConDecl pprConDecl :: OutputableBndr name => ConDecl name -> SDoc -pprConDecl (ConDecl { con_names = [L _ con] -- NB: non-GADT means 1 con - , con_explicit = expl, con_qvars = tvs - , con_cxt = cxt, con_details = details - , con_res = ResTyH98, con_doc = doc }) - = sep [ppr_mbDoc doc, ppr_con_forall expl tvs cxt, ppr_details details] +pprConDecl (ConDeclH98 { con_name = L _ con + , con_qvars = mtvs + , con_cxt = mcxt + , con_details = details + , con_doc = doc }) + = sep [ppr_mbDoc doc, pprHsForAll tvs cxt, ppr_details details] where ppr_details (InfixCon t1 t2) = hsep [ppr t1, pprInfixOcc con, ppr t2] ppr_details (PrefixCon tys) = hsep (pprPrefixOcc con : map (pprParendHsType . unLoc) tys) ppr_details (RecCon fields) = pprPrefixOcc con <+> pprConDeclFields (unLoc fields) + tvs = case mtvs of + Nothing -> [] + Just (HsQTvs _ tvs) -> tvs -pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs - , con_cxt = cxt, con_details = PrefixCon arg_tys - , con_res = ResTyGADT _ res_ty, con_doc = doc }) - = ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon <+> - sep [ppr_con_forall expl tvs cxt, ppr (foldr mk_fun_ty res_ty arg_tys)] - where - mk_fun_ty a b = noLoc (HsFunTy a b) + cxt = fromMaybe (noLoc []) mcxt -pprConDecl (ConDecl { con_names = cons, con_explicit = expl, con_qvars = tvs - , con_cxt = cxt, con_details = RecCon fields - , con_res = ResTyGADT _ res_ty, con_doc = doc }) +pprConDecl (ConDeclGADT { con_names = cons, con_type = res_ty, con_doc = doc }) = sep [ppr_mbDoc doc <+> ppr_con_names cons <+> dcolon - <+> ppr_con_forall expl tvs cxt, - pprConDeclFields (unLoc fields) <+> arrow <+> ppr res_ty] - -pprConDecl decl@(ConDecl { con_details = InfixCon ty1 ty2, con_res = ResTyGADT {} }) - = pprConDecl (decl { con_details = PrefixCon [ty1,ty2] }) - -- In GADT syntax we don't allow infix constructors - -- so if we ever trip over one (albeit I can't see how that - -- can happen) print it like a prefix one - --- this fallthrough would happen with a non-GADT-syntax ConDecl with more --- than one constructor, which should indeed be impossible -pprConDecl (ConDecl { con_names = cons }) = pprPanic "pprConDecl" (ppr cons) - -ppr_con_forall :: OutputableBndr name => Bool -> LHsQTyVars name - -> LHsContext name -> SDoc -ppr_con_forall explicit_forall qtvs (L _ ctxt) - | explicit_forall - = pprHsForAllTvs (hsQTvBndrs qtvs) <+> pprHsContext ctxt - | otherwise - = pprHsContext ctxt + <+> ppr res_ty] ppr_con_names :: (OutputableBndr name) => [Located name] -> SDoc ppr_con_names = pprWithCommas (pprPrefixOcc . unLoc) diff --git a/compiler/hsSyn/HsTypes.hs b/compiler/hsSyn/HsTypes.hs index ed4c3be44b..01902ea63e 100644 --- a/compiler/hsSyn/HsTypes.hs +++ b/compiler/hsSyn/HsTypes.hs @@ -137,7 +137,7 @@ See also Note [Kind and type-variable binders] in RnTypes Note [HsType binders] ~~~~~~~~~~~~~~~~~~~~~ -The system fr recording type and kind-variable binders in HsTypes +The system for recording type and kind-variable binders in HsTypes is a bit complicated. Here's how it works. * In a HsType, @@ -146,7 +146,7 @@ is a bit complicated. Here's how it works. HsQualTy reprsents an /explicit, user-written/ context e.g. (Eq a, Show a) => ... The context can be empty if that's what the user wrote - These constructors reprsents what the user wrote, no more + These constructors represent what the user wrote, no more and no less. * HsTyVarBndr describes a quantified type variable written by the diff --git a/compiler/hsSyn/HsUtils.hs b/compiler/hsSyn/HsUtils.hs index 19996fd0f1..01cc9abca3 100644 --- a/compiler/hsSyn/HsUtils.hs +++ b/compiler/hsSyn/HsUtils.hs @@ -953,14 +953,25 @@ hsConDeclsBinders cons = go id cons case r of -- remove only the first occurrence of any seen field in order to -- avoid circumventing detection of duplicate fields (#9156) - L loc (ConDecl { con_names = names, con_details = RecCon flds }) -> - (map (L loc . unLoc) names ++ ns, r' ++ fs) + L loc (ConDeclGADT { con_names = names, con_type = HsIB { hsib_body = res_ty}}) -> + case tau of + L _ (HsFunTy (L _ (HsRecTy flds)) _res_ty) + -> (map (L loc . unLoc) names ++ ns, r' ++ fs) + where r' = remSeen (concatMap (cd_fld_names . unLoc) flds) + remSeen' = foldr (.) remSeen [deleteBy ((==) `on` rdrNameFieldOcc . unLoc) v | v <- r'] + (ns, fs) = go remSeen' rs + _other -> (map (L loc . unLoc) names ++ ns, fs) + where (ns, fs) = go remSeen rs + where + (_tvs, _cxt, tau) = splitLHsSigmaTy res_ty + L loc (ConDeclH98 { con_name = name, con_details = RecCon flds }) -> + ([L loc (unLoc name)] ++ ns, r' ++ fs) where r' = remSeen (concatMap (cd_fld_names . unLoc) (unLoc flds)) remSeen' = foldr (.) remSeen [deleteBy ((==) `on` rdrNameFieldOcc . unLoc) v | v <- r'] (ns, fs) = go remSeen' rs - L loc (ConDecl { con_names = names }) -> - (map (L loc . unLoc) names ++ ns, fs) + L loc (ConDeclH98 { con_name = name }) -> + ([L loc (unLoc name)] ++ ns, fs) where (ns, fs) = go remSeen rs {- diff --git a/compiler/parser/Parser.y b/compiler/parser/Parser.y index fb5c8dbd45..bbde989293 100644 --- a/compiler/parser/Parser.y +++ b/compiler/parser/Parser.y @@ -1895,10 +1895,9 @@ gadt_constr_with_doc gadt_constr :: { LConDecl RdrName } -- see Note [Difference in parsing GADT and data constructors] -- Returns a list because of: C,D :: ty - : con_list '::' ctype - {% do { let { (anns,gadtDecl) = mkGadtDecl (unLoc $1) $3 } - ; ams (sLL $1 $> gadtDecl) - (mu AnnDcolon $2:anns) } } + : con_list '::' sigtype + {% ams (sLL $1 $> (mkGadtDecl (unLoc $1) (mkLHsSigType $3))) + [mu AnnDcolon $2] } {- Note [Difference in parsing GADT and data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1925,13 +1924,13 @@ constrs1 :: { Located [LConDecl RdrName] } constr :: { LConDecl RdrName } : maybe_docnext forall context '=>' constr_stuff maybe_docprev {% ams (let (con,details) = unLoc $5 in - addConDoc (L (comb4 $2 $3 $4 $5) (mkSimpleConDecl con + addConDoc (L (comb4 $2 $3 $4 $5) (mkConDeclH98 con (snd $ unLoc $2) $3 details)) ($1 `mplus` $6)) (mu AnnDarrow $4:(fst $ unLoc $2)) } | maybe_docnext forall constr_stuff maybe_docprev {% ams ( let (con,details) = unLoc $3 in - addConDoc (L (comb2 $2 $3) (mkSimpleConDecl con + addConDoc (L (comb2 $2 $3) (mkConDeclH98 con (snd $ unLoc $2) (noLoc []) details)) ($1 `mplus` $4)) (fst $ unLoc $2) } @@ -2671,7 +2670,6 @@ stmtlist :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } -- here, because we need too much lookahead if we see do { e ; } -- So we use BodyStmts throughout, and switch the last one over -- in ParseUtils.checkDo instead --- AZ: TODO check that we can retrieve multiple semis. stmts :: { Located ([AddAnn],[LStmt RdrName (LHsExpr RdrName)]) } : stmts ';' stmt {% if null (snd $ unLoc $1) diff --git a/compiler/parser/RdrHsSyn.hs b/compiler/parser/RdrHsSyn.hs index 4b744fe69a..70be8e5d0e 100644 --- a/compiler/parser/RdrHsSyn.hs +++ b/compiler/parser/RdrHsSyn.hs @@ -35,7 +35,8 @@ module RdrHsSyn ( mkExport, mkExtName, -- RdrName -> CLabelString mkGadtDecl, -- [Located RdrName] -> LHsType RdrName -> ConDecl RdrName - mkSimpleConDecl, + gadtDeclDetails, + mkConDeclH98, mkATDefault, -- Bunch of functions in the parser monad for @@ -487,38 +488,30 @@ mkPatSynMatchGroup (L _ patsyn_name) (L _ decls) = text "pattern synonym 'where' clause must bind the pattern synonym's name" <+> quotes (ppr patsyn_name) $$ ppr decl -mkSimpleConDecl :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] +mkConDeclH98 :: Located RdrName -> Maybe [LHsTyVarBndr RdrName] -> LHsContext RdrName -> HsConDeclDetails RdrName -> ConDecl RdrName -mkSimpleConDecl name mb_forall cxt details - = ConDecl { con_names = [name] - , con_explicit = explicit - , con_qvars = qvars - , con_cxt = cxt - , con_details = details - , con_res = ResTyH98 - , con_doc = Nothing } - where - (explicit, qvars) = case mb_forall of - Nothing -> (False, mkHsQTvs []) - Just tvs -> (True, mkHsQTvs tvs) +mkConDeclH98 name mb_forall cxt details + = ConDeclH98 { con_name = name + , con_qvars = fmap mkHsQTvs mb_forall + , con_cxt = Just cxt + -- AZ:TODO: when can cxt be Nothing? + -- remembering that () is a valid context. + , con_details = details + , con_doc = Nothing } mkGadtDecl :: [Located RdrName] - -> LHsType RdrName -- Always a HsForAllTy - -> ([AddAnn], ConDecl RdrName) -mkGadtDecl names ty = ([], mkGadtDecl' names ty) - -mkGadtDecl' :: [Located RdrName] - -> LHsType RdrName - -> ConDecl RdrName --- We allow C,D :: ty --- and expand it as if it had been --- C :: ty; D :: ty --- (Just like type signatures in general.) - -mkGadtDecl' names lbody_ty@(L loc body_ty) - = mk_gadt_con names + -> LHsSigType RdrName -- Always a HsForAllTy + -> ConDecl RdrName +mkGadtDecl names ty = ConDeclGADT { con_names = names + , con_type = ty + , con_doc = Nothing } + +-- AZ:TODO: this probably belongs in a different module +gadtDeclDetails :: LHsSigType name + -> (HsConDeclDetails name,LHsType name,LHsContext name,[LHsTyVarBndr name]) +gadtDeclDetails (HsIB {hsib_body = lbody_ty}) = (details,res_ty,cxt,tvs) where (tvs, cxt, tau) = splitLHsSigmaTy lbody_ty (details, res_ty) -- See Note [Sorting out the result type] @@ -527,19 +520,6 @@ mkGadtDecl' names lbody_ty@(L loc body_ty) -> (RecCon (L l flds), res_ty) _other -> (PrefixCon [], tau) - explicit = case body_ty of - HsForAllTy {} -> True - _ -> False - - mk_gadt_con names - = ConDecl { con_names = names - , con_explicit = explicit - , con_qvars = mkHsQTvs tvs - , con_cxt = cxt - , con_details = details - , con_res = ResTyGADT loc res_ty - , con_doc = Nothing } - tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) tyConToDataCon loc tc | isTcOcc (rdrNameOcc tc) @@ -639,19 +619,19 @@ really doesn't matter! -- | Note [Sorting out the result type] -- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ --- In a GADT declaration which is not a record, we put the whole constr --- type into the ResTyGADT for now; the renamer will unravel it once it --- has sorted out operator fixities. Consider for example +-- In a GADT declaration which is not a record, we put the whole constr type +-- into the res_ty for a ConDeclGADT for now; the renamer will unravel it once +-- it has sorted out operator fixities. Consider for example -- C :: a :*: b -> a :*: b -> a :+: b -- Initially this type will parse as -- a :*: (b -> (a :*: (b -> (a :+: b)))) - +-- -- so it's hard to split up the arguments until we've done the precedence -- resolution (in the renamer) On the other hand, for a record -- { x,y :: Int } -> a :*: b -- there is no doubt. AND we need to sort records out so that -- we can bring x,y into scope. So: --- * For PrefixCon we keep all the args in the ResTyGADT +-- * For PrefixCon we keep all the args in the res_ty -- * For RecCon we do not checkTyVarsP :: SDoc -> SDoc -> Located RdrName -> [LHsType RdrName] -> P (LHsQTyVars RdrName) diff --git a/compiler/rename/RnEnv.hs b/compiler/rename/RnEnv.hs index c90b556cac..57890aad4f 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 b0b79f55e6..3cbb887693 100644 --- a/compiler/rename/RnNames.hs +++ b/compiler/rename/RnNames.hs @@ -610,11 +610,20 @@ 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 2fbbea4179..fb6ab27078 100644 --- a/compiler/rename/RnSource.hs +++ b/compiler/rename/RnSource.hs @@ -1242,8 +1242,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) @@ -1454,7 +1454,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) _ -> [] {- @@ -1506,29 +1506,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 -} --------------- @@ -1543,75 +1520,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 @@ -1635,9 +1598,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) diff --git a/compiler/typecheck/TcHsType.hs b/compiler/typecheck/TcHsType.hs index b6bd43c923..73cc674c70 100644 --- a/compiler/typecheck/TcHsType.hs +++ b/compiler/typecheck/TcHsType.hs @@ -9,7 +9,7 @@ module TcHsType ( -- Type signatures - kcClassSigType, tcClassSigType, + kcHsSigType, tcClassSigType, tcHsSigType, tcHsSigWcType, zonkSigType, zonkAndCheckValidity, funsSigCtxt, addSigCtxt, @@ -183,8 +183,8 @@ tcHsSigWcType :: UserTypeCtxt -> LHsSigWcType Name -> TcM Type -- alrady checked this, so we can simply ignore it. tcHsSigWcType ctxt sig_ty = tcHsSigType ctxt (dropWildCards sig_ty) -kcClassSigType :: [Located Name] -> LHsSigType Name -> TcM () -kcClassSigType names (HsIB { hsib_body = hs_ty +kcHsSigType :: [Located Name] -> LHsSigType Name -> TcM () +kcHsSigType names (HsIB { hsib_body = hs_ty , hsib_kvs = sig_kvs , hsib_tvs = sig_tvs }) = addSigCtxt (funsSigCtxt names) hs_ty $ @@ -387,9 +387,10 @@ tc_hs_type ty@(HsBangTy {}) _ -- other kinds of bangs are not (eg ((!Maybe) Int)). These kinds of -- bangs are invalid, so fail. (#7210) = failWithTc (ptext (sLit "Unexpected strictness annotation:") <+> ppr ty) -tc_hs_type (HsRecTy _) _ = panic "tc_hs_type: record" -- Unwrapped by con decls +tc_hs_type ty@(HsRecTy _) _ -- Record types (which only show up temporarily in constructor -- signatures) should have been removed by now + = failWithTc (ptext (sLit "Record syntax is illegal here:") <+> ppr ty) ---------- Functions and applications tc_hs_type hs_ty@(HsTyVar (L _ name)) exp_kind diff --git a/compiler/typecheck/TcRnDriver.hs b/compiler/typecheck/TcRnDriver.hs index ee95bb5594..27b807455a 100644 --- a/compiler/typecheck/TcRnDriver.hs +++ b/compiler/typecheck/TcRnDriver.hs @@ -1444,7 +1444,7 @@ tcTyClsInstDecls tycl_decls inst_decls deriv_decls get_fi_cons :: DataFamInstDecl Name -> [Name] get_fi_cons (DataFamInstDecl { dfid_defn = HsDataDefn { dd_cons = cons } }) - = map unLoc $ concatMap (con_names . unLoc) cons + = map unLoc $ concatMap (getConNames . unLoc) cons {- Note [AFamDataCon: not promoting data family constructors] diff --git a/compiler/typecheck/TcTyClsDecls.hs b/compiler/typecheck/TcTyClsDecls.hs index 6dbe540b32..4caa62c2d4 100644 --- a/compiler/typecheck/TcTyClsDecls.hs +++ b/compiler/typecheck/TcTyClsDecls.hs @@ -64,9 +64,11 @@ import Digraph import DynFlags import FastString import BasicTypes +import RdrHsSyn ( gadtDeclDetails ) import Control.Monad import Data.List +import Data.Monoid ( mempty ) {- ************************************************************************ @@ -381,7 +383,7 @@ getInitialKind decl@(DataDecl { tcdLName = L _ name ; return (res_k, ()) } ; let main_pr = (name, AThing decl_kind) inner_prs = [ (unLoc con, APromotionErr RecDataConPE) - | L _ con' <- cons, con <- con_names con' ] + | L _ con' <- cons, con <- getConNames con' ] ; return (main_pr : inner_prs) } getInitialKind (FamDecl { tcdFam = decl }) @@ -480,7 +482,7 @@ kcTyClDecl (ClassDecl { tcdLName = L _ name, tcdTyVars = hs_tvs do { _ <- tcHsContext ctxt ; mapM_ (wrapLocM kc_sig) sigs } where - kc_sig (ClassOpSig _ nms op_ty) = kcClassSigType nms op_ty + kc_sig (ClassOpSig _ nms op_ty) = kcHsSigType nms op_ty kc_sig _ = return () -- closed type families look at their equations, but other families don't @@ -495,20 +497,25 @@ kcTyClDecl (FamDecl {}) = return () ------------------- kcConDecl :: ConDecl Name -> TcM () -kcConDecl (ConDecl { con_names = names, con_qvars = ex_tvs - , con_cxt = ex_ctxt, con_details = details - , con_res = res }) - = addErrCtxt (dataConCtxtName names) $ +kcConDecl (ConDeclH98 { con_name = name, con_qvars = ex_tvs + , con_cxt = ex_ctxt, con_details = details }) + = addErrCtxt (dataConCtxtName [name]) $ -- the 'False' says that the existentials don't have a CUSK, as the -- concept doesn't really apply here. We just need to bring the variables -- into scope! - do { _ <- kcHsTyVarBndrs False ex_tvs $ - do { _ <- tcHsContext ex_ctxt + do { _ <- kcHsTyVarBndrs False ((fromMaybe (HsQTvs mempty []) ex_tvs) ::LHsQTyVars Name) $ + do { _ <- tcHsContext (fromMaybe (noLoc []) ex_ctxt) ; mapM_ (tcHsOpenType . getBangType) (hsConDeclArgTys details) - ; _ <- tcConRes res ; return (panic "kcConDecl", ()) } ; return () } +kcConDecl (ConDeclGADT { con_names = names + , con_type = ty }) + = addErrCtxt (dataConCtxtName names) $ + do { _ <- tcGadtSigType (ppr names) (unLoc $ head names) ty + ; return () } + + {- Note [Recursion and promoting data constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1241,8 +1248,8 @@ dataDeclChecks tc_name new_or_data stupid_theta cons ----------------------------------- consUseGadtSyntax :: [LConDecl a] -> Bool -consUseGadtSyntax (L _ (ConDecl { con_res = ResTyGADT _ _ }) : _) = True -consUseGadtSyntax _ = False +consUseGadtSyntax (L _ (ConDeclGADT { }) : _) = True +consUseGadtSyntax _ = False -- All constructors have same shape ----------------------------------- @@ -1261,41 +1268,71 @@ tcConDecl :: NewOrData -> TcM [DataCon] tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl - (ConDecl { con_names = names - , con_qvars = hs_tvs, con_cxt = hs_ctxt - , con_details = hs_details, con_res = hs_res_ty }) - = addErrCtxt (dataConCtxtName names) $ - do { traceTc "tcConDecl 1" (ppr names) - ; (ctxt, arg_tys, res_ty, field_lbls, stricts) - <- tcHsQTyVars hs_tvs $ \ _ -> - do { traceTc "tcConDecl" (ppr names <+> text "tvs:" <+> ppr hs_tvs) - ; ctxt <- tcHsContext hs_ctxt + (ConDeclH98 { con_name = name + , con_qvars = hs_tvs, con_cxt = hs_ctxt + , con_details = hs_details }) + = addErrCtxt (dataConCtxtName [name]) $ + do { traceTc "tcConDecl 1" (ppr name) + ; (ctxt, arg_tys, field_lbls, stricts) + <- tcHsQTyVars (fromMaybe (HsQTvs [] []) hs_tvs) $ \ _ -> + do { traceTc "tcConDecl" (ppr name <+> text "tvs:" <+> ppr hs_tvs) + ; ctxt <- tcHsContext (fromMaybe (noLoc []) hs_ctxt) ; btys <- tcConArgs new_or_data hs_details - ; res_ty <- tcConRes hs_res_ty - ; field_lbls <- lookupConstructorFields (unLoc $ head names) + ; field_lbls <- lookupConstructorFields (unLoc name) ; let (arg_tys, stricts) = unzip btys - ; return (ctxt, arg_tys, res_ty, field_lbls, stricts) + ; return (ctxt, arg_tys, field_lbls, stricts) } - -- Generalise the kind variables (returning quantified TcKindVars) - -- and quantify the type variables (substituting their kinds) - -- REMEMBER: 'tkvs' are: - -- ResTyH98: the *existential* type variables only - -- ResTyGADT: *all* the quantified type variables - -- c.f. the comment on con_qvars in HsDecls - ; tkvs <- case res_ty of - ResTyH98 -> quantifyTyVars (mkVarSet tmpl_tvs) - (tyVarsOfTypes (ctxt++arg_tys)) - ResTyGADT _ res_ty -> quantifyTyVars emptyVarSet - (tyVarsOfTypes (res_ty:ctxt++arg_tys)) + ; tkvs <- quantifyTyVars (mkVarSet tmpl_tvs) (tyVarsOfTypes (ctxt++arg_tys)) -- Zonk to Types ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs ; arg_tys <- zonkTcTypeToTypes ze arg_tys ; ctxt <- zonkTcTypeToTypes ze ctxt - ; res_ty <- case res_ty of - ResTyH98 -> return ResTyH98 - ResTyGADT ls ty -> ResTyGADT ls <$> zonkTcTypeToType ze ty + + ; let (univ_tvs, ex_tvs, eq_preds) = (tmpl_tvs, qtkvs, []) + -- AZ:TODO: Is this comment needed here for ConDeclH98? + -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon + -- without yet forcing the guards in rejigConRes + -- See Note [Checking GADT return types] + + ; fam_envs <- tcGetFamInstEnvs + + -- Can't print univ_tvs, arg_tys etc, because we are inside the knot here + ; traceTc "tcConDecl 2" (ppr name $$ ppr field_lbls) + ; let + buildOneDataCon (L _ name) = do + { is_infix <- tcConIsInfixH98 name hs_details + ; rep_nm <- newTyConRepName name + + ; buildDataCon fam_envs name is_infix + (if is_prom then Promoted rep_nm else NotPromoted) + -- Must be lazy in is_prom because it is knot-tied + stricts Nothing field_lbls + univ_tvs ex_tvs eq_preds ctxt arg_tys + res_tmpl rep_tycon + -- NB: we put data_tc, the type constructor gotten from the + -- constructor type signature into the data constructor; + -- that way checkValidDataCon can complain if it's wrong. + } + ; traceTc "tcConDecl 2" (ppr name) + ; mapM buildOneDataCon [name] + } + +tcConDecl _new_or_data is_prom rep_tycon tmpl_tvs res_tmpl + (ConDeclGADT { con_names = names + , con_type = ty@(HsIB { hsib_kvs = _kvs, hsib_tvs = _tvs, hsib_body = _bty}) }) + = addErrCtxt (dataConCtxtName names) $ + do { traceTc "tcConDecl 1" (ppr names) + ; (ctxt, stricts, field_lbls, arg_tys, res_ty,hs_details) + <- tcGadtSigType (ppr names) (unLoc $ head names) ty + ; tkvs <- quantifyTyVars emptyVarSet (tyVarsOfTypes (res_ty:ctxt++arg_tys)) + + -- Zonk to Types + ; (ze, qtkvs) <- zonkTyBndrsX emptyZonkEnv tkvs + ; arg_tys <- zonkTcTypeToTypes ze arg_tys + ; ctxt <- zonkTcTypeToTypes ze ctxt + ; res_ty <- zonkTcTypeToType ze res_ty ; let (univ_tvs, ex_tvs, eq_preds, res_ty') = rejigConRes tmpl_tvs res_tmpl qtkvs res_ty -- NB: this is a /lazy/ binding, so we pass four thunks to buildDataCon @@ -1308,7 +1345,7 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl ; traceTc "tcConDecl 2" (ppr names $$ ppr field_lbls) ; let buildOneDataCon (L _ name) = do - { is_infix <- tcConIsInfix name hs_details res_ty + { is_infix <- tcConIsInfixGADT name hs_details ; rep_nm <- newTyConRepName name ; buildDataCon fam_envs name is_infix @@ -1326,19 +1363,70 @@ tcConDecl new_or_data is_prom rep_tycon tmpl_tvs res_tmpl } -tcConIsInfix :: Name +tcGadtSigType :: SDoc -> Name -> LHsSigType Name + -> TcM ([PredType],[HsSrcBang], [FieldLabel], [Type], Type + ,HsConDetails (LHsType Name) (Located [LConDeclField Name])) +tcGadtSigType doc name ty@(HsIB { hsib_kvs = kvs, hsib_tvs = tvs, hsib_body = _bty}) + = do { let (hs_details',res_ty',cxt,gtvs) = gadtDeclDetails ty + ; (hs_details,res_ty) <- tcUpdateConResult doc hs_details' res_ty' + ; let hs_tvs = HsQTvs { hsq_kvs = kvs, hsq_tvs = gtvs ++ map (noLoc . UserTyVar . noLoc) tvs } + ; (ctxt, arg_tys, res_ty, field_lbls, stricts) + <- tcHsQTyVars hs_tvs $ \ _ -> + do { ctxt <- tcHsContext cxt + ; btys <- tcConArgs DataType hs_details + ; ty' <- tcHsLiftedType res_ty + ; field_lbls <- lookupConstructorFields name + ; let (arg_tys, stricts) = unzip btys + ; return (ctxt, arg_tys, ty', field_lbls, stricts) + } + ; return (ctxt,stricts,field_lbls,arg_tys,res_ty,hs_details) + } + +tcUpdateConResult :: SDoc + -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -- Original details + -> LHsType Name -- The original result type + -> TcM (HsConDetails (LHsType Name) (Located [LConDeclField Name]), + LHsType Name) +tcUpdateConResult doc details ty + = do { 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 "tcUpdateConResult" (ppr ty) + -- See Note [Sorting out the result type] in RdrHsSyn + + RecCon {} -> do { unless (null arg_tys) + (failWithTc (badRecResTy doc)) + -- AZ: This error used to be reported during + -- renaming, will now be reported in type + -- checking. Is this a problem? + ; return (details, res_ty) } + + PrefixCon {} -> return (PrefixCon arg_tys, res_ty)} + where + badRecResTy :: SDoc -> SDoc + badRecResTy ctxt = ctxt <+> + ptext (sLit "Malformed constructor signature") + +tcConIsInfixH98 :: Name -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) - -> ResType Type -> TcM Bool -tcConIsInfix _ details ResTyH98 +tcConIsInfixH98 _ details = case details of InfixCon {} -> return True _ -> return False -tcConIsInfix con details (ResTyGADT _ _) + +tcConIsInfixGADT :: Name + -> HsConDetails (LHsType Name) (Located [LConDeclField Name]) + -> TcM Bool +tcConIsInfixGADT con details = case details of InfixCon {} -> return True RecCon {} -> return False - PrefixCon arg_tys -- See Note [Infix GADT cons] + PrefixCon arg_tys -- See Note [Infix GADT constructors] | isSymOcc (getOccName con) , [_ty1,_ty2] <- arg_tys -> do { fix_env <- getFixityEnv @@ -1372,11 +1460,6 @@ tcConArg new_or_data bty ; traceTc "tcConArg 2" (ppr bty) ; return (arg_ty, getBangStrictness bty) } -tcConRes :: ResType (LHsType Name) -> TcM (ResType Type) -tcConRes ResTyH98 = return ResTyH98 -tcConRes (ResTyGADT ls res_ty) = do { res_ty' <- tcHsLiftedType res_ty - ; return (ResTyGADT ls res_ty') } - {- Note [Infix GADT constructors] ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -1432,7 +1515,7 @@ rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. -- data instance T [a] b c = ... -- gives template ([a,b,c], T [a] b c) -> [TyVar] -- where MkT :: forall x y z. ... - -> ResType Type + -> Type -- res_ty -> ([TyVar], -- Universal [TyVar], -- Existential (distinct OccNames from univs) [(TyVar,Type)], -- Equality predicates @@ -1440,13 +1523,7 @@ rejigConRes :: [TyVar] -> Type -- Template for result type; e.g. -- We don't check that the TyCon given in the ResTy is -- the same as the parent tycon, because checkValidDataCon will do it -rejigConRes tmpl_tvs res_ty dc_tvs ResTyH98 - = (tmpl_tvs, dc_tvs, [], res_ty) - -- In H98 syntax the dc_tvs are the existential ones - -- data T a b c = forall d e. MkT ... - -- The universals {a,b,c} are tc_tvs, and the existentials {d,e} are dc_tvs - -rejigConRes tmpl_tvs res_tmpl dc_tvs (ResTyGADT _ res_ty) +rejigConRes tmpl_tvs res_tmpl dc_tvs res_ty -- E.g. data T [a] b c where -- MkT :: forall x y z. T [(x,y)] z z -- The {a,b,c} are the tmpl_tvs, and the {x,y,z} are the dc_tvs @@ -1499,7 +1576,7 @@ data SList s as where We call tcResultType with tmpl_tvs = [(k :: BOX), (s :: k -> *), (as :: List k)] res_tmpl = SList k s as - res_ty = ResTyGADT (SList k1 (s1 :: k1 -> *) (Nil k1)) + res_ty = (SList k1 (s1 :: k1 -> *) (Nil k1)) We get subst: k -> k1 diff --git a/testsuite/tests/ghc-api/annotations/T10399.stdout b/testsuite/tests/ghc-api/annotations/T10399.stdout index 58a4093aae..612ecfd734 100644 --- a/testsuite/tests/ghc-api/annotations/T10399.stdout +++ b/testsuite/tests/ghc-api/annotations/T10399.stdout @@ -44,9 +44,7 @@ ((Test10399.hs:15:45-46,AnnBang), [Test10399.hs:15:45]), ((Test10399.hs:15:45-46,AnnRarrow), [Test10399.hs:15:48-49]), ((Test10399.hs:15:45-64,AnnRarrow), [Test10399.hs:15:48-49]), -((Test10399.hs:(16,5)-(17,69),AnnCloseP), [Test10399.hs:17:69]), ((Test10399.hs:(16,5)-(17,69),AnnDcolon), [Test10399.hs:16:12-13]), -((Test10399.hs:(16,5)-(17,69),AnnOpenP), [Test10399.hs:16:27]), ((Test10399.hs:(16,15)-(17,69),AnnDot), [Test10399.hs:16:25]), ((Test10399.hs:(16,15)-(17,69),AnnForall), [Test10399.hs:16:15-20]), ((Test10399.hs:(16,27)-(17,69),AnnCloseP), [Test10399.hs:17:69]), diff --git a/testsuite/tests/ghc-api/annotations/all.T b/testsuite/tests/ghc-api/annotations/all.T index 4104bceebf..c7c8542a11 100644 --- a/testsuite/tests/ghc-api/annotations/all.T +++ b/testsuite/tests/ghc-api/annotations/all.T @@ -16,7 +16,7 @@ test('T10358', normal, run_command, ['$MAKE -s --no-print-directory T10358' test('T10278', normal, run_command, ['$MAKE -s --no-print-directory T10278']) test('T10354', normal, run_command, ['$MAKE -s --no-print-directory T10354']) test('T10396', normal, run_command, ['$MAKE -s --no-print-directory T10396']) -test('T10399', expect_broken(11028), run_command, ['$MAKE -s --no-print-directory T10399']) +test('T10399', normal, run_command, ['$MAKE -s --no-print-directory T10399']) test('T10313', normal, run_command, ['$MAKE -s --no-print-directory T10313']) test('T11018', normal, run_command, ['$MAKE -s --no-print-directory T11018']) test('bundle-export', normal, run_command, ['$MAKE -s --no-print-directory bundle-export']) diff --git a/testsuite/tests/ghc-api/landmines/landmines.stdout b/testsuite/tests/ghc-api/landmines/landmines.stdout index db0b651dfa..551b2cf8d7 100644 --- a/testsuite/tests/ghc-api/landmines/landmines.stdout +++ b/testsuite/tests/ghc-api/landmines/landmines.stdout @@ -1,4 +1,4 @@ (12,12,7) -(66,62,0) +(63,63,0) (13,13,7) (10,10,7) diff --git a/testsuite/tests/rename/should_compile/T5331.stderr b/testsuite/tests/rename/should_compile/T5331.stderr index 13249b0e17..965e15a9b4 100644 --- a/testsuite/tests/rename/should_compile/T5331.stderr +++ b/testsuite/tests/rename/should_compile/T5331.stderr @@ -5,7 +5,7 @@ T5331.hs:8:17: warning: T5331.hs:11:16: warning:
Unused quantified type variable ‘a’
- In the definition of data constructor ‘W1’
+ In the type ‘forall a. W’
T5331.hs:13:13: warning:
Unused quantified type variable ‘a’
diff --git a/testsuite/tests/rename/should_fail/T7943.stderr b/testsuite/tests/rename/should_fail/T7943.stderr index 8594a25e2f..c6bf7ae9b5 100644 --- a/testsuite/tests/rename/should_fail/T7943.stderr +++ b/testsuite/tests/rename/should_fail/T7943.stderr @@ -1,2 +1,6 @@ -T7943.hs:4:22: Record syntax is illegal here: {bar :: String} +T7943.hs:4:22: + Record syntax is illegal here: {bar :: String} + In the type ‘{bar :: String}’ + In the definition of data constructor ‘B’ + In the data declaration for ‘Foo’
\ No newline at end of file diff --git a/utils/haddock b/utils/haddock -Subproject 42b2cfc595f1ee62d1c1b8513c5df1d92709c06 +Subproject 628c80444e55289cfb74823555f80e1dabfa82e |