[project @ 2000-05-23 11:35:36 by simonpj]
[ghc-hetmet.git] / ghc / compiler / rename / RnExpr.lhs
index aecf9a9..8669ca6 100644 (file)
@@ -18,7 +18,7 @@ module RnExpr (
 #include "HsVersions.h"
 
 import {-# SOURCE #-} RnBinds  ( rnBinds ) 
-import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsType )
+import {-# SOURCE #-} RnSource ( rnHsSigType, rnHsPolyType, rnHsType )
 
 import HsSyn
 import RdrHsSyn
@@ -27,7 +27,7 @@ import RnMonad
 import RnEnv
 import RnIfaces                ( lookupFixity )
 import CmdLineOpts     ( opt_GlasgowExts, opt_IgnoreAsserts )
-import BasicTypes      ( Fixity(..), FixityDirection(..), defaultFixity )
+import BasicTypes      ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity, negatePrecedence )
 import PrelInfo                ( numClass_RDR, fractionalClass_RDR, eqClass_RDR, 
                          ccallableClass_RDR, creturnableClass_RDR, 
                          monadClass_RDR, enumClass_RDR, ordClass_RDR,
@@ -70,7 +70,7 @@ rnPat (VarPatIn name)
 rnPat (SigPatIn pat ty)
   | opt_GlasgowExts
   = rnPat pat          `thenRn` \ (pat', fvs1) ->
-    rnHsType doc ty    `thenRn` \ (ty',  fvs2) ->
+    rnHsPolyType doc ty        `thenRn` \ (ty',  fvs2) ->
     returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
 
   | otherwise
@@ -174,23 +174,24 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
        tyvars_in_sigs = rhs_sig_tyvars `unionLists` tyvars_in_pats
        rhs_sig_tyvars = case maybe_rhs_sig of
                                Nothing -> []
-                               Just ty -> extractHsTyRdrNames ty
+                               Just ty -> extractHsTyRdrTyVars ty
        tyvars_in_pats = extractPatsTyVars pats
        forall_tyvars  = filter (not . (`elemFM` name_env)) tyvars_in_sigs
-       doc            = text "a pattern type-signature"
+       doc_sig        = text "a pattern type-signature"
+       doc_pats       = text "in a pattern match"
     in
-    bindTyVarsFVRn doc (map UserTyVar forall_tyvars)   $ \ sig_tyvars ->
+    bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars)       $ \ sig_tyvars ->
 
        -- Note that we do a single bindLocalsRn for all the
        -- matches together, so that we spot the repeated variable in
        --      f x x = 1
-    bindLocalsFVRn doc (collectPatsBinders pats) $ \ new_binders ->
+    bindLocalsFVRn doc_pats (collectPatsBinders pats) $ \ new_binders ->
 
     mapFvRn rnPat pats                 `thenRn` \ (pats', pat_fvs) ->
     rnGRHSs grhss                      `thenRn` \ (grhss', grhss_fvs) ->
     (case maybe_rhs_sig of
        Nothing -> returnRn (Nothing, emptyFVs)
-       Just ty | opt_GlasgowExts -> rnHsType doc ty    `thenRn` \ (ty', ty_fvs) ->
+       Just ty | opt_GlasgowExts -> rnHsPolyType doc_sig ty    `thenRn` \ (ty', ty_fvs) ->
                                     returnRn (Just ty', ty_fvs)
                | otherwise       -> addErrRn (patSigErr ty)    `thenRn_`
                                     returnRn (Nothing, emptyFVs)
@@ -282,6 +283,10 @@ rnExpr (HsVar v)
         -- The normal case
        returnRn (HsVar name, unitFV name)
 
+rnExpr (HsIPVar v)
+  = getIPName v                        `thenRn` \ name ->
+    returnRn (HsIPVar name, emptyFVs)
+
 rnExpr (HsLit lit) 
   = litOccurrence lit          `thenRn` \ fvs ->
     returnRn (HsLit lit, fvs)
@@ -331,23 +336,25 @@ rnExpr (HsPar e)
   = rnExpr e           `thenRn` \ (e', fvs_e) ->
     returnRn (HsPar e', fvs_e)
 
-rnExpr (SectionL expr op)
-  = rnExpr expr                `thenRn` \ (expr', fvs_expr) ->
-    rnExpr op          `thenRn` \ (op', fvs_op) ->
+rnExpr section@(SectionL expr op)
+  = rnExpr expr                                        `thenRn` \ (expr', fvs_expr) ->
+    rnExpr op                                  `thenRn` \ (op', fvs_op) ->
+    checkSectionPrec "left" section op' expr'  `thenRn_`
     returnRn (SectionL expr' op', fvs_op `plusFV` fvs_expr)
 
-rnExpr (SectionR op expr)
-  = rnExpr op          `thenRn` \ (op',   fvs_op) ->
-    rnExpr expr                `thenRn` \ (expr', fvs_expr) ->
+rnExpr section@(SectionR op expr)
+  = rnExpr op                                  `thenRn` \ (op',   fvs_op) ->
+    rnExpr expr                                        `thenRn` \ (expr', fvs_expr) ->
+    checkSectionPrec "right" section op' expr' `thenRn_`
     returnRn (SectionR op' expr', fvs_op `plusFV` fvs_expr)
 
-rnExpr (CCall fun args may_gc is_casm fake_result_ty)
+rnExpr (HsCCall fun args may_gc is_casm fake_result_ty)
        -- Check out the comment on RnIfaces.getNonWiredDataDecl about ccalls
   = lookupImplicitOccRn ccallableClass_RDR     `thenRn` \ cc ->
     lookupImplicitOccRn creturnableClass_RDR   `thenRn` \ cr ->
     lookupImplicitOccRn ioDataCon_RDR          `thenRn` \ io ->
     rnExprs args                               `thenRn` \ (args', fvs_args) ->
-    returnRn (CCall fun args' may_gc is_casm fake_result_ty, 
+    returnRn (HsCCall fun args' may_gc is_casm fake_result_ty, 
              fvs_args `addOneFV` cc `addOneFV` cr `addOneFV` io)
 
 rnExpr (HsSCC lbl expr)
@@ -365,10 +372,21 @@ rnExpr (HsLet binds expr)
     rnExpr expr                         `thenRn` \ (expr',fvExpr) ->
     returnRn (HsLet binds' expr', fvExpr)
 
-rnExpr (HsDo do_or_lc stmts src_loc)
+rnExpr (HsWith expr binds)
+  = rnExpr expr                        `thenRn` \ (expr',fvExpr) ->
+    rnIPBinds binds            `thenRn` \ (binds',fvBinds) ->
+    returnRn (HsWith expr' binds', fvExpr `plusFV` fvBinds)
+
+rnExpr e@(HsDo do_or_lc stmts src_loc)
   = pushSrcLocRn src_loc $
     lookupImplicitOccRn monadClass_RDR         `thenRn` \ monad ->
     rnStmts rnExpr stmts                       `thenRn` \ (stmts', fvs) ->
+       -- check the statement list ends in an expression
+    case last stmts' of {
+       ExprStmt _ _ -> returnRn () ;
+       ReturnStmt _ -> returnRn () ;   -- for list comprehensions
+       _            -> addErrRn (doStmtListErr e)
+    }                                          `thenRn_`
     returnRn (HsDo do_or_lc stmts' src_loc, fvs `addOneFV` monad)
 
 rnExpr (ExplicitList exps)
@@ -483,6 +501,22 @@ rnRpats rpats
 
 %************************************************************************
 %*                                                                     *
+\subsubsection{@rnIPBinds@s: in implicit parameter bindings}           *
+%*                                                                     *
+%************************************************************************
+
+\begin{code}
+rnIPBinds [] = returnRn ([], emptyFVs)
+rnIPBinds ((n, expr) : binds)
+  = getIPName n                        `thenRn` \ name ->
+    rnExpr expr                        `thenRn` \ (expr',fvExpr) ->
+    rnIPBinds binds            `thenRn` \ (binds',fvBinds) ->
+    returnRn ((name, expr') : binds', fvExpr `plusFV` fvBinds)
+
+\end{code}
+
+%************************************************************************
+%*                                                                     *
 \subsubsection{@Stmt@s: in @do@ expressions}
 %*                                                                     *
 %************************************************************************
@@ -561,48 +595,59 @@ the programmer actually wrote, so you can't find it out from the Name.
 
 Furthermore, the second argument is guaranteed not to be another
 operator application.  Why? Because the parser parses all
-operator appications left-associatively.
+operator appications left-associatively, EXCEPT negation, which
+we need to handle specially.
 
 \begin{code}
-mkOpAppRn :: RenamedHsExpr -> RenamedHsExpr -> Fixity -> RenamedHsExpr
+mkOpAppRn :: RenamedHsExpr                     -- Left operand; already rearranged
+         -> RenamedHsExpr -> Fixity            -- Operator and fixity
+         -> RenamedHsExpr                      -- Right operand (not an OpApp, but might
+                                               -- be a NegApp)
          -> RnMS RenamedHsExpr
 
-mkOpAppRn e1@(OpApp e11 op1 fix1 e12) 
-         op2 fix2 e2
+---------------------------
+-- (e11 `op1` e12) `op2` e2
+mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2
   | nofix_error
-  = addErrRn (precParseErr (get op1,fix1) (get op2,fix2))      `thenRn_`
+  = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))        `thenRn_`
     returnRn (OpApp e1 op2 fix2 e2)
 
-  | rearrange_me
+  | associate_right
   = mkOpAppRn e12 op2 fix2 e2          `thenRn` \ new_e ->
     returnRn (OpApp e11 op1 fix1 new_e)
   where
-    (nofix_error, rearrange_me) = compareFixity fix1 fix2
+    (nofix_error, associate_right) = compareFixity fix1 fix2
 
-mkOpAppRn e1@(NegApp neg_arg neg_op) 
-         op2 
-         fix2@(Fixity prec2 dir2)
-         e2
+---------------------------
+--     (- neg_arg) `op` e2
+mkOpAppRn e1@(NegApp neg_arg neg_op) op2 fix2 e2
   | nofix_error
-  = addErrRn (precParseErr (get neg_op,fix_neg) (get op2,fix2))        `thenRn_`
+  = addErrRn (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2))   `thenRn_`
     returnRn (OpApp e1 op2 fix2 e2)
 
-  | rearrange_me
+  | associate_right
   = mkOpAppRn neg_arg op2 fix2 e2      `thenRn` \ new_e ->
     returnRn (NegApp new_e neg_op)
   where
-    fix_neg = Fixity 6 InfixL          -- Precedence of unary negate is wired in as infixl 6!
-    (nofix_error, rearrange_me) = compareFixity fix_neg fix2
+    (nofix_error, associate_right) = compareFixity negateFixity fix2
+
+---------------------------
+--     e1 `op` - neg_arg
+mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg neg_op)       -- NegApp can occur on the right
+  | not associate_right                                        -- We *want* right association
+  = addErrRn (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenRn_`
+    returnRn (OpApp e1 op1 fix1 e2)
+  where
+    (_, associate_right) = compareFixity fix1 negateFixity
 
+---------------------------
+--     Default case
 mkOpAppRn e1 op fix e2                         -- Default case, no rearrangment
-  = ASSERT( if right_op_ok fix e2 then True
-           else pprPanic "mkOpAppRn" (vcat [ppr e1, text "---", ppr op, 
-                                            text "---", ppr fix, text "---", ppr e2])
+  = ASSERT2( right_op_ok fix e2,
+            ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2
     )
     returnRn (OpApp e1 op fix e2)
 
-get (HsVar n) = n
-
 -- Parser left-associates everything, but 
 -- derived instances may have correctly-associated things to
 -- in the right operarand.  So we just check that the right operand is OK
@@ -633,22 +678,22 @@ mkConOpPatRn :: RenamedPat -> Name -> Fixity -> RenamedPat
 mkConOpPatRn p1@(ConOpPatIn p11 op1 fix1 p12) 
             op2 fix2 p2
   | nofix_error
-  = addErrRn (precParseErr (op1,fix1) (op2,fix2))      `thenRn_`
+  = addErrRn (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2))        `thenRn_`
     returnRn (ConOpPatIn p1 op2 fix2 p2)
 
-  | rearrange_me
+  | associate_right
   = mkConOpPatRn p12 op2 fix2 p2               `thenRn` \ new_p ->
     returnRn (ConOpPatIn p11 op1 fix1 new_p)
 
   where
-    (nofix_error, rearrange_me) = compareFixity fix1 fix2
+    (nofix_error, associate_right) = compareFixity fix1 fix2
 
 mkConOpPatRn p1@(NegPatIn neg_arg) 
          op2 
          fix2@(Fixity prec2 dir2)
          p2
-  | prec2 > 6  -- Precedence of unary - is wired in as 6!
-  = addErrRn (precParseNegPatErr (op2,fix2))   `thenRn_`
+  | prec2 > negatePrecedence   -- Precedence of unary - is wired in
+  = addErrRn (precParseNegPatErr (ppr_op op2,fix2))    `thenRn_`
     returnRn (ConOpPatIn p1 op2 fix2 p2)
 
 mkConOpPatRn p1 op fix p2                      -- Default case, no rearrangment
@@ -665,7 +710,8 @@ checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnMS ()
 checkPrecMatch False fn match
   = returnRn ()
 
-checkPrecMatch True op (Match _ [p1,p2] _ _)
+checkPrecMatch True op (Match _ (p1:p2:_) _ _)
+       -- True indicates an infix lhs
   = getModeRn          `thenRn` \ mode ->
        -- See comments with rnExpr (OpApp ...)
     case mode of
@@ -684,18 +730,33 @@ checkPrec op (ConOpPatIn _ op1 _ _) right
                  (op1_dir == InfixR && op_dir == InfixR && right ||
                   op1_dir == InfixL && op_dir == InfixL && not right))
 
-       info  = (op,op_fix)
-       info1 = (op1,op1_fix)
+       info  = (ppr_op op,  op_fix)
+       info1 = (ppr_op op1, op1_fix)
        (infol, infor) = if right then (info, info1) else (info1, info)
     in
     checkRn inf_ok (precParseErr infol infor)
 
 checkPrec op (NegPatIn _) right
   = lookupFixity op    `thenRn` \ op_fix@(Fixity op_prec op_dir) ->
-    checkRn (op_prec <= 6) (precParseNegPatErr (op,op_fix))
+    checkRn (op_prec <= negatePrecedence) (precParseNegPatErr (ppr_op op,op_fix))
 
 checkPrec op pat right
   = returnRn ()
+
+-- Check precedence of (arg op) or (op arg) respectively
+-- If arg is itself an operator application, its precedence should
+-- be higher than that of op
+checkSectionPrec left_or_right section op arg
+  = case arg of
+       OpApp _ op fix _ -> go_for_it (ppr_op op)     fix
+       NegApp _ op      -> go_for_it pp_prefix_minus negateFixity
+       other            -> returnRn ()
+  where
+    HsVar op_name = op
+    go_for_it pp_arg_op arg_fix@(Fixity arg_prec _)
+       = lookupFixity op_name  `thenRn` \ op_fix@(Fixity op_prec _) ->
+         checkRn (op_prec < arg_prec)
+                 (sectionPrecErr (ppr_op op_name, op_fix) (pp_arg_op, arg_fix) section)
 \end{code}
 
 Consider
@@ -818,26 +879,36 @@ mkAssertExpr =
 %************************************************************************
 
 \begin{code}
+ppr_op op = quotes (ppr op)    -- Here, op can be a Name or a (Var n), where n is a Name
+ppr_opfix (pp_op, fixity) = pp_op <+> brackets (ppr fixity)
+pp_prefix_minus = ptext SLIT("prefix `-'")
+
 dupFieldErr str (dup:rest)
   = hsep [ptext SLIT("duplicate field name"), 
           quotes (ppr dup),
          ptext SLIT("in record"), text str]
 
 negPatErr pat 
-  = sep [ptext SLIT("prefix `-' not applied to literal in pattern"), quotes (ppr pat)]
+  = sep [pp_prefix_minus <+> ptext SLIT("not applied to literal in pattern"), 
+        quotes (ppr pat)]
 
 precParseNegPatErr op 
   = hang (ptext SLIT("precedence parsing error"))
-      4 (hsep [ptext SLIT("prefix `-' has lower precedence than"), 
-              quotes (pp_op op), 
+      4 (hsep [pp_prefix_minus <+> ptext SLIT("has lower precedence than"), 
+              ppr_opfix op, 
               ptext SLIT("in pattern")])
 
 precParseErr op1 op2 
   = hang (ptext SLIT("precedence parsing error"))
-      4 (hsep [ptext SLIT("cannot mix"), quotes (pp_op op1), ptext SLIT("and"), 
-              quotes (pp_op op2),
+      4 (hsep [ptext SLIT("cannot mix"), ppr_opfix op1, ptext SLIT("and"), 
+              ppr_opfix op2,
               ptext SLIT("in the same infix expression")])
 
+sectionPrecErr op arg_op section
+ = vcat [ptext SLIT("The operator") <+> ppr_opfix op <+> ptext SLIT("of a section"),
+        nest 4 (ptext SLIT("must have lower precedence than the operand") <+> ppr_opfix arg_op),
+        nest 4 (ptext SLIT("In the section:") <+> quotes (ppr section))]
+
 nonStdGuardErr guard
   = hang (ptext
     SLIT("accepting non-standard pattern guards (-fglasgow-exts to suppress this message)")
@@ -847,9 +918,11 @@ patSigErr ty
   =  (ptext SLIT("Illegal signature in pattern:") <+> ppr ty)
        $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it"))
 
-pp_op (op, fix) = hcat [ppr op, space, parens (ppr fix)]
-
 patSynErr e 
   = sep [ptext SLIT("Pattern syntax in expression context:"),
         nest 4 (ppr e)]
+
+doStmtListErr e
+  = sep [ptext SLIT("`do' statements must end in expression:"),
+        nest 4 (ppr e)]
 \end{code}