Expose enabled language extensions to TH
[ghc.git] / compiler / rename / RnExpr.hs
index ba48830..c520732 100644 (file)
@@ -45,6 +45,7 @@ import SrcLoc
 import FastString
 import Control.Monad
 import TysWiredIn       ( nilDataConName )
+import qualified GHC.LanguageExtensions as LangExt
 
 {-
 ************************************************************************
@@ -73,14 +74,14 @@ rnLExpr = wrapLocFstM rnExpr
 
 rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars)
 
-finishHsVar :: Name -> RnM (HsExpr Name, FreeVars)
+finishHsVar :: Located Name -> RnM (HsExpr Name, FreeVars)
 -- Separated from rnExpr because it's also used
 -- when renaming infix expressions
-finishHsVar name
+finishHsVar (L l name)
  = do { this_mod <- getModule
       ; when (nameIsLocalOrFrom this_mod name) $
         checkThLocalName name
-      ; return (HsVar name, unitFV name) }
+      ; return (HsVar (L l name), unitFV name) }
 
 rnUnboundVar :: RdrName -> RnM (HsExpr Name, FreeVars)
 rnUnboundVar v
@@ -92,10 +93,10 @@ rnUnboundVar v
 
         else -- Fail immediately (qualified name)
              do { n <- reportUnboundName v
-                ; return (HsVar n, emptyFVs) } }
+                ; return (HsVar (noLoc n), emptyFVs) } }
 
-rnExpr (HsVar v)
-  = do { opt_DuplicateRecordFields <- xoptM Opt_DuplicateRecordFields
+rnExpr (HsVar (L l v))
+  = do { opt_DuplicateRecordFields <- xoptM LangExt.DuplicateRecordFields
        ; mb_name <- lookupOccRn_overloaded opt_DuplicateRecordFields v
        ; case mb_name of {
            Nothing -> rnUnboundVar v ;
@@ -105,7 +106,7 @@ rnExpr (HsVar v)
               -> rnExpr (ExplicitList placeHolderType Nothing [])
 
               | otherwise
-              -> finishHsVar name ;
+              -> finishHsVar (L l name) ;
            Just (Right [f])        -> return (HsRecFld (ambiguousFieldOcc f)
                                              , unitFV (selectorFieldOcc f)) ;
            Just (Right fs@(_:_:_)) -> return (HsRecFld (Ambiguous v PlaceHolder)
@@ -119,7 +120,7 @@ rnExpr (HsOverLabel v)
   = return (HsOverLabel v, emptyFVs)
 
 rnExpr (HsLit lit@(HsString src s))
-  = do { opt_OverloadedStrings <- xoptM Opt_OverloadedStrings
+  = do { opt_OverloadedStrings <- xoptM LangExt.OverloadedStrings
        ; if opt_OverloadedStrings then
             rnExpr (HsOverLit (mkHsIsString src s placeHolderType))
          else do {
@@ -150,9 +151,10 @@ rnExpr (OpApp e1 op  _ e2)
         -- more, so I've removed the test.  Adding HsPars in TcGenDeriv
         -- should prevent bad things happening.
         ; fixity <- case op' of
-                      L _ (HsVar n) -> lookupFixityRn n
-                      _             -> return (Fixity minPrecedence InfixL)
-                                       -- c.f. lookupFixity for unbound
+                      L _ (HsVar (L _ n)) -> lookupFixityRn n
+                      L _ (HsRecFld f)    -> lookupFieldFixityRn f
+                      _ -> return (Fixity minPrecedence InfixL)
+                           -- c.f. lookupFixity for unbound
 
         ; final_e <- mkOpAppRn e1' op' fixity e2'
         ; return (final_e, fv_e1 `plusFV` fv_op `plusFV` fv_e2) }
@@ -230,7 +232,7 @@ rnExpr (HsDo do_or_lc (L l stmts) _)
         ; return ( HsDo do_or_lc (L l stmts') placeHolderType, fvs ) }
 
 rnExpr (ExplicitList _ _  exps)
-  = do  { opt_OverloadedLists <- xoptM Opt_OverloadedLists
+  = do  { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
         ; (exps', fvs) <- rnExprs exps
         ; if opt_OverloadedLists
            then do {
@@ -255,12 +257,19 @@ rnExpr (ExplicitTuple tup_args boxity)
     rnTupArg (L l (Missing _)) = return (L l (Missing placeHolderType)
                                         , emptyFVs)
 
-rnExpr (RecordCon { rcon_con_name = con_id, rcon_flds = rbinds })
-  = do  { conname <- lookupLocatedOccRn con_id
-        ; (rbinds', fvRbinds) <- rnHsRecBinds (HsRecFieldCon (unLoc conname)) rbinds
-        ; return (RecordCon { rcon_con_name = conname, rcon_flds = rbinds'
-                            , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder },
-                  fvRbinds `addOneFV` unLoc conname ) }
+rnExpr (RecordCon { rcon_con_name = con_id
+                  , rcon_flds = rec_binds@(HsRecFields { rec_dotdot = dd }) })
+  = do { con_lname@(L _ con_name) <- lookupLocatedOccRn con_id
+       ; (flds, fvs)   <- rnHsRecFields (HsRecFieldCon con_name) mk_hs_var rec_binds
+       ; (flds', fvss) <- mapAndUnzipM rn_field flds
+       ; let rec_binds' = HsRecFields { rec_flds = flds', rec_dotdot = dd }
+       ; return (RecordCon { rcon_con_name = con_lname, rcon_flds = rec_binds'
+                           , rcon_con_expr = noPostTcExpr, rcon_con_like = PlaceHolder }
+                , fvs `plusFV` plusFVs fvss `addOneFV` con_name) }
+  where
+    mk_hs_var l n = HsVar (L l n)
+    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
+                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
 
 rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
   = do  { (expr', fvExpr) <- rnLExpr expr
@@ -270,11 +279,11 @@ rnExpr (RecordUpd { rupd_expr = expr, rupd_flds = rbinds })
                             , rupd_out_tys = PlaceHolder, rupd_wrap   = PlaceHolder }
                  , fvExpr `plusFV` fvRbinds) }
 
-rnExpr (ExprWithTySig expr pty PlaceHolder)
-  = do  { (pty', fvTy, wcs) <- rnLHsTypeWithWildCards ExprWithTySigCtx pty
-        ; (expr', fvExpr)   <- bindSigTyVarsFV (hsExplicitTvs pty') $
-                               rnLExpr expr
-        ; return (ExprWithTySig expr' pty' wcs, fvExpr `plusFV` fvTy) }
+rnExpr (ExprWithTySig expr pty)
+  = do  { (pty', fvTy)    <- rnHsSigWcType ExprWithTySigCtx pty
+        ; (expr', fvExpr) <- bindSigTyVarsFV (hsWcScopedTvs pty') $
+                             rnLExpr expr
+        ; return (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) }
 
 rnExpr (HsIf _ p b1 b2)
   = do { (p', fvP) <- rnLExpr p
@@ -293,7 +302,7 @@ rnExpr (HsType a)
        ; return (HsType t, fvT) }
 
 rnExpr (ArithSeq _ _ seq)
-  = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
+  = do { opt_OverloadedLists <- xoptM LangExt.OverloadedLists
        ; (new_seq, fvs) <- rnArithSeq seq
        ; if opt_OverloadedLists
            then do {
@@ -417,25 +426,6 @@ rnSection other = pprPanic "rnSection" (ppr other)
 {-
 ************************************************************************
 *                                                                      *
-        Records
-*                                                                      *
-************************************************************************
--}
-
-rnHsRecBinds :: HsRecFieldContext -> HsRecordBinds RdrName
-             -> RnM (HsRecordBinds Name, FreeVars)
-rnHsRecBinds ctxt rec_binds@(HsRecFields { rec_dotdot = dd })
-  = do { (flds, fvs) <- rnHsRecFields ctxt HsVar rec_binds
-       ; (flds', fvss) <- mapAndUnzipM rn_field flds
-       ; return (HsRecFields { rec_flds = flds', rec_dotdot = dd },
-                 fvs `plusFV` plusFVs fvss) }
-  where
-    rn_field (L l fld) = do { (arg', fvs) <- rnLExpr (hsRecFieldArg fld)
-                            ; return (L l (fld { hsRecFieldArg = arg' }), fvs) }
-
-{-
-************************************************************************
-*                                                                      *
         Arrow commands
 *                                                                      *
 ************************************************************************
@@ -485,7 +475,7 @@ rnCmd (HsCmdArrApp arrow arg _ ho rtl)
 -- infix form
 rnCmd (HsCmdArrForm op (Just _) [arg1, arg2])
   = do { (op',fv_op) <- escapeArrowScope (rnLExpr op)
-       ; let L _ (HsVar op_name) = op'
+       ; let L _ (HsVar (L _ op_name)) = op'
        ; (arg1',fv_arg1) <- rnCmdTop arg1
        ; (arg2',fv_arg2) <- rnCmdTop arg2
         -- Deal with fixity
@@ -692,7 +682,7 @@ postProcessStmtsForApplicativeDo ctxt stmts
        -- rearrange the statements using ApplicativeStmt if
        -- -XApplicativeDo is on.  Also strip out the FreeVars attached
        -- to each Stmt body.
-         ado_is_on <- xoptM Opt_ApplicativeDo
+         ado_is_on <- xoptM LangExt.ApplicativeDo
        ; let is_do_expr | DoExpr <- ctxt = True
                         | otherwise = False
        ; if ado_is_on && is_do_expr
@@ -790,7 +780,7 @@ rnStmt ctxt rnBody (L loc (BindStmt pat body _ _)) thing_inside
                 -- The binders do not scope over the expression
         ; (bind_op, fvs1) <- lookupStmtName ctxt bindMName
 
-        ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
+        ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
         ; let failFunction | xMonadFailEnabled = failMName
                            | otherwise         = failMName_preMFP
         ; (fail_op, fvs2) <- lookupSyntaxName failFunction
@@ -934,7 +924,7 @@ lookupStmtName ctxt n
       TransStmtCtxt c -> lookupStmtName c n     -- the parent context
   where
     rebindable     = lookupSyntaxName n
-    not_rebindable = return (HsVar n, emptyFVs)
+    not_rebindable = return (HsVar (noLoc n), emptyFVs)
 
 {-
 Note [Renaming parallel Stmts]
@@ -1099,7 +1089,7 @@ rn_rec_stmt rnBody _ (L loc (BindStmt pat' body _ _), fv_pat)
   = do { (body', fv_expr) <- rnBody body
        ; (bind_op, fvs1) <- lookupSyntaxName bindMName
 
-       ; xMonadFailEnabled <- fmap (xopt Opt_MonadFailDesugaring) getDynFlags
+       ; xMonadFailEnabled <- fmap (xopt LangExt.MonadFailDesugaring) getDynFlags
        ; let failFunction | xMonadFailEnabled = failMName
                           | otherwise         = failMName_preMFP
        ; (fail_op, fvs2) <- lookupSyntaxName failFunction
@@ -1449,6 +1439,11 @@ ado _ctxt []        tail _ = return (tail, emptyNameSet)
 -- the bind form, which would give rise to a Monad constraint.
 ado ctxt [(L _ (BindStmt pat rhs _ _),_)] tail _
   | isIrrefutableHsPat pat, (False,tail') <- needJoin tail
+    -- WARNING: isIrrefutableHsPat on (HsPat Name) doesn't have enough info
+    --          to know which types have only one constructor.  So only
+    --          tuples come out as irrefutable; other single-constructor
+    --          types, and newtypes, will not.  See the code for
+    --          isIrrefuatableHsPat
   = mkApplicativeStmt ctxt [ApplicativeArgOne pat rhs] False tail'
 
 ado _ctxt [(one,_)] tail _ = return (one:tail, emptyNameSet)
@@ -1645,7 +1640,7 @@ isReturnApp (L _ (HsApp f arg))
   | otherwise = Nothing
  where
   is_return (L _ (HsPar e)) = is_return e
-  is_return (L _ (HsVar r)) = r == returnMName
+  is_return (L _ (HsVar (L _ r))) = r == returnMName
        -- TODO: I don't know how to get this right for rebindable syntax
   is_return _ = False
 isReturnApp _ = Nothing
@@ -1769,7 +1764,7 @@ okParStmt dflags ctxt stmt
 okDoStmt dflags ctxt stmt
   = case stmt of
        RecStmt {}
-         | Opt_RecursiveDo `xopt` dflags -> IsValid
+         | LangExt.RecursiveDo `xopt` dflags -> IsValid
          | ArrowExpr <- ctxt -> IsValid    -- Arrows allows 'rec'
          | otherwise         -> NotValid (ptext (sLit "Use RecursiveDo"))
        BindStmt {} -> IsValid
@@ -1784,10 +1779,10 @@ okCompStmt dflags _ stmt
        LetStmt {}  -> IsValid
        BodyStmt {} -> IsValid
        ParStmt {}
-         | Opt_ParallelListComp `xopt` dflags -> IsValid
+         | LangExt.ParallelListComp `xopt` dflags -> IsValid
          | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
        TransStmt {}
-         | Opt_TransformListComp `xopt` dflags -> IsValid
+         | LangExt.TransformListComp `xopt` dflags -> IsValid
          | otherwise -> NotValid (ptext (sLit "Use TransformListComp"))
        RecStmt {}  -> emptyInvalid
        LastStmt {} -> emptyInvalid  -- Should not happen (dealt with by checkLastStmt)
@@ -1800,7 +1795,7 @@ okPArrStmt dflags _ stmt
        LetStmt {}  -> IsValid
        BodyStmt {} -> IsValid
        ParStmt {}
-         | Opt_ParallelListComp `xopt` dflags -> IsValid
+         | LangExt.ParallelListComp `xopt` dflags -> IsValid
          | otherwise -> NotValid (ptext (sLit "Use ParallelListComp"))
        TransStmt {} -> emptyInvalid
        RecStmt {}   -> emptyInvalid
@@ -1810,7 +1805,7 @@ okPArrStmt dflags _ stmt
 ---------
 checkTupleSection :: [LHsTupArg RdrName] -> RnM ()
 checkTupleSection args
-  = do  { tuple_section <- xoptM Opt_TupleSections
+  = do  { tuple_section <- xoptM LangExt.TupleSections
         ; checkErr (all tupArgPresent args || tuple_section) msg }
   where
     msg = ptext (sLit "Illegal tuple section: use TupleSections")