View patterns, record wildcards, and record puns
[ghc-hetmet.git] / compiler / rename / RnTypes.lhs
index fe51c1a..aad8de8 100644 (file)
@@ -4,25 +4,24 @@
 \section[RnSource]{Main pass of renamer}
 
 \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 RnTypes ( 
        -- Type related stuff
        rnHsType, rnLHsType, rnLHsTypes, rnContext,
        rnHsSigType, rnHsTypeFVs,
 
-       -- Patterns and literals
-       rnLPat, rnPat, rnPatsAndThen,   -- Here because it's not part 
-       rnLit, rnOverLit,               -- of any mutual recursion      
-
        -- Precence related stuff
-       mkOpAppRn, mkNegAppRn, mkOpFormRn, 
-       checkPrecMatch, checkSectionPrec, 
-       
-       -- Error messages
-       dupFieldErr, patSigErr, checkTupSize
+       mkOpAppRn, mkNegAppRn, mkOpFormRn, mkConOpPatRn,
+       checkPrecMatch, checkSectionPrec
   ) 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 +31,25 @@ import RnHsDoc          ( rnLHsDoc )
 import RnEnv           ( lookupOccRn, lookupBndrRn, lookupSyntaxName,
                          lookupLocatedOccRn, lookupLocatedBndrRn,
                          lookupLocatedGlobalOccRn, bindTyVarsRn, 
-                         lookupFixityRn, lookupTyFixityRn,
-                         mapFvRn, warnUnusedMatches,
-                         newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV )
+                         lookupFixityRn, lookupTyFixityRn, lookupConstructorFields,
+                         lookupRecordBndr, mapFvRn, warnUnusedMatches,
+                         newIPNameRn, bindPatSigTyVarsFV)
 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"
@@ -124,7 +123,7 @@ rnHsType doc (HsTyVar tyvar)
 
 rnHsType doc ty@(HsOpTy ty1 (L loc op) ty2)
   = setSrcSpan loc $ 
-    do { ty_ops_ok <- doptM Opt_ScopedTypeVariables    -- Badly named option
+    do { ty_ops_ok <- doptM Opt_TypeOperators
        ; checkErr ty_ops_ok (opTyErr op ty)
        ; op' <- lookupOccRn op
        ; let l_op' = L loc op'
@@ -220,6 +219,39 @@ rnForAll doc exp forall_tyvars ctxt ty
        -- so that we can later print it correctly
 \end{code}
 
+%*********************************************************
+%*                                                     *
+\subsection{Contexts and predicates}
+%*                                                     *
+%*********************************************************
+
+\begin{code}
+rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
+rnContext doc = wrapLocM (rnContext' doc)
+
+rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
+rnContext' doc ctxt = mappM (rnLPred doc) ctxt
+
+rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name)
+rnLPred doc  = wrapLocM (rnPred doc)
+
+rnPred doc (HsClassP clas 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)
+  = do { name <- newIPNameRn n
+       ; ty' <- rnLHsType doc ty
+       ; returnM (HsIParam name ty')
+       }
+\end{code}
+
 
 %************************************************************************
 %*                                                                     *
@@ -386,19 +418,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) )
@@ -490,271 +520,11 @@ ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
 
 %*********************************************************
 %*                                                     *
-\subsection{Contexts and predicates}
-%*                                                     *
-%*********************************************************
-
-\begin{code}
-rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name)
-rnContext doc = wrapLocM (rnContext' doc)
-
-rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name)
-rnContext' doc ctxt = mappM (rnLPred doc) ctxt
-
-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')
-
-rnPred doc (HsIParam n ty)
-  = newIPNameRn n              `thenM` \ name ->
-    rnLHsType doc ty           `thenM` \ ty' ->
-    returnM (HsIParam name ty')
-\end{code}
-
-
-*********************************************************
-*                                                      *
-\subsection{Patterns}
-*                                                      *
-*********************************************************
-
-\begin{code}
-rnPatsAndThen :: HsMatchContext Name
-             -> [LPat RdrName] 
-             -> ([LPat Name] -> RnM (a, FreeVars))
-             -> RnM (a, FreeVars)
--- Bring into scope all the binders and type variables
--- bound by the patterns; then rename the patterns; then
--- do the thing inside.
---
--- Note that we do a single bindLocalsRn for all the
--- matches together, so that we spot the repeated variable in
---     f x x = 1
-
-rnPatsAndThen ctxt pats thing_inside
-  = bindPatSigTyVarsFV pat_sig_tys     $
-    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
-    warnUnusedMatches unused_binders   `thenM_`
-    returnM (res, res_fvs `plusFV` pat_fvs)
-  where
-    pat_sig_tys = collectSigTysFromPats pats
-    bndrs      = collectLocatedPatsBinders pats
-    doc_pat     = ptext SLIT("In") <+> pprMatchContext ctxt
-
-rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars)
-rnLPats ps = mapFvRn rnLPat ps
-
-rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars)
-rnLPat = wrapLocFstM rnPat
-
--- -----------------------------------------------------------------------------
--- rnPat
-
-rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars)
-
-rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs)
-
-rnPat (VarPat name)
-  = lookupBndrRn  name                 `thenM` \ vname ->
-    returnM (VarPat vname, emptyFVs)
-
-rnPat (SigPatIn pat ty)
-  = doptM Opt_GlasgowExts `thenM` \ glaExts ->
-    
-    if glaExts
-    then rnLPat pat            `thenM` \ (pat', fvs1) ->
-         rnHsTypeFVs doc ty    `thenM` \ (ty',  fvs2) ->
-         returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
-
-    else addErr (patSigErr ty) `thenM_`
-         rnPat (unLoc pat) -- XXX shouldn't throw away the loc
-  where
-    doc = text "In a pattern type-signature"
-    
-rnPat (LitPat lit) 
-  = rnLit lit  `thenM_` 
-    returnM (LitPat lit, emptyFVs) 
-
-rnPat (NPat lit mb_neg eq _) 
-  = rnOverLit lit                      `thenM` \ (lit', fvs1) ->
-    (case mb_neg of
-       Nothing -> returnM (Nothing, emptyFVs)
-       Just _  -> lookupSyntaxName negateName  `thenM` \ (neg, fvs) ->
-                  returnM (Just neg, fvs)
-    )                                  `thenM` \ (mb_neg', fvs2) ->
-    lookupSyntaxName eqName            `thenM` \ (eq', fvs3) -> 
-    returnM (NPat lit' mb_neg' eq' placeHolderType, 
-             fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` eqClassName)  
-       -- Needed to find equality on pattern
-
-rnPat (NPlusKPat name lit _ _)
-  = rnOverLit lit                      `thenM` \ (lit', fvs1) ->
-    lookupLocatedBndrRn name           `thenM` \ name' ->
-    lookupSyntaxName minusName         `thenM` \ (minus, fvs2) ->
-    lookupSyntaxName geName            `thenM` \ (ge, fvs3) ->
-    returnM (NPlusKPat name' lit' ge minus,
-            fvs1 `plusFV` fvs2 `plusFV` fvs3 `addOneFV` integralClassName)
-       -- The Report says that n+k patterns must be in Integral
-
-rnPat (LazyPat pat)
-  = rnLPat pat         `thenM` \ (pat', fvs) ->
-    returnM (LazyPat pat', fvs)
-
-rnPat (BangPat pat)
-  = rnLPat pat         `thenM` \ (pat', fvs) ->
-    returnM (BangPat pat', fvs)
-
-rnPat (AsPat name pat)
-  = rnLPat pat                 `thenM` \ (pat', fvs) ->
-    lookupLocatedBndrRn name   `thenM` \ vname ->
-    returnM (AsPat vname pat', fvs)
-
-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)
-
-rnPat (PArrPat pats _)
-  = rnLPats pats                       `thenM` \ (patslist, fvs) ->
-    returnM (PArrPat patslist placeHolderType, 
-             fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name)
-  where
-    implicit_fvs = mkFVs [lengthPName, indexPName]
-
-rnPat (TuplePat pats boxed _)
-  = checkTupSize tup_size      `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
-
-rnPat (TypePat name) =
-    rnHsTypeFVs (text "In a type pattern") name        `thenM` \ (name', fvs) ->
-    returnM (TypePat name', fvs)
-
--- -----------------------------------------------------------------------------
--- rnConPat
-
-rnConPat con (PrefixCon pats)
-  = lookupLocatedOccRn con     `thenM` \ con' ->
-    rnLPats pats               `thenM` \ (pats', fvs) ->
-    returnM (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')
-
-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')
-
--- -----------------------------------------------------------------------------
--- rnRpats
-
--- 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)
-  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)
-
-\end{code}
-
-
-%************************************************************************
-%*                                                                     *
-\subsubsection{Literals}
-%*                                                                     *
-%************************************************************************
-
-When literals occur we have to make sure
-that the types and classes they involve
-are made available.
-
-\begin{code}
-rnLit :: HsLit -> RnM ()
-rnLit (HsChar c) = checkErr (inCharRange c) (bogusCharError c)
-rnLit other     = returnM ()
-
-rnOverLit (HsIntegral i _)
-  = lookupSyntaxName fromIntegerName   `thenM` \ (from_integer_name, fvs) ->
-    if inIntRange i then
-       returnM (HsIntegral i from_integer_name, 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
-    returnM (HsIntegral i from_integer_name, fvs `plusFV` extra_fvs)
-
-rnOverLit (HsFractional i _)
-  = lookupSyntaxName fromRationalName          `thenM` \ (from_rat_name, fvs) ->
-    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)
-    in
-    returnM (HsFractional i from_rat_name, fvs `plusFV` extra_fvs)
-\end{code}
-
-
-
-%*********************************************************
-%*                                                     *
 \subsection{Errors}
 %*                                                     *
 %*********************************************************
 
 \begin{code}
-checkTupSize :: Int -> RnM ()
-checkTupSize tup_size
-  | tup_size <= mAX_TUPLE_SIZE 
-  = returnM ()
-  | 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"))])
-
 forAllWarn doc ty (L loc tyvar)
   = ifOptM Opt_WarnUnusedMatches       $
     addWarnAt loc (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar),
@@ -764,17 +534,5 @@ forAllWarn doc ty (L loc tyvar)
 
 opTyErr op ty 
   = hang (ptext SLIT("Illegal operator") <+> quotes (ppr op) <+> ptext SLIT("in type") <+> quotes (ppr ty))
-        2 (parens (ptext SLIT("Use -fscoped-type-variables 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"))
-
-dupFieldErr str dup
-  = hsep [ptext SLIT("duplicate field name"), 
-          quotes (ppr dup),
-         ptext SLIT("in record"), text str]
+        2 (parens (ptext SLIT("Use -XTypeOperators to allow operators in types")))
 \end{code}