[project @ 2000-10-17 14:40:26 by sewardj]

[ghc-hetmet.git] / ghc / compiler / rename / RnExpr.lhs

diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs
index 5a83610..0225370 100644 (file)
--- a/ghc/compiler/rename/RnExpr.lhs
+++ b/ghc/compiler/rename/RnExpr.lhs
@@ -26,15 +26,15 @@ import RnHsSyn
 import RnMonad
 import RnEnv
 import RnIfaces                ( lookupFixityRn )
-import CmdLineOpts     ( opt_GlasgowExts, opt_IgnoreAsserts )
+import CmdLineOpts     ( dopt_GlasgowExts, opt_IgnoreAsserts )
 import Literal         ( inIntRange )
 import BasicTypes      ( Fixity(..), FixityDirection(..), defaultFixity, negateFixity )
-import PrelInfo                ( eqClass_RDR, 
+import PrelNames       ( hasKey, assertIdKey,
+                         eqClass_RDR, foldr_RDR, build_RDR, eqString_RDR,
                          ccallableClass_RDR, creturnableClass_RDR, 
                          monadClass_RDR, enumClass_RDR, ordClass_RDR,
                          ratioDataCon_RDR, negate_RDR, assertErr_RDR,
-                         ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR,
-                         foldr_RDR, build_RDR
+                         ioDataCon_RDR, plusInteger_RDR, timesInteger_RDR
                        )
 import TysPrim         ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, 
                          floatPrimTyCon, doublePrimTyCon
@@ -45,9 +45,7 @@ import NameSet
 import UniqFM          ( isNullUFM )
 import FiniteMap       ( elemFM )
 import UniqSet         ( emptyUniqSet )
-import Unique          ( hasKey, assertIdKey )
-import Util            ( removeDups )
-import ListSetOps      ( unionLists )
+import ListSetOps      ( unionLists, removeDups )
 import Maybes          ( maybeToBool )
 import Outputable
 \end{code}
@@ -69,17 +67,22 @@ rnPat (VarPatIn name)
     returnRn (VarPatIn vname, emptyFVs)
 
 rnPat (SigPatIn pat ty)
-  | opt_GlasgowExts
-  = rnPat pat          `thenRn` \ (pat', fvs1) ->
-    rnHsType doc ty    `thenRn` \ (ty',  fvs2) ->
-    returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
-
-  | otherwise
-  = addErrRn (patSigErr ty)    `thenRn_`
-    rnPat pat
+  = doptsRn dopt_GlasgowExts `thenRn` \ opt_GlasgowExts ->
+    
+    if opt_GlasgowExts
+    then rnPat pat             `thenRn` \ (pat', fvs1) ->
+         rnHsType doc ty       `thenRn` \ (ty',  fvs2) ->
+         returnRn (SigPatIn pat' ty', fvs1 `plusFV` fvs2)
+
+    else addErrRn (patSigErr ty)       `thenRn_`
+         rnPat pat
   where
     doc = text "a pattern type-signature"
     
+rnPat (LitPatIn s@(HsString _)) 
+  = lookupOrigName eqString_RDR                `thenRn` \ eq ->
+    returnRn (LitPatIn s, unitFV eq)
+
 rnPat (LitPatIn lit) 
   = litFVs lit         `thenRn` \ fvs ->
     returnRn (LitPatIn lit, fvs) 
@@ -142,6 +145,9 @@ rnPat (RecPatIn con rpats)
   = lookupOccRn con    `thenRn` \ con' ->
     rnRpats rpats      `thenRn` \ (rpats', fvs) ->
     returnRn (RecPatIn con' rpats', fvs `addOneFV` con')
+rnPat (TypePatIn name) =
+    (rnHsType (text "type pattern") name) `thenRn` \ (name', fvs) ->
+    returnRn (TypePatIn name', fvs)
 \end{code}
 
 ************************************************************************
@@ -169,7 +175,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
        doc_sig        = text "a pattern type-signature"
        doc_pats       = text "in a pattern match"
     in
-    bindTyVarsFVRn doc_sig (map UserTyVar forall_tyvars)       $ \ sig_tyvars ->
+    bindNakedTyVarsFVRn doc_sig forall_tyvars  $ \ sig_tyvars ->
 
        -- Note that we do a single bindLocalsRn for all the
        -- matches together, so that we spot the repeated variable in
@@ -178,6 +184,7 @@ rnMatch match@(Match _ pats maybe_rhs_sig grhss)
 
     mapFvRn rnPat pats                 `thenRn` \ (pats', pat_fvs) ->
     rnGRHSs grhss                      `thenRn` \ (grhss', grhss_fvs) ->
+    doptsRn dopt_GlasgowExts           `thenRn` \ opt_GlasgowExts ->
     (case maybe_rhs_sig of
        Nothing -> returnRn (Nothing, emptyFVs)
        Just ty | opt_GlasgowExts -> rnHsType doc_sig ty        `thenRn` \ (ty', ty_fvs) ->
@@ -213,7 +220,8 @@ rnGRHSs (GRHSs grhss binds maybe_ty)
     returnRn (GRHSs grhss' binds' Nothing, fvGRHSs)
 
 rnGRHS (GRHS guarded locn)
-  = pushSrcLocRn locn $                    
+  = doptsRn dopt_GlasgowExts           `thenRn` \ opt_GlasgowExts ->
+    pushSrcLocRn locn $                    
     (if not (opt_GlasgowExts || is_standard_guard guarded) then
                addWarnRn (nonStdGuardErr guarded)
      else
@@ -414,6 +422,11 @@ rnExpr (HsIf p b1 b2 src_loc)
     rnExpr b2          `thenRn` \ (b2', fvB2) ->
     returnRn (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2])
 
+rnExpr (HsType a) = 
+    (rnHsType doc a) `thenRn` \ (t, fvT) -> returnRn (HsType t, fvT)
+       where doc = text "renaming a type pattern"
+                   
+
 rnExpr (ArithSeqIn seq)
   = lookupOrigName enumClass_RDR       `thenRn` \ enum ->
     rn_seq seq                         `thenRn` \ (new_seq, fvs) ->