X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Frename%2FRnPat.lhs;h=061df0a706f1cdbb76985261823afacaa445f3aa;hp=2edb72dadaa382d6cce49cdebaf3cfc0a4e2ff11;hb=c24a860db326c7c1c7bab837b62147a984d5aecd;hpb=403ab78dfec15dd131ee48417e096ea28ef53fd9 diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs index 2edb72d..061df0a 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,9 +32,9 @@ 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" @@ -49,43 +42,18 @@ import {-# SOURCE #-} TcSplice( runQuasiQuotePat ) import HsSyn import TcRnMonad 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) \end{code} @@ -105,14 +73,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 +154,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: @@ -263,7 +230,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 +266,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 @@ -333,6 +300,8 @@ rnLPatAndThen var@(NM varf) (L loc p) cont = ; (res, fvs2) <- lcont (TypePat name') ; return (res, fvs1 `plusFV` fvs2) } + p -> pprPanic "rnLPatAndThen" (ppr p) + -- helper for renaming constructor patterns rnConPatAndThen :: NameMaker @@ -369,14 +338,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 +437,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 -XRecordPuns to permit this")] -- wrappers @@ -528,8 +503,9 @@ are made available. \begin{code} rnLit :: HsLit -> RnM () rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c) -rnLit other = return () +rnLit _ = return () +rnOverLit :: HsOverLit t -> RnM (HsOverLit Name, FreeVars) rnOverLit (HsIntegral i _ _) = do (from_integer_name, fvs) <- lookupSyntaxName fromIntegerName if inIntRange i then @@ -595,23 +571,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 -XPatternSignatures 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 enable 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}