X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=b275d2df40350ae71e563080d718855d527978f2;hp=3de4345458f8eba2d9974f38223a3900a4164710;hb=1a9245caefb80a3c4c5965aaacdf9a607e792e1c;hpb=9b53ebc1b2da232ae682d155dbb524dc59559f59 diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 3de4345..b275d2d 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -7,23 +7,31 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsSigType, rnHsTypeFVs, + rnHsSigType, rnHsTypeFVs, rnConDeclFields, -- Precence related stuff mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, - checkPrecMatch, checkSectionPrec + checkPrecMatch, checkSectionPrec, + + -- Splice related stuff + rnSplice, checkTH ) where +import {-# SOURCE #-} RnExpr( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) +#endif /* GHCI */ + import DynFlags import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn ( extractHsTyNames ) -import RnHsDoc ( rnLHsDoc ) +import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) import RnEnv import TcRnMonad import RdrName import PrelNames -import TypeRep ( funTyCon ) +import TypeRep ( funTyConName ) import Name import SrcLoc import NameSet @@ -31,6 +39,8 @@ import NameSet import BasicTypes ( compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..) ) import Outputable +import FastString +import Control.Monad ( unless ) #include "HsVersions.h" \end{code} @@ -115,21 +125,25 @@ rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) ; fix <- lookupTyFixityRn l_op' ; ty1' <- rnLHsType doc ty1 ; ty2' <- rnLHsType doc ty2 - ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2' } + ; mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) op' fix ty1' ty2' } rnHsType doc (HsParTy ty) = do ty' <- rnLHsType doc ty return (HsParTy ty') -rnHsType doc (HsBangTy b ty) = do - ty' <- rnLHsType doc ty - return (HsBangTy b ty') +rnHsType doc (HsBangTy b ty) + = do { ty' <- rnLHsType doc ty + ; return (HsBangTy b ty') } + +rnHsType doc (HsRecTy flds) + = do { flds' <- rnConDeclFields doc flds + ; return (HsRecTy flds') } rnHsType _ (HsNumTy i) | i == 1 = return (HsNumTy i) | otherwise = addErr err_msg >> return (HsNumTy i) where - err_msg = ptext SLIT("Only unit numeric type pattern is valid") + err_msg = ptext (sLit "Only unit numeric type pattern is valid") rnHsType doc (HsFunTy ty1 ty2) = do @@ -140,15 +154,17 @@ rnHsType doc (HsFunTy ty1 ty2) = do -- when we find return :: forall m. Monad m -> forall a. a -> m a -- Check for fixity rearrangements - mkHsOpTyRn HsFunTy (ppr funTyCon) funTyFixity ty1' ty2' + mkHsOpTyRn HsFunTy funTyConName funTyFixity ty1' ty2' rnHsType doc (HsListTy ty) = do ty' <- rnLHsType doc ty return (HsListTy ty') -rnHsType doc (HsKindSig ty k) = do - ty' <- rnLHsType doc ty - return (HsKindSig ty' k) +rnHsType doc (HsKindSig ty k) + = do { kind_sigs_ok <- doptM Opt_KindSignatures + ; unless kind_sigs_ok (addErr (kindSigErr ty)) + ; ty' <- rnLHsType doc ty + ; return (HsKindSig ty' k) } rnHsType doc (HsPArrTy ty) = do ty' <- rnLHsType doc ty @@ -169,15 +185,24 @@ rnHsType doc (HsPredTy pred) = do pred' <- rnPred doc pred return (HsPredTy pred') -rnHsType _ (HsSpliceTy _) = do - addErr (ptext SLIT("Type splices are not yet implemented")) - failM +rnHsType _ (HsSpliceTy sp _ k) + = do { (sp', fvs) <- rnSplice sp -- ToDo: deal with fvs + ; return (HsSpliceTy sp' fvs k) } rnHsType doc (HsDocTy ty haddock_doc) = do ty' <- rnLHsType doc ty haddock_doc' <- rnLHsDoc haddock_doc return (HsDocTy ty' haddock_doc') +#ifndef GHCI +rnHsType _ ty@(HsQuasiQuoteTy _) = pprPanic "Can't do quasiquotation without GHCi" (ppr ty) +#else +rnHsType doc (HsQuasiQuoteTy qq) = do { ty <- runQuasiQuoteType qq + ; rnHsType doc (unLoc ty) } +#endif +rnHsType _ (HsCoreTy ty) = return (HsCoreTy ty) + +-------------- rnLHsTypes :: SDoc -> [LHsType RdrName] -> IOEnv (Env TcGblEnv TcLclEnv) [LHsType Name] rnLHsTypes doc tys = mapM (rnLHsType doc) tys @@ -185,7 +210,7 @@ rnLHsTypes doc tys = mapM (rnLHsType doc) tys \begin{code} -rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] +rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty @@ -198,12 +223,22 @@ rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- of kind *. rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> do + = bindTyVarsRn forall_tyvars $ \ new_tyvars -> do new_ctxt <- rnContext doc ctxt new_ty <- rnLHsType doc ty return (HsForAllTy exp new_tyvars new_ctxt new_ty) -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly + +rnConDeclFields :: SDoc -> [ConDeclField RdrName] -> RnM [ConDeclField Name] +rnConDeclFields doc fields = mapM (rnField doc) fields + +rnField :: SDoc -> ConDeclField RdrName -> RnM (ConDeclField Name) +rnField doc (ConDeclField name ty haddock_doc) + = do { new_name <- lookupLocatedTopBndrRn name + ; new_ty <- rnLHsType doc ty + ; new_haddock_doc <- rnMbLHsDoc haddock_doc + ; return (ConDeclField new_name new_ty new_haddock_doc) } \end{code} %********************************************************* @@ -270,36 +305,35 @@ by the presence of ->, which is a separate syntactic construct. --------------- -- Building (ty1 `op1` (ty21 `op2` ty22)) mkHsOpTyRn :: (LHsType Name -> LHsType Name -> HsType Name) - -> SDoc -> Fixity -> LHsType Name -> LHsType Name + -> Name -> Fixity -> LHsType Name -> LHsType Name -> RnM (HsType Name) mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsOpTy ty21 op2 ty22)) = do { fix2 <- lookupTyFixityRn op2 ; mk_hs_op_ty mk1 pp_op1 fix1 ty1 (\t1 t2 -> HsOpTy t1 op2 t2) - (ppr op2) fix2 ty21 ty22 loc2 } + (unLoc op2) fix2 ty21 ty22 loc2 } mkHsOpTyRn mk1 pp_op1 fix1 ty1 (L loc2 (HsFunTy ty21 ty22)) = mk_hs_op_ty mk1 pp_op1 fix1 ty1 - HsFunTy (ppr funTyCon) funTyFixity ty21 ty22 loc2 + HsFunTy funTyConName funTyFixity ty21 ty22 loc2 mkHsOpTyRn mk1 _ _ ty1 ty2 -- Default case, no rearrangment = return (mk1 ty1 ty2) --------------- mk_hs_op_ty :: (LHsType Name -> LHsType Name -> HsType Name) - -> SDoc -> Fixity -> LHsType Name + -> Name -> Fixity -> LHsType Name -> (LHsType Name -> LHsType Name -> HsType Name) - -> SDoc -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan + -> Name -> Fixity -> LHsType Name -> LHsType Name -> SrcSpan -> RnM (HsType Name) -mk_hs_op_ty mk1 pp_op1 fix1 ty1 - mk2 pp_op2 fix2 ty21 ty22 loc2 - | nofix_error = do { addErr (precParseErr (quotes pp_op1,fix1) - (quotes pp_op2,fix2)) +mk_hs_op_ty mk1 op1 fix1 ty1 + mk2 op2 fix2 ty21 ty22 loc2 + | nofix_error = do { precParseErr (op1,fix1) (op2,fix2) ; return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) } | associate_right = return (mk1 ty1 (L loc2 (mk2 ty21 ty22))) | otherwise = do { -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) - new_ty <- mkHsOpTyRn mk1 pp_op1 fix1 ty1 ty21 + new_ty <- mkHsOpTyRn mk1 op1 fix1 ty1 ty21 ; return (mk2 (noLoc new_ty) ty22) } where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -314,9 +348,9 @@ mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged -- (e11 `op1` e12) `op2` e2 mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 - | nofix_error = do - addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) - return (OpApp e1 op2 fix2 e2) + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (OpApp e1 op2 fix2 e2) | associate_right = do new_e <- mkOpAppRn e12 op2 fix2 e2 @@ -328,13 +362,13 @@ mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 --------------------------- -- (- neg_arg) `op` e2 mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 - | nofix_error = do - addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) - return (OpApp e1 op2 fix2 e2) + | nofix_error + = do precParseErr (negateName,negateFixity) (get_op op2,fix2) + return (OpApp e1 op2 fix2 e2) - | associate_right = do - new_e <- mkOpAppRn neg_arg op2 fix2 e2 - return (NegApp (L loc' new_e) neg_name) + | associate_right + = do new_e <- mkOpAppRn neg_arg op2 fix2 e2 + return (NegApp (L loc' new_e) neg_name) where loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 @@ -342,9 +376,9 @@ mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 --------------------------- -- e1 `op` - neg_arg mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right - | not associate_right= do -- We *want* right association - addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) - return (OpApp e1 op1 fix1 e2) + | not associate_right -- We *want* right association + = do precParseErr (get_op op1, fix1) (negateName, negateFixity) + return (OpApp e1 op1 fix1 e2) where (_, associate_right) = compareFixity fix1 negateFixity @@ -356,6 +390,11 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment ) return (OpApp e1 op fix e2) +---------------------------- +get_op :: LHsExpr Name -> Name +get_op (L _ (HsVar n)) = n +get_op other = pprPanic "get_op" (ppr other) + -- Parser left-associates everything, but -- derived instances may have correctly-associated things to -- in the right operarand. So we just check that the right operand is OK @@ -387,14 +426,14 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged -- (e11 `op1` e12) `op2` e2 mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) op2 fix2 a2 - | nofix_error = do - addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) - return (HsArrForm op2 (Just fix2) [a1, a2]) - - | associate_right = do - new_c <- mkOpFormRn a12 op2 fix2 a2 - return (HsArrForm op1 (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) + | nofix_error + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (HsArrForm op2 (Just fix2) [a1, a2]) + + | associate_right + = do new_c <- mkOpFormRn a12 op2 fix2 a2 + return (HsArrForm op1 (Just fix1) + [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -413,7 +452,7 @@ mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 ; let (nofix_error, associate_right) = compareFixity fix1 fix2 ; if nofix_error then do - { addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) + { precParseErr (unLoc op1,fix1) (unLoc op2,fix2) ; return (ConPatIn op2 (InfixCon p1 p2)) } else if associate_right then do @@ -430,18 +469,18 @@ not_op_pat (ConPatIn _ (InfixCon _ _)) = False not_op_pat _ = True -------------------------------------- -checkPrecMatch :: Bool -> Name -> MatchGroup Name -> RnM () - -- True indicates an infix lhs - -- See comments with rnExpr (OpApp ...) about "deriving" +checkPrecMatch :: Name -> MatchGroup Name -> RnM () + -- Check precedence of a function binding written infix + -- eg a `op` b `C` c = ... + -- See comments with rnExpr (OpApp ...) about "deriving" -checkPrecMatch False _ _ - = return () -checkPrecMatch True op (MatchGroup ms _) +checkPrecMatch op (MatchGroup ms _) = mapM_ check ms where - check (L _ (Match (p1:p2:_) _ _)) - = do checkPrec op (unLoc p1) False - checkPrec op (unLoc p2) True + check (L _ (Match (L l1 p1 : L l2 p2 :_) _ _)) + = setSrcSpan (combineSrcSpans l1 l2) $ + do checkPrec op p1 False + checkPrec op p2 True check _ = return () -- This can happen. Consider @@ -462,11 +501,10 @@ checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do (op1_dir == InfixR && op_dir == InfixR && right || op1_dir == InfixL && op_dir == InfixL && not right)) - info = (ppr_op op, op_fix) - info1 = (ppr_op op1, op1_fix) + info = (op, op_fix) + info1 = (unLoc op1, op1_fix) (infol, infor) = if right then (info, info1) else (info1, info) - - checkErr inf_ok (precParseErr infol infor) + unless inf_ok (precParseErr infol infor) checkPrec _ _ _ = return () @@ -479,41 +517,47 @@ checkSectionPrec :: FixityDirection -> HsExpr RdrName -> LHsExpr Name -> LHsExpr Name -> RnM () checkSectionPrec direction section op arg = case unLoc arg of - OpApp _ op fix _ -> go_for_it (ppr_op op) fix - NegApp _ _ -> go_for_it pp_prefix_minus negateFixity + OpApp _ op fix _ -> go_for_it (get_op op) fix + NegApp _ _ -> go_for_it negateName negateFixity _ -> return () where - L _ (HsVar op_name) = op - go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) = do + op_name = get_op op + go_for_it arg_op arg_fix@(Fixity arg_prec assoc) = do op_fix@(Fixity op_prec _) <- lookupFixityRn op_name - checkErr (op_prec < arg_prec - || op_prec == arg_prec && direction == assoc) - (sectionPrecErr (ppr_op op_name, op_fix) - (pp_arg_op, arg_fix) section) + unless (op_prec < arg_prec + || (op_prec == arg_prec && direction == assoc)) + (sectionPrecErr (op_name, op_fix) + (arg_op, arg_fix) section) \end{code} Precedence-related error messages \begin{code} -precParseErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> SDoc -precParseErr op1 op2 - = hang (ptext SLIT("precedence parsing error")) - 4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), +precParseErr :: (Name, Fixity) -> (Name, Fixity) -> RnM () +precParseErr op1@(n1,_) op2@(n2,_) + | isUnboundName n1 || isUnboundName n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ hang (ptext (sLit "Precedence parsing error")) + 4 (hsep [ptext (sLit "cannot mix"), ppr_opfix op1, ptext (sLit "and"), ppr_opfix op2, - ptext SLIT("in the same infix expression")]) - -sectionPrecErr :: (SDoc, Fixity) -> (SDoc, Fixity) -> HsExpr RdrName -> SDoc -sectionPrecErr op arg_op section - = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"), - nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op), - nest 4 (ptext SLIT("in the section:") <+> quotes (ppr section))] - -pp_prefix_minus :: SDoc -pp_prefix_minus = ptext SLIT("prefix `-'") -ppr_op :: Outputable a => a -> SDoc -ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name -ppr_opfix :: (SDoc, Fixity) -> SDoc -ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity) + ptext (sLit "in the same infix expression")]) + +sectionPrecErr :: (Name, Fixity) -> (Name, Fixity) -> HsExpr RdrName -> RnM () +sectionPrecErr op@(n1,_) arg_op@(n2,_) section + | isUnboundName n1 || isUnboundName n2 + = return () -- Avoid error cascade + | otherwise + = addErr $ vcat [ptext (sLit "The operator") <+> ppr_opfix op <+> ptext (sLit "of a section"), + nest 4 (sep [ptext (sLit "must have lower precedence than that of the operand,"), + nest 2 (ptext (sLit "namely") <+> ppr_opfix arg_op)]), + nest 4 (ptext (sLit "in the section:") <+> quotes (ppr section))] + +ppr_opfix :: (Name, Fixity) -> SDoc +ppr_opfix (op, fixity) = pp_op <+> brackets (ppr fixity) + where + pp_op | op == negateName = ptext (sLit "prefix `-'") + | otherwise = quotes (ppr op) \end{code} %********************************************************* @@ -527,23 +571,76 @@ forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName -> TcRnIf TcGblEnv TcLclEnv () forAllWarn doc ty (L loc tyvar) = ifOptM Opt_WarnUnusedMatches $ - addWarnAt loc (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), - nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] + addWarnAt loc (sep [ptext (sLit "The universally quantified type variable") <+> quotes (ppr tyvar), + nest 4 (ptext (sLit "does not appear in the type") <+> quotes (ppr ty))] $$ doc) opTyErr :: RdrName -> HsType RdrName -> SDoc opTyErr op ty@(HsOpTy ty1 _ _) - = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty)) + = hang (ptext (sLit "Illegal operator") <+> quotes (ppr op) <+> ptext (sLit "in type") <+> quotes (ppr ty)) 2 extra where extra | op == dot_tv_RDR && forall_head ty1 - = ptext SLIT("Perhaps you intended to use -XRankNTypes or similar flag") + = perhapsForallMsg | otherwise - = ptext SLIT("Use -XTypeOperators to allow operators in types") + = ptext (sLit "Use -XTypeOperators to allow operators in types") forall_head (L _ (HsTyVar tv)) = tv == forall_tv_RDR forall_head (L _ (HsAppTy ty _)) = forall_head ty forall_head _other = False opTyErr _ ty = pprPanic "opTyErr: Not an op" (ppr ty) \end{code} + +%********************************************************* +%* * + Splices +%* * +%********************************************************* + +Note [Splices] +~~~~~~~~~~~~~~ +Consider + f = ... + h = ...$(thing "f")... + +The splice can expand into literally anything, so when we do dependency +analysis we must assume that it might mention 'f'. So we simply treat +all locally-defined names as mentioned by any splice. This is terribly +brutal, but I don't see what else to do. For example, it'll mean +that every locally-defined thing will appear to be used, so no unused-binding +warnings. But if we miss the dependency, then we might typecheck 'h' before 'f', +and that will crash the type checker because 'f' isn't in scope. + +Currently, I'm not treating a splice as also mentioning every import, +which is a bit inconsistent -- but there are a lot of them. We might +thereby get some bogus unused-import warnings, but we won't crash the +type checker. Not very satisfactory really. + +\begin{code} +rnSplice :: HsSplice RdrName -> RnM (HsSplice Name, FreeVars) +rnSplice (HsSplice n expr) + = do { checkTH expr "splice" + ; loc <- getSrcSpanM + ; n' <- newLocalBndrRn (L loc n) + ; (expr', fvs) <- rnLExpr expr + + -- Ugh! See Note [Splices] above + ; lcl_rdr <- getLocalRdrEnv + ; gbl_rdr <- getGlobalRdrEnv + ; let gbl_names = mkNameSet [gre_name gre | gre <- globalRdrEnvElts gbl_rdr, + isLocalGRE gre] + lcl_names = mkNameSet (occEnvElts lcl_rdr) + + ; return (HsSplice n' expr', fvs `plusFV` lcl_names `plusFV` gbl_names) } + +checkTH :: Outputable a => a -> String -> RnM () +#ifdef GHCI +checkTH _ _ = return () -- OK +#else +checkTH e what -- Raise an error in a stage-1 compiler + = addErr (vcat [ptext (sLit "Template Haskell") <+> text what <+> + ptext (sLit "illegal in a stage-1 compiler"), + nest 2 (ppr e)]) +#endif +\end{code}