X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=31382c20a36e0f1afd540242dbff2fb25915b031;hp=8dbf8878b37f0c84177718a02431d909f15b768b;hb=b2524b3960999fffdb3767900f58825903f6560f;hpb=654a1ba16e47d3ddabeb74b809ee6097c0770d35 diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index 8dbf887..31382c2 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -7,51 +7,40 @@ module RnTypes ( -- Type related stuff rnHsType, rnLHsType, rnLHsTypes, rnContext, - rnHsSigType, rnHsTypeFVs, - - -- Patterns and literals - rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part - rnLit, rnOverLit, -- of any mutual recursion + rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred, -- Precence related stuff - mkOpAppRn, mkNegAppRn, mkOpFormRn, - checkPrecMatch, checkSectionPrec, - - -- Error messages - dupFieldErr, patSigErr, checkTupSize + mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn, + checkPrecMatch, checkSectionPrec, + + -- Splice related stuff + rnSplice, checkTH ) where -import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts, Opt_ScopedTypeVariables ) ) +import {-# SOURCE #-} RnExpr( rnLExpr ) +#ifdef GHCI +import {-# SOURCE #-} TcSplice( runQuasiQuoteType ) +#endif /* GHCI */ +import DynFlags import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) -import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, - listTyCon_name - ) -import RnHsDoc ( rnLHsDoc ) -import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, - lookupLocatedOccRn, lookupLocatedBndrRn, - lookupLocatedGlobalOccRn, bindTyVarsRn, - lookupFixityRn, lookupTyFixityRn, - mapFvRn, warnUnusedMatches, - newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) +import RnHsSyn ( extractHsTyNames ) +import RnHsDoc ( rnLHsDoc, rnMbLHsDoc ) +import RnEnv import TcRnMonad -import RdrName ( RdrName, elemLocalRdrEnv ) -import PrelNames ( eqClassName, integralClassName, geName, eqName, - negateName, minusName, lengthPName, indexPName, - plusIntegerName, fromIntegerName, timesIntegerName, - ratioDataConName, fromRationalName ) -import TypeRep ( funTyCon ) -import Constants ( mAX_TUPLE_SIZE ) -import Name ( Name ) -import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs ) +import RdrName +import PrelNames +import TysPrim ( funTyConName ) +import Name +import SrcLoc import NameSet -import Literal ( inIntRange, inCharRange ) import BasicTypes ( compareFixity, funTyFixity, negateFixity, Fixity(..), FixityDirection(..) ) -import ListSetOps ( removeDups ) import Outputable +import FastString +import Control.Monad ( unless ) #include "HsVersions.h" \end{code} @@ -67,9 +56,9 @@ to break several loop. \begin{code} rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) -rnHsTypeFVs doc_str ty - = rnLHsType doc_str ty `thenM` \ ty' -> - returnM (ty', extractHsTyNames ty') +rnHsTypeFVs doc_str ty = do + ty' <- rnLHsType doc_str ty + return (ty', extractHsTyNames ty') rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) -- rnHsSigType is used for source-language type signatures, @@ -87,11 +76,11 @@ rnLHsType doc = wrapLocM (rnHsType doc) rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name) -rnHsType doc (HsForAllTy Implicit _ ctxt ty) +rnHsType doc (HsForAllTy Implicit _ ctxt ty) = do -- Implicit quantifiction in source code (no kinds on tyvars) -- Given the signature C => T we universally quantify -- over FV(T) \ {in-scope-tyvars} - = getLocalRdrEnv `thenM` \ name_env -> + name_env <- getLocalRdrEnv let mentioned = extractHsRhoRdrTyVars ctxt ty @@ -101,108 +90,128 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) -- class C a where { op :: a -> a } forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned tyvar_bndrs = userHsTyVarBndrs forall_tyvars - in + rnForAll doc Implicit tyvar_bndrs ctxt ty -rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) +rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) = do -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not - = let + let mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau) forall_tyvar_names = hsLTyVarLocNames forall_tyvars -- Explicitly quantified but not mentioned in ctxt or tau warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names - in - mappM_ (forAllWarn doc tau) warn_guys `thenM_` + + mapM_ (forAllWarn doc tau) warn_guys rnForAll doc Explicit forall_tyvars ctxt tau -rnHsType doc (HsTyVar tyvar) - = lookupOccRn tyvar `thenM` \ tyvar' -> - returnM (HsTyVar tyvar') +rnHsType _ (HsTyVar tyvar) = do + tyvar' <- lookupOccRn tyvar + return (HsTyVar tyvar') +-- If we see (forall a . ty), without foralls on, the forall will give +-- a sensible error message, but we don't want to complain about the dot too +-- Hence the jiggery pokery with ty1 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2) = setSrcSpan loc $ - do { ty_ops_ok <- doptM Opt_ScopedTypeVariables -- Badly named option - ; checkErr ty_ops_ok (opTyErr op ty) - ; op' <- lookupOccRn op + do { ops_ok <- xoptM Opt_TypeOperators + ; op' <- if ops_ok + then lookupOccRn op + else do { addErr (opTyErr op ty) + ; return (mkUnboundName op) } -- Avoid double complaint ; let l_op' = L loc op' ; 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) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsParTy ty') +rnHsType doc (HsParTy ty) = do + ty' <- rnLHsType doc ty + return (HsParTy ty') rnHsType doc (HsBangTy b ty) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsBangTy b ty') + = do { ty' <- rnLHsType doc ty + ; return (HsBangTy b ty') } -rnHsType doc (HsNumTy i) - | i == 1 = returnM (HsNumTy i) - | otherwise = addErr err_msg `thenM_` returnM (HsNumTy i) - where - err_msg = ptext SLIT("Only unit numeric type pattern is valid") - +rnHsType doc (HsRecTy flds) + = do { flds' <- rnConDeclFields doc flds + ; return (HsRecTy flds') } -rnHsType doc (HsFunTy ty1 ty2) - = rnLHsType doc ty1 `thenM` \ ty1' -> +rnHsType doc (HsFunTy ty1 ty2) = do + ty1' <- rnLHsType doc ty1 -- Might find a for-all as the arg of a function type - rnLHsType doc ty2 `thenM` \ ty2' -> + ty2' <- rnLHsType doc ty2 -- Or as the result. This happens when reading Prelude.hi -- 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) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsListTy ty') +rnHsType doc (HsListTy ty) = do + ty' <- rnLHsType doc ty + return (HsListTy ty') rnHsType doc (HsKindSig ty k) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsKindSig ty' k) + = do { kind_sigs_ok <- xoptM 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 + return (HsPArrTy ty') -rnHsType doc (HsPArrTy ty) - = rnLHsType doc ty `thenM` \ ty' -> - returnM (HsPArrTy ty') +rnHsType doc (HsModalBoxType ecn ty) = do + ecn' <- lookupOccRn ecn + ty' <- rnLHsType doc ty + return (HsModalBoxType ecn' ty') -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. -rnHsType doc (HsTupleTy tup_con tys) - = mappM (rnLHsType doc) tys `thenM` \ tys' -> - returnM (HsTupleTy tup_con tys') - -rnHsType doc (HsAppTy ty1 ty2) - = rnLHsType doc ty1 `thenM` \ ty1' -> - rnLHsType doc ty2 `thenM` \ ty2' -> - returnM (HsAppTy ty1' ty2') - -rnHsType doc (HsPredTy pred) - = rnPred doc pred `thenM` \ pred' -> - returnM (HsPredTy pred') - -rnHsType doc (HsSpliceTy _) - = do { addErr (ptext SLIT("Type splices are not yet implemented")) - ; failM } - -rnHsType doc (HsDocTy ty haddock_doc) - = rnLHsType doc ty `thenM` \ ty' -> - rnLHsDoc haddock_doc `thenM` \ haddock_doc' -> - returnM (HsDocTy ty' haddock_doc') - -rnLHsTypes doc tys = mappM (rnLHsType doc) tys +rnHsType doc (HsTupleTy tup_con tys) = do + tys' <- mapM (rnLHsType doc) tys + return (HsTupleTy tup_con tys') + +rnHsType doc (HsAppTy ty1 ty2) = do + ty1' <- rnLHsType doc ty1 + ty2' <- rnLHsType doc ty2 + return (HsAppTy ty1' ty2') + +rnHsType doc (HsPredTy pred) = do + pred' <- rnPred doc pred + return (HsPredTy pred') + +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 \end{code} \begin{code} -rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] +rnForAll :: SDoc -> HsExplicitFlag -> [LHsTyVarBndr RdrName] -> LHsContext RdrName -> LHsType RdrName -> RnM (HsType Name) -rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty +rnForAll doc _ [] (L _ []) (L _ ty) = rnHsType doc ty -- One reason for this case is that a type like Int# -- starts off as (HsForAllTy Nothing [] Int), in case -- there is some quantification. Now that we have quantified @@ -212,12 +221,57 @@ rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty -- of kind *. rnForAll doc exp forall_tyvars ctxt ty - = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> - rnContext doc ctxt `thenM` \ new_ctxt -> - rnLHsType doc ty `thenM` \ new_ty -> - returnM (HsForAllTy exp new_tyvars new_ctxt new_ty) + = 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} + +%********************************************************* +%* * +\subsection{Contexts and predicates} +%* * +%********************************************************* + +\begin{code} +rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) +rnContext doc = wrapLocM (rnContext' doc) + +rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) +rnContext' doc ctxt = mapM (rnLPred doc) ctxt + +rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) +rnLPred doc = wrapLocM (rnPred doc) + +rnPred :: SDoc -> HsPred RdrName + -> IOEnv (Env TcGblEnv TcLclEnv) (HsPred Name) +rnPred doc (HsClassP clas tys) + = do { clas_name <- lookupOccRn clas + ; tys' <- rnLHsTypes doc tys + ; return (HsClassP clas_name tys') + } +rnPred doc (HsEqualP ty1 ty2) + = do { ty1' <- rnLHsType doc ty1 + ; ty2' <- rnLHsType doc ty2 + ; return (HsEqualP ty1' ty2') + } +rnPred doc (HsIParam n ty) + = do { name <- newIPNameRn n + ; ty' <- rnLHsType doc ty + ; return (HsIParam name ty') + } \end{code} @@ -249,36 +303,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 ty2@(L loc2 (HsFunTy ty21 ty22)) +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 pp_op1 fix1 ty1 ty2 -- Default case, no rearrangment +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 @@ -294,12 +347,12 @@ 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 - = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (OpApp e1 op2 fix2 e2) + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (OpApp e1 op2 fix2 e2) - | associate_right - = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> - returnM (OpApp e11 op1 fix1 (L loc' new_e)) + | associate_right = do + new_e <- mkOpAppRn e12 op2 fix2 e2 + return (OpApp e11 op1 fix1 (L loc' new_e)) where loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 @@ -308,22 +361,22 @@ 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 - = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` - returnM (OpApp e1 op2 fix2 e2) + = do precParseErr (negateName,negateFixity) (get_op op2,fix2) + return (OpApp e1 op2 fix2 e2) - | associate_right - = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> - returnM (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 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right - | not associate_right -- We *want* right association - = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` - returnM (OpApp e1 op1 fix1 e2) +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp _ _)) -- NegApp can occur on the right + | 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 @@ -333,16 +386,22 @@ mkOpAppRn e1 op fix e2 -- Default case, no rearrangment = ASSERT2( right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) - returnM (OpApp e1 op fix e2) + 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 +right_op_ok :: Fixity -> HsExpr Name -> Bool right_op_ok fix1 (OpApp _ _ fix2 _) = not error_please && associate_right where (error_please, associate_right) = compareFixity fix1 fix2 -right_op_ok fix1 other +right_op_ok _ _ = True -- Parser initially makes negation bind more tightly than any other operator @@ -350,10 +409,11 @@ right_op_ok fix1 other mkNegAppRn :: LHsExpr id -> SyntaxExpr id -> RnM (HsExpr id) mkNegAppRn neg_arg neg_name = ASSERT( not_op_app (unLoc neg_arg) ) - returnM (NegApp neg_arg neg_name) + return (NegApp neg_arg neg_name) +not_op_app :: HsExpr id -> Bool not_op_app (OpApp _ _ _ _) = False -not_op_app other = True +not_op_app _ = True --------------------------- mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged @@ -365,20 +425,20 @@ mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) op2 fix2 a2 | nofix_error - = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (HsArrForm op2 (Just fix2) [a1, a2]) + = do precParseErr (get_op op1,fix1) (get_op op2,fix2) + return (HsArrForm op2 (Just fix2) [a1, a2]) | associate_right - = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c -> - returnM (HsArrForm op1 (Just fix1) - [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) + = 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 -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = returnM (HsArrForm op (Just fix) [arg1, arg2]) + = return (HsArrForm op (Just fix) [arg1, arg2]) -------------------------------------- @@ -386,40 +446,39 @@ mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name -> RnM (Pat Name) mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 - = lookupFixityRn (unLoc op1) `thenM` \ fix1 -> - let - (nofix_error, associate_right) = compareFixity fix1 fix2 - in - if nofix_error then - addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (ConPatIn op2 (InfixCon p1 p2)) - else - if associate_right then - mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> - returnM (ConPatIn op1 (InfixCon p11 (L loc new_p))) -- XXX loc right? - else - returnM (ConPatIn op2 (InfixCon p1 p2)) - -mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment + = do { fix1 <- lookupFixityRn (unLoc op1) + ; let (nofix_error, associate_right) = compareFixity fix1 fix2 + + ; if nofix_error then do + { precParseErr (unLoc op1,fix1) (unLoc op2,fix2) + ; return (ConPatIn op2 (InfixCon p1 p2)) } + + else if associate_right then do + { new_p <- mkConOpPatRn op2 fix2 p12 p2 + ; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right? + else return (ConPatIn op2 (InfixCon p1 p2)) } + +mkConOpPatRn op _ p1 p2 -- Default case, no rearrangment = ASSERT( not_op_pat (unLoc p2) ) - returnM (ConPatIn op (InfixCon p1 p2)) + return (ConPatIn op (InfixCon p1 p2)) +not_op_pat :: Pat Name -> Bool not_op_pat (ConPatIn _ (InfixCon _ _)) = False -not_op_pat other = True +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 fn match - = returnM () -checkPrecMatch True op (MatchGroup ms _) +checkPrecMatch op (MatchGroup ms _) = mapM_ check ms where - check (L _ (Match (p1:p2:_) _ _)) - = checkPrec op (unLoc p1) False `thenM_` - 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 @@ -430,23 +489,23 @@ checkPrecMatch True op (MatchGroup ms _) -- until the type checker). So we don't want to crash on the -- second eqn. -checkPrec op (ConPatIn op1 (InfixCon _ _)) right - = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> +checkPrec :: Name -> Pat Name -> Bool -> IOEnv (Env TcGblEnv TcLclEnv) () +checkPrec op (ConPatIn op1 (InfixCon _ _)) right = do + op_fix@(Fixity op_prec op_dir) <- lookupFixityRn op + op1_fix@(Fixity op1_prec op1_dir) <- lookupFixityRn (unLoc op1) let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && (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) - in - checkErr inf_ok (precParseErr infol infor) + unless inf_ok (precParseErr infol infor) -checkPrec op pat right - = returnM () +checkPrec _ _ _ + = return () -- Check precedence of (arg op) or (op arg) respectively -- If arg is itself an operator application, then either @@ -456,331 +515,130 @@ 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 - other -> returnM () + 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) - = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> - checkErr (op_prec < arg_prec - || op_prec == arg_prec && direction == assoc) - (sectionPrecErr (ppr_op op_name, op_fix) - (pp_arg_op, arg_fix) section) + 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 + 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 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 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 = ptext SLIT("prefix `-'") -ppr_op op = quotes (ppr op) -- Here, op can be a Name or a (Var n), where n is a Name -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} %********************************************************* %* * -\subsection{Contexts and predicates} +\subsection{Errors} %* * %********************************************************* \begin{code} -rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) -rnContext doc = wrapLocM (rnContext' doc) - -rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) -rnContext' doc ctxt = mappM (rnLPred doc) ctxt - -rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) -rnLPred doc = wrapLocM (rnPred doc) - -rnPred doc (HsClassP clas tys) - = do { clas_name <- lookupOccRn clas - ; tys' <- rnLHsTypes doc tys - ; returnM (HsClassP clas_name tys') - } -rnPred doc (HsEqualP ty1 ty2) - = do { ty1' <- rnLHsType doc ty1 - ; ty2' <- rnLHsType doc ty2 - ; returnM (HsEqualP ty1' ty2') - } -rnPred doc (HsIParam n ty) - = do { name <- newIPNameRn n - ; ty' <- rnLHsType doc ty - ; returnM (HsIParam name ty') - } -\end{code} - - -********************************************************* -* * -\subsection{Patterns} -* * -********************************************************* - -\begin{code} -rnPatsAndThen :: HsMatchContext Name - -> [LPat RdrName] - -> ([LPat Name] -> RnM (a, FreeVars)) - -> RnM (a, FreeVars) --- Bring into scope all the binders and type variables --- bound by the patterns; then rename the patterns; then --- do the thing inside. --- --- Note that we do a single bindLocalsRn for all the --- matches together, so that we spot the repeated variable in --- f x x = 1 - -rnPatsAndThen ctxt pats thing_inside - = bindPatSigTyVarsFV pat_sig_tys $ - bindLocatedLocalsFV doc_pat bndrs $ \ new_bndrs -> - rnLPats pats `thenM` \ (pats', pat_fvs) -> - thing_inside pats' `thenM` \ (res, res_fvs) -> - let - unused_binders = filter (not . (`elemNameSet` res_fvs)) new_bndrs - in - warnUnusedMatches unused_binders `thenM_` - returnM (res, res_fvs `plusFV` pat_fvs) - where - pat_sig_tys = collectSigTysFromPats pats - bndrs = collectLocatedPatsBinders pats - doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt - -rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars) -rnLPats ps = mapFvRn rnLPat ps - -rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars) -rnLPat = wrapLocFstM rnPat - --- ----------------------------------------------------------------------------- --- rnPat - -rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars) - -rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) - -rnPat (VarPat name) - = lookupBndrRn name `thenM` \ vname -> - returnM (VarPat vname, emptyFVs) - -rnPat (SigPatIn pat ty) - = doptM Opt_GlasgowExts `thenM` \ glaExts -> - - if glaExts - then rnLPat pat `thenM` \ (pat', fvs1) -> - rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) -> - returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2) - - else addErr (patSigErr ty) `thenM_` - rnPat (unLoc pat) -- XXX shouldn't throw away the loc - where - doc = text "In a pattern type-signature" - -rnPat (LitPat lit) - = rnLit lit `thenM_` - returnM (LitPat lit, emptyFVs) - -rnPat (NPat lit mb_neg eq _) - = rnOverLit lit `thenM` \ (lit', fvs1) -> - (case mb_neg of - Nothing -> returnM (Nothing, emptyFVs) - Just _ -> lookupSyntaxName negateName `thenM` \ (neg, fvs) -> - returnM (Just neg, fvs) - ) `thenM` \ (mb_neg', fvs2) -> - lookupSyntaxName eqName `thenM` \ (eq', fvs3) -> - returnM (NPat lit' mb_neg' eq' placeHolderType, - fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName) - -- Needed to find equality on pattern - -rnPat (NPlusKPat name lit _ _) - = rnOverLit lit `thenM` \ (lit', fvs1) -> - lookupLocatedBndrRn name `thenM` \ name' -> - lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> - lookupSyntaxName geName `thenM` \ (ge, fvs3) -> - returnM (NPlusKPat name' lit' ge minus, - fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName) - -- The Report says that n+k patterns must be in Integral - -rnPat (LazyPat pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - returnM (LazyPat pat', fvs) - -rnPat (BangPat pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - returnM (BangPat pat', fvs) - -rnPat (AsPat name pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - lookupLocatedBndrRn name `thenM` \ vname -> - returnM (AsPat vname pat', fvs) - -rnPat (ConPatIn con stuff) = rnConPat con stuff - - -rnPat (ParPat pat) - = rnLPat pat `thenM` \ (pat', fvs) -> - returnM (ParPat pat', fvs) - -rnPat (ListPat pats _) - = rnLPats pats `thenM` \ (patslist, fvs) -> - returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name) - -rnPat (PArrPat pats _) - = rnLPats pats `thenM` \ (patslist, fvs) -> - returnM (PArrPat patslist placeHolderType, - fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) - where - implicit_fvs = mkFVs [lengthPName, indexPName] +forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName + -> TcRnIf TcGblEnv TcLclEnv () +forAllWarn doc ty (L loc tyvar) + = ifDOptM 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))] + $$ + doc) -rnPat (TuplePat pats boxed _) - = checkTupSize tup_size `thenM_` - rnLPats pats `thenM` \ (patslist, fvs) -> - returnM (TuplePat patslist boxed placeHolderType, - fvs `addOneFV` tycon_name) - where - tup_size = length pats - tycon_name = tupleTyCon_name boxed tup_size - -rnPat (TypePat name) = - rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> - returnM (TypePat name', fvs) - --- ----------------------------------------------------------------------------- --- rnConPat - -rnConPat con (PrefixCon pats) - = lookupLocatedOccRn con `thenM` \ con' -> - rnLPats pats `thenM` \ (pats', fvs) -> - returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') - -rnConPat con (RecCon rpats) - = lookupLocatedOccRn con `thenM` \ con' -> - rnRpats rpats `thenM` \ (rpats', fvs) -> - returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') - -rnConPat con (InfixCon pat1 pat2) - = lookupLocatedOccRn con `thenM` \ con' -> - rnLPat pat1 `thenM` \ (pat1', fvs1) -> - rnLPat pat2 `thenM` \ (pat2', fvs2) -> - lookupFixityRn (unLoc con') `thenM` \ fixity -> - mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' -> - returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con') - --- ----------------------------------------------------------------------------- --- rnRpats - --- Haddock comments for record fields are renamed to Nothing here -rnRpats :: [HsRecField RdrName (LPat RdrName)] - -> RnM ([HsRecField Name (LPat Name)], FreeVars) -rnRpats rpats - = mappM_ field_dup_err dup_fields `thenM_` - mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) -> - returnM (rpats', fvs) +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)) + 2 extra where - (_, dup_fields) = removeDups compare [ unLoc f | HsRecField f _ _ <- rpats ] - - field_dup_err dups = addErr (dupFieldErr "pattern" dups) - - rn_rpat (HsRecField field pat _) - = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> - rnLPat pat `thenM` \ (pat', fvs) -> - returnM ((mkRecField fieldname pat'), fvs `addOneFV` unLoc fieldname) - -\end{code} - - -%************************************************************************ -%* * -\subsubsection{Literals} -%* * -%************************************************************************ - -When literals occur we have to make sure -that the types and classes they involve -are made available. - -\begin{code} -rnLit :: HsLit -> RnM () -rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) -rnLit other = returnM () - -rnOverLit (HsIntegral i _) - = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> - if inIntRange i then - returnM (HsIntegral i from_integer_name, fvs) - else let - extra_fvs = mkFVs [plusIntegerName, timesIntegerName] - -- Big integer literals are built, using + and *, - -- out of small integers (DsUtils.mkIntegerLit) - -- [NB: plusInteger, timesInteger aren't rebindable... - -- they are used to construct the argument to fromInteger, - -- which is the rebindable one.] - in - returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs) - -rnOverLit (HsFractional i _) - = lookupSyntaxName fromRationalName `thenM` \ (from_rat_name, fvs) -> - let - extra_fvs = mkFVs [ratioDataConName, plusIntegerName, timesIntegerName] - -- We have to make sure that the Ratio type is imported with - -- its constructor, because literals of type Ratio t are - -- built with that constructor. - -- The Rational type is needed too, but that will come in - -- as part of the type for fromRational. - -- The plus/times integer operations may be needed to construct the numerator - -- and denominator (see DsUtils.mkIntegerLit) - in - returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs) + extra | op == dot_tv_RDR && forall_head ty1 + = perhapsForallMsg + | otherwise + = 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} - - %********************************************************* %* * -\subsection{Errors} + Splices %* * %********************************************************* -\begin{code} -checkTupSize :: Int -> RnM () -checkTupSize tup_size - | tup_size <= mAX_TUPLE_SIZE - = returnM () - | otherwise - = addErr (sep [ptext SLIT("A") <+> int tup_size <> ptext SLIT("-tuple is too large for GHC"), - nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)), - nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))]) +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. -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))] - $$ - doc) - -opTyErr op ty - = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty)) - 2 (parens (ptext SLIT("Use -fscoped-type-variables to allow operators in types"))) - -bogusCharError c - = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' - -patSigErr ty - = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) - $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it")) - -dupFieldErr str dup - = hsep [ptext SLIT("duplicate field name"), - quotes (ppr dup), - ptext SLIT("in record"), text str] +\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}