- 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)
-
-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)
- -- 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)
- -- 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)
-
-rnPat (PArrPat pats _)
- = rnLPats pats `thenM` \ (patslist, fvs) ->
- returnM (PArrPat patslist placeHolderType,
- fvs `plusFV` implicit_fvs)
- where
- implicit_fvs = mkFVs [lengthPName, indexPName]
-
-rnPat (TuplePat pats boxed _)
- = checkTupSize (length pats) `thenM_`
- rnLPats pats `thenM` \ (patslist, fvs) ->
- returnM (TuplePat patslist boxed placeHolderType, fvs)
-
-rnPat (TypePat name) =
- rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) ->
- returnM (TypePat name', fvs)
-
--- -----------------------------------------------------------------------------
--- rnConPat
-
-rnConPat :: Located RdrName -> HsConPatDetails RdrName -> RnM (Pat Name, FreeVars)
-rnConPat con (PrefixCon pats)
- = do { con' <- lookupLocatedOccRn con
- ; (pats', fvs) <- rnLPats pats
- ; return (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') }
-
-rnConPat con (RecCon rpats)
- = 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)
- = 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') }
-
--- -----------------------------------------------------------------------------
-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
-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 (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")]