X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnPat.lhs;h=ac35fe55fc72af9a671e58d37eef79b99edb853c;hp=9d3dc0489ee9151c8d82c5fac9b754cce892ab40;hb=432b9c9322181a3644083e3c19b7e240d90659e7;hpb=d51f42f602bf9a6d1b356c41228a534c88723f65 diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 9d3dc04..ac35fe5 100644 --- a/compiler/rename/RnPat.lhs +++ b/compiler/rename/RnPat.lhs @@ -10,13 +10,6 @@ general, all of these functions return a renamed thing, and a set of free variables. \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module RnPat (-- main entry points rnPatsAndThen_LocalRightwards, rnBindPat, @@ -39,61 +32,37 @@ module RnPat (-- main entry points -- ENH: thin imports to only what is necessary for patterns -import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts) +import {-# SOURCE #-} RnExpr ( rnLExpr ) #ifdef GHCI -import {-# SOURCE #-} TcSplice( runQuasiQuotePat ) +import {-# SOURCE #-} TcSplice ( runQuasiQuotePat ) #endif /* GHCI */ #include "HsVersions.h" import HsSyn import TcRnMonad +import TcHsSyn ( hsOverLitName ) import RnEnv -import HscTypes ( availNames ) -import RnNames ( getLocalDeclBinders, extendRdrEnvRn ) -import RnTypes ( rnHsTypeFVs, - mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, mkConOpPatRn - ) +import RnTypes import DynFlags ( DynFlag(..) ) -import BasicTypes ( FixityDirection(..) ) -import SrcLoc ( SrcSpan ) -import PrelNames ( thFAKE, hasKey, assertIdKey, assertErrorName, - loopAName, choiceAName, appAName, arrAName, composeAName, firstAName, - negateName, thenMName, bindMName, failMName, - eqClassName, integralClassName, geName, eqName, - negateName, minusName, lengthPName, indexPName, - plusIntegerName, fromIntegerName, timesIntegerName, - ratioDataConName, fromRationalName, fromStringName, mkUnboundName ) +import PrelNames import Constants ( mAX_TUPLE_SIZE ) -import Name ( Name, nameOccName, nameModule_maybe, getOccName, nameSrcSpan ) -import OccName ( occEnvElts ) +import Name import NameSet -import LazyUniqFM -import RdrName ( RdrName, GlobalRdrElt(..), Provenance(..), - extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, - mkRdrUnqual, nameRdrName, gre_name, globalRdrEnvElts, isLocalGRE ) -import LoadIface ( loadInterfaceForName ) -import UniqSet ( emptyUniqSet ) -import List ( nub ) -import Util ( isSingleton ) +import RdrName import ListSetOps ( removeDups, minusList ) -import Maybes ( expectJust ) import Outputable -import SrcLoc ( Located(..), unLoc, getLoc, cmpLocated, noLoc ) +import SrcLoc import FastString -import Literal ( inIntRange, inCharRange ) -import List ( unzip4 ) -import Bag (foldrBag) - -import ErrUtils (Message) +import Literal ( inCharRange ) \end{code} -********************************************************* -* * +%********************************************************* +%* * \subsection{Patterns} -* * -********************************************************* +%* * +%********************************************************* \begin{code} -- externally abstract type of name makers, @@ -105,14 +74,13 @@ matchNameMaker :: NameMaker matchNameMaker = NM (\ rdr_name thing_inside -> do { names@[name] <- newLocalsRn [rdr_name] - ; bindLocalNamesFV names $ - warnUnusedMatches names $ - thing_inside name }) + ; bindLocalNamesFV names $ do + { (res, fvs) <- thing_inside name + ; warnUnusedMatches names fvs + ; return (res, fvs) }}) topRecNameMaker, localRecNameMaker - :: UniqFM (Located Fixity) -- mini fixity env for the names we're about to bind - -- these fixities need to be brought into scope with the names - -> NameMaker + :: MiniFixityEnv -> NameMaker -- topNameMaker and localBindMaker do not check for unused binding localRecNameMaker fix_env @@ -187,7 +155,7 @@ rnPatsAndThen_LocalRightwards ctxt pats thing_inside [(nameSrcSpan name, nameOccName name) | name <- names] ; thing_inside pats' } } where - doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt + doc_pat = ptext (sLit "In") <+> pprMatchContext ctxt -- entry point 2: @@ -244,7 +212,7 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple) SigPatIn pat ty -> do - patsigs <- doptM Opt_PatternSignatures + patsigs <- doptM Opt_ScopedTypeVariables if patsigs then rnLPatAndThen var pat (\ pat' -> do { (ty', fvs1) <- rnHsTypeFVs tvdoc ty @@ -263,7 +231,7 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = LitPat lit -> do { rnLit lit; lcont (LitPat lit) } - NPat lit mb_neg eq -> + NPat lit mb_neg _eq -> do { (lit', fvs1) <- rnOverLit lit ; (mb_neg', fvs2) <- case mb_neg of Nothing -> return (Nothing, emptyFVs) @@ -299,7 +267,7 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = ; return (res, fvs_res `plusFV` fv_expr) } #ifndef GHCI - pat@(QuasiQuotePat _) -> pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) + (QuasiQuotePat _) -> pprPanic "Can't do QuasiQuotePat without GHCi" (ppr p) #else QuasiQuotePat qq -> do (qq', _) <- rnQuasiQuote qq @@ -328,11 +296,13 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = ; rnLPatsAndThen var pats $ \ patslist -> lcont (TuplePat patslist boxed placeHolderType) } - TypePat name -> - do { (name', fvs1) <- rnHsTypeFVs (text "In a type pattern") name - ; (res, fvs2) <- lcont (TypePat name') + TypePat ty -> + do { (ty', fvs1) <- rnHsTypeFVs (text "In a type pattern") ty + ; (res, fvs2) <- lcont (TypePat ty') ; return (res, fvs1 `plusFV` fvs2) } + p -> pprPanic "rnLPatAndThen" (ppr p) + -- helper for renaming constructor patterns rnConPatAndThen :: NameMaker @@ -369,14 +339,17 @@ data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a) | Pattern (Located Name) (RdrName -> a) | Update +choiceToMessage :: RnHsRecFieldsChoice t -> String choiceToMessage (Constructor _ _) = "construction" choiceToMessage (Pattern _ _) = "pattern" choiceToMessage Update = "update" +doDotDot :: RnHsRecFieldsChoice t -> Maybe (Located Name, RdrName -> t) doDotDot (Constructor a b) = Just (a,b) doDotDot (Pattern a b) = Just (a,b) doDotDot Update = Nothing +getChoiceName :: RnHsRecFieldsChoice field -> Maybe (Located Name) getChoiceName (Constructor n _) = Just n getChoiceName (Pattern n _) = Just n getChoiceName (Update) = Nothing @@ -465,13 +438,16 @@ rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = \ fields2 -> cont (HsRecFields (fields1 ++ fields2) dd) -needFlagDotDot str = vcat [ptext SLIT("Illegal `..' in record") <+> text str, - ptext SLIT("Use -XRecordWildCards to permit this")] +needFlagDotDot :: String -> SDoc +needFlagDotDot str = vcat [ptext (sLit "Illegal `..' in record") <+> text str, + ptext (sLit "Use -XRecordWildCards to permit this")] -badDotDot str = ptext SLIT("You cannot use `..' in record") <+> text str +badDotDot :: String -> SDoc +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 -XRecordPuns to permit this")] +badPun :: Located RdrName -> SDoc +badPun fld = vcat [ptext (sLit "Illegal use of punning for field") <+> quotes (ppr fld), + ptext (sLit "Use -XNamedFieldPuns to permit this")] -- wrappers @@ -528,40 +504,42 @@ are made available. \begin{code} rnLit :: HsLit -> RnM () rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) -rnLit other = return () - -rnOverLit (HsIntegral i _ _) = do - (from_integer_name, fvs) <- lookupSyntaxName fromIntegerName - if inIntRange i then - return (HsIntegral i from_integer_name placeHolderType, 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 - return (HsIntegral i from_integer_name placeHolderType, fvs `plusFV` extra_fvs) - -rnOverLit (HsFractional i _ _) = do - (from_rat_name, fvs) <- lookupSyntaxName fromRationalName - 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) - return (HsFractional i from_rat_name placeHolderType, fvs `plusFV` extra_fvs) - -rnOverLit (HsIsString s _ _) = do - (from_string_name, fvs) <- lookupSyntaxName fromStringName - return (HsIsString s from_string_name placeHolderType, fvs) +rnLit _ = return () + +rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) +rnOverLit lit@(OverLit {ol_val=val}) + = do { let std_name = hsOverLitName val + ; (from_thing_name, fvs) <- lookupSyntaxName std_name + ; let rebindable = case from_thing_name of + HsVar v -> v /= std_name + _ -> panic "rnOverLit" + ; return (lit { ol_witness = from_thing_name + , ol_rebindable = rebindable }, fvs) } \end{code} +---------------------------------------------------------------- +-- Old code returned extra free vars need in desugarer +-- but that is no longer necessary, I believe +-- if inIntRange i then +-- return (HsIntegral i from_integer_name placeHolderType, 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.] + +-- (HsFractional i _ _) = do +-- 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) + %************************************************************************ %* * \subsubsection{Quasiquotation} @@ -595,23 +573,27 @@ checkTupSize tup_size | tup_size <= mAX_TUPLE_SIZE = return () | 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"))]) + = 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"))]) +patSigErr :: Outputable a => a -> SDoc patSigErr ty - = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) - $$ nest 4 (ptext SLIT("Use -XPatternSignatures to permit it")) + = (ptext (sLit "Illegal signature in pattern:") <+> ppr ty) + $$ nest 4 (ptext (sLit "Use -XScopedTypeVariables to permit it")) +dupFieldErr :: String -> RdrName -> SDoc dupFieldErr str dup - = hsep [ptext SLIT("duplicate field name"), + = hsep [ptext (sLit "duplicate field name"), quotes (ppr dup), - ptext SLIT("in record"), text str] + ptext (sLit "in record"), text str] +bogusCharError :: Char -> SDoc bogusCharError c - = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' + = ptext (sLit "character literal out of range: '\\") <> char c <> char '\'' -badViewPat pat = vcat [ptext SLIT("Illegal view pattern: ") <+> ppr pat, - ptext SLIT("Use -XViewPatterns to enalbe view patterns")] +badViewPat :: Pat RdrName -> SDoc +badViewPat pat = vcat [ptext (sLit "Illegal view pattern: ") <+> ppr pat, + ptext (sLit "Use -XViewPatterns to enable view patterns")] \end{code}