rnHsSigType, rnHsTypeFVs,
-- Patterns and literals
- rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part
+ rnLPat, rnPatsAndThen, -- Here because it's not part
rnLit, rnOverLit, -- of any mutual recursion
+ rnHsRecFields,
-- Precence related stuff
mkOpAppRn, mkNegAppRn, mkOpFormRn,
checkPrecMatch, checkSectionPrec,
-- Error messages
- dupFieldErr, patSigErr, checkTupSize
+ patSigErr, checkTupSize
) where
-import DynFlags ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) )
-
+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,
+ lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
+ lookupRecordBndr, mapFvRn, warnUnusedMatches,
newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
import TcRnMonad
-import RdrName ( RdrName, elemLocalRdrEnv )
+import RdrName
import PrelNames ( eqClassName, integralClassName, geName, eqName,
negateName, minusName, lengthPName, indexPName,
plusIntegerName, fromIntegerName, timesIntegerName,
- ratioDataConName, fromRationalName )
+ ratioDataConName, fromRationalName, fromStringName )
import TypeRep ( funTyCon )
import Constants ( mAX_TUPLE_SIZE )
-import Name ( Name )
-import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc, combineLocs )
+import Name
+import SrcLoc
import NameSet
import Literal ( inIntRange, inCharRange )
import BasicTypes ( compareFixity, funTyFixity, negateFixity,
Fixity(..), FixityDirection(..) )
-import ListSetOps ( removeDups )
+import ListSetOps ( removeDups, minusList )
import Outputable
#include "HsVersions.h"
= lookupOccRn tyvar `thenM` \ tyvar' ->
returnM (HsTyVar tyvar')
-rnHsType doc (HsOpTy ty1 (L loc op) ty2)
- = setSrcSpan loc (
- lookupOccRn op `thenM` \ op' ->
- let
- l_op' = L loc op'
- in
- lookupTyFixityRn l_op' `thenM` \ fix ->
- rnLHsType doc ty1 `thenM` \ ty1' ->
- rnLHsType doc ty2 `thenM` \ ty2' ->
- mkHsOpTyRn (\t1 t2 -> HsOpTy t1 l_op' t2) (ppr op') fix ty1' ty2'
- )
+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
+ ; 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' }
rnHsType doc (HsParTy ty)
= rnLHsType doc ty `thenM` \ ty' ->
= 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
\end{code}
-> 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))
+ = do { fix1 <- lookupFixityRn (unLoc op1)
+ ; let (nofix_error, associate_right) = compareFixity fix1 fix2
+
+ ; if nofix_error then do
+ { addErr (precParseErr (ppr_op op1,fix1) (ppr_op 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 fix p1 p2 -- Default case, no rearrangment
= ASSERT( not_op_pat (unLoc p2) )
rnLPred doc = wrapLocM (rnPred doc)
rnPred doc (HsClassP clas tys)
- = lookupOccRn clas `thenM` \ clas_name ->
- rnLHsTypes doc tys `thenM` \ tys' ->
- returnM (HsClassP clas_name 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)
- = newIPNameRn n `thenM` \ name ->
- rnLHsType doc ty `thenM` \ ty' ->
- returnM (HsIParam name ty')
+ = do { name <- newIPNameRn n
+ ; ty' <- rnLHsType doc ty
+ ; returnM (HsIParam name ty')
+ }
\end{code}
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
returnM (VarPat vname, emptyFVs)
rnPat (SigPatIn pat ty)
- = doptM Opt_GlasgowExts `thenM` \ glaExts ->
+ = doptM Opt_PatternSignatures `thenM` \ glaExts ->
if glaExts
then rnLPat pat `thenM` \ (pat', fvs1) ->
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)
) `thenM` \ (mb_neg', fvs2) ->
lookupSyntaxName eqName `thenM` \ (eq', fvs3) ->
returnM (NPat lit' mb_neg' eq' placeHolderType,
- fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)
+ fvs1 `plusFV` fvs2 `plusFV` fvs3)
-- Needed to find equality on pattern
rnPat (NPlusKPat name lit _ _)
lookupSyntaxName minusName `thenM` \ (minus, fvs2) ->
lookupSyntaxName geName `thenM` \ (ge, fvs3) ->
returnM (NPlusKPat name' lit' ge minus,
- fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
+ fvs1 `plusFV` fvs2 `plusFV` fvs3)
-- The Report says that n+k patterns must be in Integral
rnPat (LazyPat pat)
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)
+ returnM (ListPat patslist placeHolderType, fvs)
rnPat (PArrPat pats _)
= rnLPats pats `thenM` \ (patslist, fvs) ->
returnM (PArrPat patslist placeHolderType,
- fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
+ fvs `plusFV` implicit_fvs)
where
implicit_fvs = mkFVs [lengthPName, indexPName]
rnPat (TuplePat pats boxed _)
- = checkTupSize tup_size `thenM_`
+ = checkTupSize (length pats) `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
+ returnM (TuplePat patslist boxed placeHolderType, fvs)
rnPat (TypePat name) =
rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
-- -----------------------------------------------------------------------------
-- rnConPat
+rnConPat :: Located RdrName -> HsConPatDetails RdrName -> RnM (Pat Name, FreeVars)
rnConPat con (PrefixCon pats)
- = lookupLocatedOccRn con `thenM` \ con' ->
- rnLPats pats `thenM` \ (pats', fvs) ->
- returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con')
+ = do { con' <- lookupLocatedOccRn con
+ ; (pats', fvs) <- rnLPats pats
+ ; return (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')
+ = 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)
- = 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')
+ = 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') }
-- -----------------------------------------------------------------------------
--- rnRpats
-
-rnRpats :: [(Located RdrName, LPat RdrName)]
- -> RnM ([(Located Name, LPat Name)], FreeVars)
-rnRpats rpats
- = mappM_ field_dup_err dup_fields `thenM_`
- mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) ->
- returnM (rpats', fvs)
+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) } }
where
- (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ]
-
- field_dup_err dups = addErr (dupFieldErr "pattern" dups)
-
- rn_rpat (field, pat)
- = lookupLocatedGlobalOccRn field `thenM` \ fieldname ->
- rnLPat pat `thenM` \ (pat', fvs) ->
- returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname)
-
+ (_, 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}
-- 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)
\end{code}
forAllWarn doc ty (L loc tyvar)
= ifOptM Opt_WarnUnusedMatches $
- setSrcSpan loc $
- addWarn (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
- )
+ 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")))
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"))
+ $$ nest 4 (ptext SLIT("Use -XPatternSigs to permit it"))
dupFieldErr str dup
= hsep [ptext SLIT("duplicate field name"),
projects / ghc-hetmet.git / blobdiff