%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
\section[RnPat]{Renaming of patterns}

Basically dependency analysis.

Handles @Match@, @GRHSs@, @HsExpr@, and @Qualifier@ datatypes.  In
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,

              NameMaker, applyNameMaker,     -- a utility for making names:
              localRecNameMaker, topRecNameMaker,  --   sometimes we want to make local names,
                                             --   sometimes we want to make top (qualified) names.

              rnHsRecFields_Con, rnHsRecFields_Update, --rename record fields in a constructor
                                                       --and in an update

	      -- Literals
	      rnLit, rnOverLit,     

             -- Pattern Error messages that are also used elsewhere
             checkTupSize, patSigErr
             ) where

-- ENH: thin imports to only what is necessary for patterns

import {-# SOURCE #-} RnExpr( rnLExpr, rnStmts)

#include "HsVersions.h"

import HsSyn            
import TcRnMonad
import RnEnv
import HscTypes         ( availNames )
import RnNames		( getLocalDeclBinders, extendRdrEnvRn )
import RnTypes		( rnHsTypeFVs, 
			  mkOpFormRn, mkOpAppRn, mkNegAppRn, checkSectionPrec, mkConOpPatRn
			   )
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 )
import Constants	( mAX_TUPLE_SIZE )
import Name		( Name, nameOccName, nameIsLocalOrFrom, getOccName, nameSrcSpan )
import NameSet
import UniqFM
import RdrName        ( RdrName, extendLocalRdrEnv, lookupLocalRdrEnv, hideSomeUnquals, mkRdrUnqual, nameRdrName )
import LoadIface	( loadInterfaceForName )
import UniqFM		( isNullUFM )
import UniqSet		( emptyUniqSet )
import List		( nub )
import Util		( isSingleton )
import ListSetOps	( removeDups, minusList )
import Maybes		( expectJust )
import Outputable
import SrcLoc		( Located(..), unLoc, getLoc, cmpLocated, noLoc )
import FastString
import Literal		( inIntRange, inCharRange )
import List		( unzip4 )
import Bag            (foldrBag)

import ErrUtils       (Message)
\end{code}


*********************************************************
*							*
\subsection{Patterns}
*							*
*********************************************************

\begin{code}
-- externally abstract type of name makers,
-- which is how you go from a RdrName to a Name
data NameMaker = NM (forall a. Located RdrName -> (Name -> RnM (a, FreeVars))
			                       -> RnM (a, FreeVars))

matchNameMaker :: NameMaker
matchNameMaker
  = NM (\ rdr_name thing_inside -> 
	do { names@[name] <- newLocalsRn [rdr_name]
	   ; bindLocalNamesFV names $
	     warnUnusedMatches names $
	     thing_inside name })
			  
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

-- topNameMaker and localBindMaker do not check for unused binding
localRecNameMaker fix_env
  = NM (\ rdr_name thing_inside -> 
	do { [name] <- newLocalsRn [rdr_name]
	   ; bindLocalNamesFV_WithFixities [name] fix_env $
	     thing_inside name })
  
topRecNameMaker fix_env
  = NM (\rdr_name thing_inside -> 
        do { mod <- getModule
           ; name <- newTopSrcBinder mod rdr_name
	   ; bindLocalNamesFV_WithFixities [name] fix_env $
	     thing_inside name })
	        -- Note: the bindLocalNamesFV_WithFixities is somewhat suspicious 
        	--       because it binds a top-level name as a local name.
	        --       however, this binding seems to work, and it only exists for
	        --       the duration of the patterns and the continuation;
	        --       then the top-level name is added to the global env
	        --       before going on to the RHSes (see RnSource.lhs).

applyNameMaker :: NameMaker -> Located RdrName
	       -> (Name -> RnM (a,FreeVars)) -> RnM (a, FreeVars)
applyNameMaker (NM f) = f


-- There are various entry points to renaming patterns, depending on
--  (1) whether the names created should be top-level names or local names
--  (2) whether the scope of the names is entirely given in a continuation
--      (e.g., in a case or lambda, but not in a let or at the top-level,
--       because of the way mutually recursive bindings are handled)
--  (3) whether the a type signature in the pattern can bind 
--	lexically-scoped type variables (for unpacking existential 
--	type vars in data constructors)
--  (4) whether we do duplicate and unused variable checking
--  (5) whether there are fixity declarations associated with the names
--      bound by the patterns that need to be brought into scope with them.
--      
--  Rather than burdening the clients of this module with all of these choices,
--  we export the three points in this design space that we actually need:

-- entry point 1:
-- binds local names; the scope of the bindings is entirely in the thing_inside
--   allows type sigs to bind type vars
--   local namemaker
--   unused and duplicate checking
--   no fixities
rnPatsAndThen_LocalRightwards :: HsMatchContext Name -- for error messages
                              -> [LPat RdrName] 
                              -- the continuation gets:
                              --    the list of renamed patterns
                              --    the (overall) free vars of all of them
                              -> ([LPat Name] -> RnM (a, FreeVars))
                              -> RnM (a, FreeVars)

rnPatsAndThen_LocalRightwards ctxt pats thing_inside
  = do	{ -- Check for duplicated and shadowed names 
	  -- Because we don't bind the vars all at once, we can't
	  -- 	check incrementally for duplicates; 
	  -- Nor can we check incrementally for shadowing, else we'll
	  -- 	complain *twice* about duplicates e.g. f (x,x) = ...
	  let rdr_names_w_loc = collectLocatedPatsBinders pats
	; checkDupNames  doc_pat rdr_names_w_loc
      	; checkShadowing doc_pat rdr_names_w_loc

	  -- (0) bring into scope all of the type variables bound by the patterns
	  -- (1) rename the patterns, bringing into scope all of the term variables
	  -- (2) then do the thing inside.
	; bindPatSigTyVarsFV (collectSigTysFromPats pats) $ 
	  rnLPatsAndThen matchNameMaker pats	$
	  thing_inside }
  where
    doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt


-- entry point 2:
-- binds local names; in a recursive scope that involves other bound vars
--	e.g let { (x, Just y) = e1; ... } in ...
--   does NOT allows type sig to bind type vars
--   local namemaker
--   no unused and duplicate checking
--   fixities might be coming in
rnBindPat :: NameMaker
          -> LPat RdrName
          -> RnM (LPat Name, 
                       -- free variables of the pattern,
                       -- but not including variables bound by this pattern 
                   FreeVars)

rnBindPat name_maker pat
  = rnLPatsAndThen name_maker [pat] $ \ [pat'] ->
    return (pat', emptyFVs)


-- general version: parametrized by how you make new names
-- invariant: what-to-do continuation only gets called with a list whose length is the same as
--            the part of the pattern we're currently renaming
rnLPatsAndThen :: NameMaker -- how to make a new variable
               -> [LPat RdrName]   -- part of pattern we're currently renaming
               -> ([LPat Name] -> RnM (a, FreeVars)) -- what to do afterwards
               -> RnM (a, FreeVars) -- renaming of the whole thing
               
rnLPatsAndThen var = mapFvRnCPS (rnLPatAndThen var)


-- the workhorse
rnLPatAndThen :: NameMaker
              -> LPat RdrName   -- part of pattern we're currently renaming
              -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards
              -> RnM (a, FreeVars) -- renaming of the whole thing
rnLPatAndThen var@(NM varf) (L loc p) cont = 
    setSrcSpan loc $ 
      let reloc = L loc 
          lcont = \ unlocated -> cont (reloc unlocated)
      in
       case p of
         WildPat _   -> lcont (WildPat placeHolderType)

         ParPat pat  -> rnLPatAndThen var pat $ \ pat' -> lcont (ParPat pat')
         LazyPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (LazyPat pat')
         BangPat pat -> rnLPatAndThen var pat $ \ pat' -> lcont (BangPat pat')
         
         VarPat name -> 
	    varf (reloc name) $ \ newBoundName -> 
	    lcont (VarPat newBoundName)
               -- we need to bind pattern variables for view pattern expressions
               -- (e.g. in the pattern (x, x -> y) x needs to be bound in the rhs of the tuple)
                                     
         SigPatIn pat ty ->
             doptM Opt_PatternSignatures `thenM` \ patsigs ->
             if patsigs
             then rnLPatAndThen var pat
                      (\ pat' -> do { (ty', fvs1) <- rnHsTypeFVs tvdoc ty
				    ; (res, fvs2) <- lcont (SigPatIn pat' ty')
				    ; return (res, fvs1 `plusFV` fvs2) })
             else addErr (patSigErr ty) `thenM_`
                  rnLPatAndThen var pat cont 
           where
             tvdoc = text "In a pattern type-signature"
       
         LitPat lit@(HsString s) -> 
             do ovlStr <- doptM Opt_OverloadedStrings
                if ovlStr 
                 then rnLPatAndThen var (reloc $ mkNPat (mkHsIsString s placeHolderType) Nothing) cont
                 else do { rnLit lit; lcont (LitPat lit) }   -- Same as below
      
         LitPat lit -> do { rnLit lit; lcont (LitPat lit) }

         NPat lit mb_neg eq ->
           do { (lit', fvs1) <- rnOverLit lit
	      ;	(mb_neg', fvs2) <- case mb_neg of
			             Nothing -> return (Nothing, emptyFVs)
			             Just _  -> do { (neg, fvs) <- lookupSyntaxName negateName
						   ; return (Just neg, fvs) }
	      ; (eq', fvs3) <- lookupSyntaxName eqName
	      ; (res, fvs4) <- lcont (NPat lit' mb_neg' eq')
	      ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
	       	-- Needed to find equality on pattern

         NPlusKPat name lit _ _ ->
   	   varf name $ \ new_name ->
	   do { (lit', fvs1) <- rnOverLit lit
  	      ; (minus, fvs2) <- lookupSyntaxName minusName
              ; (ge, fvs3) <- lookupSyntaxName geName
              ; (res, fvs4) <- lcont (NPlusKPat (L (nameSrcSpan new_name) new_name) lit' ge minus)
	      ; return (res, fvs1 `plusFV` fvs2 `plusFV` fvs3 `plusFV` fvs4) }
	   	-- The Report says that n+k patterns must be in Integral

         AsPat name pat ->
   	   varf name $ \ new_name ->
           rnLPatAndThen var pat $ \ pat' -> 
           lcont (AsPat (L (nameSrcSpan new_name) new_name) pat')

         ViewPat expr pat ty -> 
	   do { vp_flag <- doptM Opt_ViewPatterns
              ; checkErr vp_flag (badViewPat p)
                -- because of the way we're arranging the recursive calls,
                -- this will be in the right context 
              ; (expr', fv_expr) <- rnLExpr expr 
              ; (res, fvs_res) <- rnLPatAndThen var pat $ \ pat' ->
		                  lcont (ViewPat expr' pat' ty)
	      ; return (res, fvs_res `plusFV` fv_expr) }

         ConPatIn con stuff -> 
             -- rnConPatAndThen takes care of reconstructing the pattern
             rnConPatAndThen var con stuff cont

         ListPat pats _ -> 
           rnLPatsAndThen var pats $ \ patslist ->
               lcont (ListPat patslist placeHolderType)

         PArrPat pats _ -> 
	   do { (res, res_fvs) <- rnLPatsAndThen var pats $ \ patslist ->
			          lcont (PArrPat patslist placeHolderType)
	      ; return (res, res_fvs `plusFV` implicit_fvs) }
           where
             implicit_fvs = mkFVs [lengthPName, indexPName]

         TuplePat pats boxed _ -> 
           do { checkTupSize (length pats)
              ; 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')
	      ; return (res, fvs1 `plusFV` fvs2) }


-- helper for renaming constructor patterns
rnConPatAndThen :: NameMaker
                -> Located RdrName          -- the constructor
                -> HsConPatDetails RdrName 
                -> (LPat Name -> RnM (a, FreeVars)) -- what to do afterwards
                -> RnM (a, FreeVars)

rnConPatAndThen var (con@(L loc _)) (PrefixCon pats) cont
  = do	{ con' <- lookupLocatedOccRn con
	; (res, res_fvs) <- rnLPatsAndThen var pats $ \ pats' ->
		            cont (L loc $ ConPatIn con' (PrefixCon pats'))
        ; return (res, res_fvs `addOneFV` unLoc con') }

rnConPatAndThen var (con@(L loc _)) (InfixCon pat1 pat2) cont
  = do	{ con' <- lookupLocatedOccRn con
   	; (res, res_fvs) <- rnLPatAndThen var pat1 $ \ pat1' -> 
			    rnLPatAndThen var pat2 $ \ pat2' ->
			    do { fixity <- lookupFixityRn (unLoc con')
		               ; pat' <- mkConOpPatRn con' fixity pat1' pat2'
			       ; cont (L loc pat') }
        ; return (res, res_fvs `addOneFV` unLoc con') }

rnConPatAndThen var (con@(L loc _)) (RecCon rpats) cont
  = do	{ con' <- lookupLocatedOccRn con
  	; (res, res_fvs) <- rnHsRecFieldsAndThen_Pattern con' var rpats $ \ rpats' -> 
			    cont (L loc $ ConPatIn con' (RecCon rpats'))
        ; return (res, res_fvs `addOneFV` unLoc con') }

-- what kind of record expression we're doing
-- the first two tell the name of the datatype constructor in question
-- and give a way of creating a variable to fill in a ..
data RnHsRecFieldsChoice a = Constructor (Located Name) (RdrName -> a)
                           | Pattern  (Located Name) (RdrName -> a)
                           | Update

choiceToMessage (Constructor _ _) = "construction"
choiceToMessage (Pattern _ _) = "pattern"
choiceToMessage Update = "update"

doDotDot (Constructor a b) = Just (a,b)
doDotDot (Pattern a b) = Just (a,b)
doDotDot Update        = Nothing

getChoiceName (Constructor n _) = Just n
getChoiceName (Pattern n _) = Just n
getChoiceName (Update) = Nothing



-- helper for renaming record patterns;
-- parameterized so that it can also be used for expressions
rnHsRecFieldsAndThen :: RnHsRecFieldsChoice field
                     -- how to rename the fields (CPSed)
                     -> (Located field -> (Located field' -> RnM (c, FreeVars)) 
                                       -> RnM (c, FreeVars)) 
                     -- the actual fields 
                     -> HsRecFields RdrName (Located field)  
                     -- what to do in the scope of the field vars
                     -> (HsRecFields Name (Located field') -> RnM (c, FreeVars)) 
                     -> RnM (c, FreeVars)
-- Haddock comments for record fields are renamed to Nothing here
rnHsRecFieldsAndThen choice rn_thing (HsRecFields fields dd) cont = 
    let

        -- helper to collect and report duplicate record fields
        reportDuplicateFields doingstr fields = 
            let 
                -- each list represents a RdrName that occurred more than once
                -- (the list contains all occurrences)
                -- invariant: each list in dup_fields is non-empty
                (_, dup_fields :: [[RdrName]]) = removeDups compare
                                                 (map (unLoc . hsRecFieldId) fields)
                                             
                -- duplicate field reporting function
                field_dup_err dup_group = addErr (dupFieldErr doingstr (head dup_group))
            in
              mappM_ field_dup_err dup_fields

        -- helper to rename each field
        rn_field pun_ok (HsRecField field inside pun) cont = do 
          fieldname <- lookupRecordBndr (getChoiceName choice) field
          checkErr (not pun || pun_ok) (badPun field)
          (res, res_fvs) <- rn_thing inside $ \ inside' -> 
		            cont (HsRecField fieldname inside' pun) 
          return (res, res_fvs `addOneFV` unLoc fieldname)

        -- Compute the extra fields to be filled in by the dot-dot notation
        dot_dot_fields fs con mk_field cont = do 
            con_fields <- lookupConstructorFields (unLoc con)
            let missing_fields = con_fields `minusList` fs
            loc <- getSrcSpanM	-- Rather approximate
            -- it's important that we make the RdrName fields that we morally wrote
            -- and then rename them in the usual manner
            -- (rather than trying to make the result of renaming directly)
            -- because, for patterns, renaming can bind vars in the continuation
            mapFvRnCPS rn_thing 
             (map (L loc . mk_field . mkRdrUnqual . getOccName) missing_fields) $
              \ rhss -> 
                  let new_fs = [ HsRecField (L loc f) r False
		                 | (f, r) <- missing_fields `zip` rhss ]
                  in 
                  cont new_fs

   in do
       -- report duplicate fields
       let doingstr = choiceToMessage choice
       reportDuplicateFields doingstr fields

       -- rename the records as written
       -- check whether punning (implicit x=x) is allowed
       pun_flag <- doptM Opt_RecordPuns
       -- rename the fields
       mapFvRnCPS (rn_field pun_flag) fields $ \ fields1 ->

           -- handle ..
           case dd of
             Nothing -> cont (HsRecFields fields1 dd)
             Just n  -> ASSERT( n == length fields ) do
                          dd_flag <- doptM Opt_RecordWildCards
                          checkErr dd_flag (needFlagDotDot doingstr)
                          let fld_names1 = map (unLoc . hsRecFieldId) fields1
                          case doDotDot choice of 
                                Nothing -> addErr (badDotDot doingstr) `thenM_` 
                                           -- we return a junk value here so that error reporting goes on
                                           cont (HsRecFields fields1 dd)
                                Just (con, mk_field) ->
                                    dot_dot_fields fld_names1 con mk_field $
                                      \ fields2 -> 
                                          cont (HsRecFields (fields1 ++ fields2) dd)

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

badPun fld = vcat [ptext SLIT("Illegal use of punning for field") <+> quotes (ppr fld),
		   ptext SLIT("Use -XRecordPuns to permit this")]


-- wrappers
rnHsRecFieldsAndThen_Pattern :: Located Name
                             -> NameMaker -- new name maker
                             -> HsRecFields RdrName (LPat RdrName)  
                             -> (HsRecFields Name (LPat Name) -> RnM (c, FreeVars)) 
                             -> RnM (c, FreeVars)
rnHsRecFieldsAndThen_Pattern n var
  = rnHsRecFieldsAndThen (Pattern n VarPat) (rnLPatAndThen var)


-- wrapper to use rnLExpr in CPS style;
-- because it does not bind any vars going forward, it does not need
-- to be written that way
rnLExprAndThen :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
               -> LHsExpr RdrName 
               -> (LHsExpr Name -> RnM (c, FreeVars)) 
               -> RnM (c, FreeVars) 
rnLExprAndThen f e cont = do { (x, fvs1) <- f e
			     ; (res, fvs2) <- cont x
			     ; return (res, fvs1 `plusFV` fvs2) }


-- non-CPSed because exprs don't leave anything bound
rnHsRecFields_Con :: Located Name
                  -> (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
                  -> HsRecFields RdrName (LHsExpr RdrName)  
                  -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
rnHsRecFields_Con n rnLExpr fields = rnHsRecFieldsAndThen (Constructor n HsVar) 
                                     (rnLExprAndThen rnLExpr) fields $ \ res ->
				     return (res, emptyFVs)

rnHsRecFields_Update :: (LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars))
                     -> HsRecFields RdrName (LHsExpr RdrName)  
                     -> RnM (HsRecFields Name (LHsExpr Name), FreeVars)
rnHsRecFields_Update rnLExpr fields = rnHsRecFieldsAndThen Update
                                      (rnLExprAndThen rnLExpr) fields $ \ res -> 
				      return (res, emptyFVs)
\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 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
    returnM (HsIntegral i from_integer_name placeHolderType, 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 placeHolderType, fvs `plusFV` extra_fvs)

rnOverLit (HsIsString s _ _)
  = lookupSyntaxName fromStringName	`thenM` \ (from_string_name, fvs) ->
	returnM (HsIsString s from_string_name placeHolderType, fvs)
\end{code}


%************************************************************************
%*									*
\subsubsection{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"))])

patSigErr ty
  =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
	$$ nest 4 (ptext SLIT("Use -XPatternSignatures to permit it"))

dupFieldErr str dup
  = hsep [ptext SLIT("duplicate field name"), 
          quotes (ppr dup),
	  ptext SLIT("in record"), text str]

bogusCharError c
  = 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")]

\end{code}