module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
- rnHsSigType, rnHsTypeFVs,
-
- -- Patterns and literals
- rnLPat, rnPatsAndThen, -- Here because it's not part
- rnLit, rnOverLit, -- of any mutual recursion
- rnHsRecFields,
+ rnHsSigType, rnHsTypeFVs, rnConDeclFields,
-- Precence related stuff
- mkOpAppRn, mkNegAppRn, mkOpFormRn,
- checkPrecMatch, checkSectionPrec,
-
- -- Error messages
- patSigErr, checkTupSize
+ mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
+ 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, parrTyCon_name, tupleTyCon_name,
- listTyCon_name
- )
-import RnHsDoc ( rnLHsDoc )
-import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
- lookupLocatedOccRn, lookupLocatedBndrRn,
- lookupLocatedGlobalOccRn, bindTyVarsRn,
- lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
- lookupRecordBndr, mapFvRn, warnUnusedMatches,
- newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
+import RnHsSyn ( extractHsTyNames )
+import RnHsDoc ( rnLHsDoc, rnMbLHsDoc )
+import RnEnv
import TcRnMonad
import RdrName
-import PrelNames ( eqClassName, integralClassName, geName, eqName,
- negateName, minusName, lengthPName, indexPName,
- plusIntegerName, fromIntegerName, timesIntegerName,
- ratioDataConName, fromRationalName, fromStringName )
-import TypeRep ( funTyCon )
-import Constants ( mAX_TUPLE_SIZE )
+import PrelNames
+import TypeRep ( funTyConName )
import Name
import SrcLoc
import NameSet
-import Literal ( inIntRange, inCharRange )
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) )
-import ListSetOps ( removeDups, minusList )
import Outputable
+import FastString
+import Control.Monad ( unless )
#include "HsVersions.h"
\end{code}
\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,
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
-- 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_TypeOperators
- ; checkErr ty_ops_ok (opTyErr op ty)
- ; op' <- lookupOccRn op
+ do { ops_ok <- doptM 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)
+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)
- = 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 <- doptM Opt_KindSignatures
+ ; unless kind_sigs_ok (addErr (kindSigErr ty))
+ ; ty' <- rnLHsType doc ty
+ ; return (HsKindSig ty' k) }
-rnHsType doc (HsPArrTy ty)
- = rnLHsType doc ty `thenM` \ ty' ->
- returnM (HsPArrTy ty')
+rnHsType doc (HsPArrTy ty) = do
+ ty' <- rnLHsType doc ty
+ return (HsPArrTy 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
-- 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}
---------------
-- 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
-- (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
-- (- 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
= 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
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
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])
--------------------------------------
; 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
; return (ConPatIn op1 (InfixCon p11 (L loc new_p))) } -- XXX loc right?
else return (ConPatIn op2 (InfixCon p1 p2)) }
-mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment
+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
-- 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
-> 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_PatternSignatures `thenM` \ glaExts ->
-
- if glaExts
- then rnLPat pat `thenM` \ (pat', fvs1) ->
- rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) ->
- returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
+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))]
+ $$
+ doc)
- 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@(HsString s))
- = do { ovlStr <- doptM Opt_OverloadedStrings
- ; if ovlStr then rnPat (mkNPat (mkHsIsString s) Nothing)
- else do { rnLit lit; return (LitPat lit, emptyFVs) } } -- Same as below
-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)
- -- 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)
- -- 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)
-
-rnPat (PArrPat pats _)
- = rnLPats pats `thenM` \ (patslist, fvs) ->
- returnM (PArrPat patslist placeHolderType,
- fvs `plusFV` implicit_fvs)
- where
- implicit_fvs = mkFVs [lengthPName, indexPName]
-
-rnPat (TuplePat pats boxed _)
- = checkTupSize (length pats) `thenM_`
- rnLPats pats `thenM` \ (patslist, fvs) ->
- returnM (TuplePat patslist boxed placeHolderType, fvs)
-
-rnPat (TypePat name) =
- rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
- returnM (TypePat name', fvs)
-
--- -----------------------------------------------------------------------------
--- rnConPat
-
-rnConPat :: Located RdrName -> HsConPatDetails RdrName -> RnM (Pat Name, FreeVars)
-rnConPat con (PrefixCon pats)
- = do { con' <- lookupLocatedOccRn con
- ; (pats', fvs) <- rnLPats pats
- ; return (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') }
-
-rnConPat con (RecCon rpats)
- = do { con' <- lookupLocatedOccRn con
- ; (rpats', fvs) <- rnHsRecFields "pattern" (Just con') rnLPat VarPat rpats
- ; return (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') }
-
-rnConPat con (InfixCon pat1 pat2)
- = do { con' <- lookupLocatedOccRn con
- ; (pat1', fvs1) <- rnLPat pat1
- ; (pat2', fvs2) <- rnLPat pat2
- ; fixity <- lookupFixityRn (unLoc con')
- ; pat' <- mkConOpPatRn con' fixity pat1' pat2'
- ; return (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con') }
-
--- -----------------------------------------------------------------------------
-rnHsRecFields :: String -- "pattern" or "construction" or "update"
- -> Maybe (Located Name)
- -> (Located a -> RnM (Located b, FreeVars))
- -> (RdrName -> a) -- How to fill in ".."
- -> HsRecFields RdrName (Located a)
- -> RnM (HsRecFields Name (Located b), FreeVars)
--- Haddock comments for record fields are renamed to Nothing here
-rnHsRecFields str mb_con rn_thing mk_rhs (HsRecFields fields dd)
- = do { mappM_ field_dup_err dup_fields
- ; pun_flag <- doptM Opt_RecordPuns
- ; (fields1, fvs1) <- mapFvRn (rn_rpat pun_flag) fields
- ; case dd of
- Nothing -> return (HsRecFields fields1 dd, fvs1)
- Just n -> ASSERT( n == length fields ) do
- { dd_flag <- doptM Opt_RecordWildCards
- ; checkErr dd_flag (needFlagDotDot str)
-
- ; let fld_names1 = map (unLoc . hsRecFieldId) fields1
- ; (fields2, fvs2) <- dot_dot_fields fld_names1 mb_con
-
- ; return (HsRecFields (fields1 ++ fields2) dd, fvs1 `plusFV` fvs2) } }
+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 (map (unLoc . hsRecFieldId) fields)
-
- field_dup_err dups = addErr (dupFieldErr str (head dups))
-
- rn_rpat pun_ok (HsRecField field pat pun)
- = do { fieldname <- lookupRecordBndr mb_con field
- ; checkErr (not pun || pun_ok) (badPun field)
- ; (pat', fvs) <- rn_thing pat
- ; return (HsRecField fieldname pat' pun,
- fvs `addOneFV` unLoc fieldname) }
-
- dot_dot_fields fs Nothing = do { addErr (badDotDot str)
- ; return ([], emptyFVs) }
-
- -- Compute the extra fields to be filled in by the dot-dot notation
- dot_dot_fields fs (Just con)
- = do { con_fields <- lookupConstructorFields (unLoc con)
- ; let missing_fields = con_fields `minusList` fs
- ; loc <- getSrcSpanM -- Rather approximate
- ; (rhss, fvs_s) <- mapAndUnzipM rn_thing
- [ L loc (mk_rhs (mkRdrUnqual (getOccName f)))
- | f <- missing_fields ]
- ; let new_fs = [ HsRecField (L loc f) r False
- | (f, r) <- missing_fields `zip` rhss ]
- ; return (new_fs, plusFVs fvs_s) }
-
-needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str,
- ptext SLIT("Use -frecord-dot-dot to permit this")]
-
-badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str
-
-badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld),
- ptext SLIT("Use -frecord-puns to permit this")]
-\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)
-
-rnOverLit (HsIsString s _)
- = lookupSyntaxName fromStringName `thenM` \ (from_string_name, fvs) ->
- returnM (HsIsString s from_string_name, 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"))])
-
-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 -XTypeOperators to allow operators in types")))
+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.
-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 -XPatternSigs 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}
projects / ghc-hetmet.git / blobdiff