X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Frename%2FRnTypes.lhs;h=2cc232cdc4bef994d75d52d0ec40b25d7ee9270e;hb=ed2f8e2a6ec160a0e57028fbfd4a9c5a3a5e083d;hp=fe51c1af32604920d1b92800fa8db97916c8628e;hpb=190f24892156953d73b55401d0467a6f1a88ce5d;p=ghc-hetmet.git diff --git a/compiler/rename/RnTypes.lhs b/compiler/rename/RnTypes.lhs index fe51c1a..2cc232c 100644 --- a/compiler/rename/RnTypes.lhs +++ b/compiler/rename/RnTypes.lhs @@ -10,19 +10,19 @@ module RnTypes ( 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, Opt_ScopedTypeVariables ) ) - +import DynFlags import HsSyn import RdrHsSyn ( extractHsRhoRdrTyVars ) import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, @@ -32,25 +32,25 @@ 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" @@ -386,19 +386,17 @@ 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)) + = 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) ) @@ -505,14 +503,20 @@ rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) 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} @@ -580,6 +584,10 @@ rnPat (SigPatIn pat ty) 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) @@ -593,7 +601,7 @@ rnPat (NPat lit mb_neg eq _) ) `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 _ _) @@ -602,7 +610,7 @@ 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) @@ -620,30 +628,25 @@ rnPat (AsPat name 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) -> @@ -652,44 +655,81 @@ rnPat (TypePat name) = -- ----------------------------------------------------------------------------- -- 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 - +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 -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) +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 | 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) - + (_, 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} @@ -735,6 +775,10 @@ rnOverLit (HsFractional i _) -- 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}