Repository : ssh://darcs.haskell.org//srv/darcs/ghc On branch : master
http://hackage.haskell.org/trac/ghc/changeset/ce1f1cd5f0ec5f07475e44cf2b7f72e0cbb8a963 >--------------------------------------------------------------- commit ce1f1cd5f0ec5f07475e44cf2b7f72e0cbb8a963 Author: Simon Peyton Jones <[email protected]> Date: Thu Sep 29 16:47:57 2011 +0100 Tidy up the shape-checking for instance types (in instance and standalone deriving decls) Fixes Trac #5513. >--------------------------------------------------------------- compiler/parser/Parser.y.pp | 7 +++---- compiler/parser/RdrHsSyn.lhs | 21 --------------------- compiler/rename/RnNames.lhs | 10 +++++++--- compiler/rename/RnSource.lhs | 4 ++-- compiler/rename/RnTypes.lhs | 17 ++++++++++++++++- 5 files changed, 28 insertions(+), 31 deletions(-) diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp index 9a25b7d..e3da00d 100644 --- a/compiler/parser/Parser.y.pp +++ b/compiler/parser/Parser.y.pp @@ -1049,7 +1049,7 @@ atype :: { LHsType RdrName } -- It's kept as a single type, with a MonoDictTy at the right -- hand corner, for convenience. inst_type :: { LHsType RdrName } - : sigtype {% checkInstType $1 } + : sigtype { $1 } inst_types1 :: { [LHsType RdrName] } : inst_type { [$1] } @@ -1183,9 +1183,8 @@ fielddecl :: { [ConDeclField RdrName] } -- A list because of f,g :: Int -- We don't allow a context, but that's sorted out by the type checker. deriving :: { Located (Maybe [LHsType RdrName]) } : {- empty -} { noLoc Nothing } - | 'deriving' qtycon {% do { let { L loc tv = $2 } - ; p <- checkInstType (L loc (HsTyVar tv)) - ; return (LL (Just [p])) } } + | 'deriving' qtycon { let { L loc tv = $2 } + in LL (Just [L loc (HsTyVar tv)]) } | 'deriving' '(' ')' { LL (Just []) } | 'deriving' '(' inst_types1 ')' { LL (Just $3) } -- Glasgow extension: allow partial diff --git a/compiler/parser/RdrHsSyn.lhs b/compiler/parser/RdrHsSyn.lhs index 6f47ea8..25ed3c2 100644 --- a/compiler/parser/RdrHsSyn.lhs +++ b/compiler/parser/RdrHsSyn.lhs @@ -35,7 +35,6 @@ module RdrHsSyn ( checkContext, -- HsType -> P HsContext checkTyVars, -- [LHsType RdrName] -> P () checkKindSigs, -- [LTyClDecl RdrName] -> P () - checkInstType, -- HsType -> P HsType checkPattern, -- HsExp -> P HsPat bang_RDR, checkPatterns, -- SrcLoc -> [HsExp] -> P [HsPat] @@ -457,26 +456,6 @@ we can bring x,y into scope. So: * For RecCon we do not \begin{code} ----------------------------------------------------------------------------- --- Various Syntactic Checks - -checkInstType :: LHsType RdrName -> P (LHsType RdrName) -checkInstType (L l t) - = case t of - HsForAllTy exp tvs ctxt ty -> do - dict_ty <- checkDictTy ty - return (L l (HsForAllTy exp tvs ctxt dict_ty)) - - HsParTy ty -> checkInstType ty - - ty -> do dict_ty <- checkDictTy (L l ty) - return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) - -checkDictTy :: LHsType RdrName -> P (LHsType RdrName) -checkDictTy lty@(L l ty) = case splitLHsClassTy_maybe lty of - Nothing -> parseErrorSDoc l (text "Malformed instance header:" <+> ppr ty) - Just _ -> return lty - checkTParams :: Bool -- Type/data family -> LHsType RdrName -> [LHsType RdrName] diff --git a/compiler/rename/RnNames.lhs b/compiler/rename/RnNames.lhs index ce14ad2..fa8a993 100644 --- a/compiler/rename/RnNames.lhs +++ b/compiler/rename/RnNames.lhs @@ -545,10 +545,14 @@ getLocalNonValBinders fixity_env new_assoc :: LInstDecl RdrName -> RnM [AvailInfo] new_assoc (L _ (InstDecl inst_ty _ _ ats)) - = do { cls_nm <- setSrcSpan loc $ lookupGlobalOccRn cls_rdr - ; mapM (new_ti (Just cls_nm)) ats } + = do { mb_cls_nm <- get_cls_parent inst_ty + ; mapM (new_ti mb_cls_nm) ats } where - Just (_, _, L loc cls_rdr, _) = splitLHsInstDeclTy_maybe inst_ty + get_cls_parent inst_ty + | Just (_, _, L loc cls_rdr, _) <- splitLHsInstDeclTy_maybe inst_ty + = setSrcSpan loc $ do { nm <- lookupGlobalOccRn cls_rdr; return (Just nm) } + | otherwise + = return Nothing lookupTcdName :: Maybe Name -> TyClDecl RdrName -> RnM (Located Name) -- Used for TyData and TySynonym only diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs index f405a0e..fc74b25 100644 --- a/compiler/rename/RnSource.lhs +++ b/compiler/rename/RnSource.lhs @@ -423,7 +423,7 @@ patchCCallTarget packageId callTarget rnSrcInstDecl :: InstDecl RdrName -> RnM (InstDecl Name, FreeVars) rnSrcInstDecl (InstDecl inst_ty mbinds uprags ats) -- Used for both source and interface file decls - = do { inst_ty' <- rnHsSigType (text "an instance decl") inst_ty + = do { inst_ty' <- rnLHsInstType (text "In an instance declaration") inst_ty ; let Just (inst_tyvars, _, L _ cls,_) = splitLHsInstDeclTy_maybe inst_ty' -- Rename the bindings @@ -507,7 +507,7 @@ rnSrcDerivDecl :: DerivDecl RdrName -> RnM (DerivDecl Name, FreeVars) rnSrcDerivDecl (DerivDecl ty) = do { standalone_deriv_ok <- xoptM Opt_StandaloneDeriving ; unless standalone_deriv_ok (addErr standaloneDerivErr) - ; ty' <- rnLHsType (text "In a deriving declaration") ty + ; ty' <- rnLHsInstType (text "In a deriving declaration") ty ; let fvs = extractHsTyNames ty' ; return (DerivDecl ty', fvs) } diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 770ef28..647beda 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -7,7 +7,7 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsSigType, rnHsTypeFVs, rnConDeclFields, + rnHsSigType, rnLHsInstType, rnHsTypeFVs, rnConDeclFields, rnIPName, -- Precence related stuff @@ -68,6 +68,21 @@ rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) -- which use *implicit* universal quantification. rnHsSigType doc_str ty = rnLHsType (text "In the type signature for" <+> doc_str) ty + +rnLHsInstType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +-- Rename the type in an instance or standalone deriving decl +rnLHsInstType doc_str ty + = do { ty' <- rnLHsType doc_str ty + ; unless good_inst_ty (addErrAt (getLoc ty) (badInstTy ty)) + ; return ty' } + where + good_inst_ty + | Just (_, _, L _ cls, _) <- splitLHsInstDeclTy_maybe ty + , isTcOcc (rdrNameOcc cls) = True + | otherwise = False + +badInstTy :: LHsType RdrName -> SDoc +badInstTy ty = ptext (sLit "Malformed instance:") <+> ppr ty \end{code} rnHsType is here because we call it from loadInstDecl, and I didn't _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
