X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnSource.lhs;h=75af8fdfd0c67a158c1bc6e1ca7ff87dfb431c8f;hb=5d0b2bba1dfc0b2786162927ed7b3d4911f1cc54;hp=79f7b83f94360c7b67e5885091b023c3461e058d;hpb=5f8e2da0def4a202031a5d7ac7dfd9fd4971395d;p=ghc-hetmet.git diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index 79f7b83..75af8fd 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -75,7 +75,7 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, hs_fords = foreign_decls, hs_defds = default_decls, hs_ruleds = rule_decls, - hs_docs = docs }) + hs_docs = docs }) = do { -- Deal with deprecations (returns only the extra deprecations) deprecs <- rnSrcDeprecDecls deprec_decls ; @@ -116,7 +116,8 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, (rn_default_decls, src_fvs5) <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; - rn_docs <- rnDocEntities docs ; + -- Haddock docs + rn_docs <- mapM (wrapLocM rnDocDecl) docs ; let { rn_group = HsGroup { hs_valds = rn_val_decls, @@ -128,7 +129,7 @@ rnSrcDecls (HsGroup { hs_valds = val_decls, hs_fords = rn_foreign_decls, hs_defds = rn_default_decls, hs_ruleds = rn_rule_decls, - hs_docs = rn_docs } ; + hs_docs = rn_docs } ; other_fvs = plusFVs [src_fvs1, src_fvs2, src_fvs_deriv, src_fvs3, src_fvs4, src_fvs5] ; @@ -162,21 +163,6 @@ addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } %********************************************************* \begin{code} -rnDocEntities :: [DocEntity RdrName] -> RnM [DocEntity Name] -rnDocEntities ents - = ifErrsM (return []) $ - -- Yuk: stop if we have found errors. Otherwise - -- the rnDocEntity stuff reports the errors again. - mapM rnDocEntity ents - -rnDocEntity :: DocEntity RdrName -> RnM (DocEntity Name) -rnDocEntity (DocEntity docdecl) = do - rn_docdecl <- rnDocDecl docdecl - return (DocEntity rn_docdecl) -rnDocEntity (DeclEntity name) = do - rn_name <- lookupTopBndrRn name - return (DeclEntity rn_name) - rnDocDecl :: DocDecl RdrName -> RnM (DocDecl Name) rnDocDecl (DocCommentNext doc) = do rn_doc <- rnHsDoc doc @@ -380,26 +366,16 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) Renaming of the associated types in instances. -* We raise an error if we encounter a kind signature in an instance. - \begin{code} rnATInsts :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) rnATInsts atDecls = mapFvRn (wrapLocFstM rnATInst) atDecls where - rnATInst tydecl@TyFunction {} = - do - addErr noKindSig - rnTyClDecl tydecl + rnATInst tydecl@TyData {} = rnTyClDecl tydecl rnATInst tydecl@TySynonym {} = rnTyClDecl tydecl - rnATInst tydecl@TyData {} = - do - checkM (not . isKindSigDecl $ tydecl) $ addErr noKindSig - rnTyClDecl tydecl - rnATInst _ = - panic "RnSource.rnATInsts: not a type declaration" - -noKindSig = text "Instances cannot have kind signatures" + rnATInst tydecl = + pprPanic "RnSource.rnATInsts: invalid AT instance" + (ppr (tcdName tydecl)) \end{code} For the method bindings in class and instance decls, we extend the @@ -422,11 +398,10 @@ extendTyVarEnvForMethodBinds tyvars thing_inside \begin{code} rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) -rnSrcDerivDecl (DerivDecl ty n) +rnSrcDerivDecl (DerivDecl ty) = do ty' <- rnLHsType (text "a deriving decl") ty - n' <- lookupLocatedOccRn n - let fvs = extractHsTyNames ty' `addOneFV` unLoc n' - return (DerivDecl ty' n', fvs) + let fvs = extractHsTyNames ty' + return (DerivDecl ty', fvs) \end{code} %********************************************************* @@ -558,17 +533,21 @@ rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_ returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, emptyFVs) +-- all flavours of type family declarations ("type family", "newtype fanily", +-- and "data family") +rnTyClDecl (tydecl@TyFamily {}) = + rnFamily tydecl bindTyVarsRn + +-- "data", "newtype", "data instance, and "newtype instance" declarations rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, tcdTyPats = typatsMaybe, tcdCons = condecls, tcdKindSig = sig, tcdDerivs = derivs}) - | isKindSigDecl tydecl -- kind signature of indexed type - = rnTySig tydecl bindTyVarsRn | is_vanilla -- Normal Haskell data type decl = ASSERT( isNothing sig ) -- In normal H98 form, kind signature on the -- data type is syntactically illegal bindTyVarsRn data_doc tyvars $ \ tyvars' -> - do { tycon' <- if isIdxTyDecl tydecl + do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; context' <- rnContext data_doc context @@ -584,14 +563,14 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, extractHsCtxtTyNames context' `plusFV` plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs `plusFV` - (if isIdxTyDecl tydecl + (if isFamInstDecl tydecl then unitFV (unLoc tycon') -- type instance => use else emptyFVs)) } | otherwise -- GADT = ASSERT( none typatsMaybe ) -- GADTs cannot have type patterns for now - do { tycon' <- if isIdxTyDecl tydecl + do { tycon' <- if isFamInstDecl tydecl then lookupLocatedOccRn tycon -- may be imported family else lookupLocatedTopBndrRn tycon ; checkTc (null (unLoc context)) (badGadtStupidTheta tycon) @@ -609,7 +588,7 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, tcdCons = condecls', tcdDerivs = derivs'}, plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs `plusFV` - (if isIdxTyDecl tydecl + (if isFamInstDecl tydecl then unitFV (unLoc tycon') -- type instance => use else emptyFVs)) } @@ -632,13 +611,11 @@ rnTyClDecl (tydecl@TyData {tcdND = new_or_data, tcdCtxt = context, rn_derivs (Just ds) = rnLHsTypes data_doc ds `thenM` \ ds' -> returnM (Just ds', extractHsTyNames_s ds') -rnTyClDecl (tydecl@TyFunction {}) = - rnTySig tydecl bindTyVarsRn - +-- "type" and "type instance" declarations rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdTyPats = typatsMaybe, tcdSynRhs = ty}) = bindTyVarsRn syn_doc tyvars $ \ tyvars' -> - do { name' <- if isIdxTyDecl tydecl + do { name' <- if isFamInstDecl tydecl then lookupLocatedOccRn name -- may be imported family else lookupLocatedTopBndrRn name ; typats' <- rnTyPats syn_doc typatsMaybe @@ -647,7 +624,7 @@ rnTyClDecl tydecl@(TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdTyPats = typats', tcdSynRhs = ty'}, delFVs (map hsLTyVarName tyvars') $ fvs `plusFV` - (if isIdxTyDecl tydecl + (if isFamInstDecl tydecl then unitFV (unLoc name') -- type instance => use else emptyFVs)) } @@ -699,10 +676,8 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, ; gen_tyvars <- newLocalsRn gen_rdr_tyvars_w_locs ; rnMethodBinds (unLoc cname') (mkSigTvFn sigs') gen_tyvars mbinds } - -- Sigh. Check the Haddock docs after the methods, to avoid duplicate errors - -- Example: class { op :: a->a; op2 x = x } - -- Don't want a duplicate complait about op2 - ; docs' <- bindLocalNames (map hsLTyVarName tyvars') $ rnDocEntities docs + -- Haddock docs + ; docs' <- mapM (wrapLocM rnDocDecl) docs ; return (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', tcdFDs = fds', tcdSigs = sigs', @@ -809,64 +784,45 @@ rnField doc (HsRecField name ty haddock_doc) rnMbLHsDoc haddock_doc `thenM` \ new_haddock_doc -> returnM (HsRecField new_name new_ty new_haddock_doc) --- Rename kind signatures (signatures of indexed data types/newtypes and --- signatures of type functions) +-- Rename family declarations -- -- * This function is parametrised by the routine handling the index -- variables. On the toplevel, these are defining occurences, whereas they -- are usage occurences for associated types. -- -rnTySig :: TyClDecl RdrName - -> (SDoc -> [LHsTyVarBndr RdrName] -> - ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) -> - RnM (TyClDecl Name, FreeVars)) - -> RnM (TyClDecl Name, FreeVars) - -rnTySig (tydecl@TyData {tcdCtxt = context, tcdLName = tycon, - tcdTyVars = tyvars, tcdTyPats = mb_typats, - tcdCons = condecls, tcdKindSig = sig, - tcdDerivs = derivs}) +rnFamily :: TyClDecl RdrName + -> (SDoc -> [LHsTyVarBndr RdrName] -> + ([LHsTyVarBndr Name] -> RnM (TyClDecl Name, FreeVars)) -> + RnM (TyClDecl Name, FreeVars)) + -> RnM (TyClDecl Name, FreeVars) + +rnFamily (tydecl@TyFamily {tcdFlavour = flavour, + tcdLName = tycon, tcdTyVars = tyvars}) bindIdxVars = - ASSERT( null condecls ) -- won't have constructors - ASSERT( isNothing mb_typats ) -- won't have type patterns - ASSERT( isNothing derivs ) -- won't have deriving - ASSERT( isJust sig ) -- will have kind signature - do { bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do { + do { checkM (isDataFlavour flavour -- for synonyms, + || not (null tyvars)) $ addErr needOneIdx -- #indexes >= 1 + ; bindIdxVars (family_doc tycon) tyvars $ \tyvars' -> do { ; tycon' <- lookupLocatedTopBndrRn tycon - ; context' <- rnContext (ksig_doc tycon) context - ; returnM (TyData {tcdND = tcdND tydecl, tcdCtxt = context', - tcdLName = tycon', tcdTyVars = tyvars', - tcdTyPats = Nothing, tcdKindSig = sig, - tcdCons = [], tcdDerivs = Nothing}, - delFVs (map hsLTyVarName tyvars') $ - extractHsCtxtTyNames context') - } } - where - -rnTySig (tydecl@TyFunction {tcdLName = tycon, tcdTyVars = tyvars, - tcdKind = sig}) - bindIdxVars = - do { checkM (not . null $ tyvars) $ addErr needOneIdx -- #indexes >= 1 - ; bindIdxVars (ksig_doc tycon) tyvars $ \tyvars' -> do { - ; tycon' <- lookupLocatedTopBndrRn tycon - ; returnM (TyFunction {tcdLName = tycon', tcdTyVars = tyvars', - tcdIso = tcdIso tydecl, tcdKind = sig}, + ; returnM (TyFamily {tcdFlavour = flavour, tcdLName = tycon', + tcdTyVars = tyvars', tcdKind = tcdKind tydecl}, emptyFVs) } } + where + isDataFlavour (DataFamily _) = True + isDataFlavour _ = False -ksig_doc tycon = text "In the kind signature for" <+> quotes (ppr tycon) -needOneIdx = text "Kind signature requires at least one type index" +family_doc tycon = text "In the family declaration for" <+> quotes (ppr tycon) +needOneIdx = text "Type family declarations requires at least one type index" -- Rename associated type declarations (in classes) -- --- * This can be kind signatures and (default) type function equations. +-- * This can be family declarations and (default) type instances -- rnATs :: [LTyClDecl RdrName] -> RnM ([LTyClDecl Name], FreeVars) rnATs ats = mapFvRn (wrapLocFstM rn_at) ats where - rn_at (tydecl@TyData {}) = rnTySig tydecl lookupIdxVars - rn_at (tydecl@TyFunction {}) = rnTySig tydecl lookupIdxVars - rn_at (tydecl@TySynonym {}) = + rn_at (tydecl@TyFamily {}) = rnFamily tydecl lookupIdxVars + rn_at (tydecl@TySynonym {}) = do checkM (isNothing (tcdTyPats tydecl)) $ addErr noPatterns rnTyClDecl tydecl