module RnTypes (
-- Type related stuff
rnHsType, rnLHsType, rnLHsTypes, rnContext,
- rnHsSigType, rnHsTypeFVs,
+ rnHsSigType, rnHsTypeFVs, rnConDeclFields, rnLPred,
-- 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 TysPrim ( funTyConName )
import Name
import SrcLoc
import NameSet
Fixity(..), FixityDirection(..) )
import Outputable
import FastString
+import Control.Monad ( unless )
#include "HsVersions.h"
\end{code}
-- Hence the jiggery pokery with ty1
rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
= setSrcSpan loc $
- do { ops_ok <- doptM Opt_TypeOperators
+ do { ops_ok <- xoptM Opt_TypeOperators
; op' <- if ops_ok
then lookupOccRn op
else do { addErr (opTyErr op ty)
; 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 _ (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")
-
+rnHsType doc (HsRecTy flds)
+ = do { flds' <- rnConDeclFields doc flds
+ ; return (HsRecTy flds') }
rnHsType doc (HsFunTy ty1 ty2) = do
ty1' <- rnLHsType doc ty1
-- 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 <- 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 (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) = do
pred' <- rnPred doc pred
return (HsPredTy pred')
-rnHsType _ (HsSpliceTy _) =
- failWith (ptext (sLit "Type splices are not yet implemented"))
+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
\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
-- 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}
%*********************************************************
---------------
-- 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
-- (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
---------------------------
-- (- 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
---------------------------
-- 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
)
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
-- (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
; 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
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
(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 ()
-> 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"))
+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),
+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))]
-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)
+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}
%*********************************************************
forAllWarn :: SDoc -> LHsType RdrName -> Located RdrName
-> TcRnIf TcGblEnv TcLclEnv ()
forAllWarn doc ty (L loc tyvar)
- = ifOptM Opt_WarnUnusedMatches $
+ = 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))]
$$
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")
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}
projects / ghc-hetmet.git / blobdiff