summaryrefslogtreecommitdiff
path: root/compiler/rename
diff options
context:
space:
mode:
Diffstat (limited to 'compiler/rename')
-rw-r--r--compiler/rename/RnEnv.lhs18
-rw-r--r--compiler/rename/RnExpr.lhs45
-rw-r--r--compiler/rename/RnPat.lhs21
-rw-r--r--compiler/rename/RnSource.lhs3
4 files changed, 61 insertions, 26 deletions
diff --git a/compiler/rename/RnEnv.lhs b/compiler/rename/RnEnv.lhs
index 038e775fe9..90061b10a2 100644
--- a/compiler/rename/RnEnv.lhs
+++ b/compiler/rename/RnEnv.lhs
@@ -11,6 +11,7 @@ module RnEnv (
lookupLocalOccRn_maybe,
lookupTypeOccRn, lookupKindOccRn,
lookupGlobalOccRn, lookupGlobalOccRn_maybe,
+ reportUnboundName,
HsSigCtxt(..), lookupLocalTcNames, lookupSigOccRn,
@@ -543,9 +544,11 @@ lookupLocalOccRn_maybe rdr_name
-- lookupOccRn looks up an occurrence of a RdrName
lookupOccRn :: RdrName -> RnM Name
-lookupOccRn rdr_name = do
- opt_name <- lookupOccRn_maybe rdr_name
- maybe (unboundName WL_Any rdr_name) return opt_name
+lookupOccRn rdr_name
+ = do { mb_name <- lookupOccRn_maybe rdr_name
+ ; case mb_name of
+ Just name -> return name
+ Nothing -> reportUnboundName rdr_name }
lookupKindOccRn :: RdrName -> RnM Name
-- Looking up a name occurring in a kind
@@ -553,7 +556,7 @@ lookupKindOccRn rdr_name
= do { mb_name <- lookupOccRn_maybe rdr_name
; case mb_name of
Just name -> return name
- Nothing -> unboundName WL_Any rdr_name }
+ Nothing -> reportUnboundName rdr_name }
-- lookupPromotedOccRn looks up an optionally promoted RdrName.
lookupTypeOccRn :: RdrName -> RnM Name
@@ -571,13 +574,13 @@ lookup_demoted rdr_name
= do { data_kinds <- xoptM Opt_DataKinds
; mb_demoted_name <- lookupOccRn_maybe demoted_rdr
; case mb_demoted_name of
- Nothing -> unboundName WL_Any rdr_name
+ Nothing -> reportUnboundName rdr_name
Just demoted_name
| data_kinds -> return demoted_name
| otherwise -> unboundNameX WL_Any rdr_name suggest_dk }
| otherwise
- = unboundName WL_Any rdr_name
+ = reportUnboundName rdr_name
where
suggest_dk = ptext (sLit "A data constructor of that name is in scope; did you mean -XDataKinds?")
@@ -1354,6 +1357,9 @@ data WhereLooking = WL_Any -- Any binding
| WL_Global -- Any top-level binding (local or imported)
| WL_LocalTop -- Any top-level binding in this module
+reportUnboundName :: RdrName -> RnM Name
+reportUnboundName rdr = unboundName WL_Any rdr
+
unboundName :: WhereLooking -> RdrName -> RnM Name
unboundName wl rdr = unboundNameX wl rdr empty
diff --git a/compiler/rename/RnExpr.lhs b/compiler/rename/RnExpr.lhs
index 8e4d554a46..29674ca34c 100644
--- a/compiler/rename/RnExpr.lhs
+++ b/compiler/rename/RnExpr.lhs
@@ -53,6 +53,7 @@ import Outputable
import SrcLoc
import FastString
import Control.Monad
+import TysWiredIn ( nilDataConName )
\end{code}
@@ -108,14 +109,18 @@ finishHsVar name
; return (e, unitFV name) } }
rnExpr (HsVar v)
- = do { opt_TypeHoles <- xoptM Opt_TypeHoles
- ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v)
- then do { mb_name <- lookupOccRn_maybe v
- ; case mb_name of
- Nothing -> return (HsUnboundVar v, emptyFVs)
- Just n -> finishHsVar n }
- else do { name <- lookupOccRn v
- ; finishHsVar name } }
+ = do { mb_name <- lookupOccRn_maybe v
+ ; case mb_name of {
+ Nothing -> do { opt_TypeHoles <- xoptM Opt_TypeHoles
+ ; if opt_TypeHoles && startsWithUnderscore (rdrNameOcc v)
+ then return (HsUnboundVar v, emptyFVs)
+ else do { n <- reportUnboundName v; finishHsVar n } } ;
+ Just name
+ | name == nilDataConName -- Treat [] as an ExplicitList, so that
+ -- OverloadedLists works correctly
+ -> rnExpr (ExplicitList placeHolderType Nothing [])
+ | otherwise
+ -> finishHsVar name } }
rnExpr (HsIPVar v)
= return (HsIPVar v, emptyFVs)
@@ -249,9 +254,15 @@ rnExpr (HsDo do_or_lc stmts _)
= do { ((stmts', _), fvs) <- rnStmts do_or_lc rnLExpr stmts (\ _ -> return ((), emptyFVs))
; return ( HsDo do_or_lc stmts' placeHolderType, fvs ) }
-rnExpr (ExplicitList _ exps)
- = rnExprs exps `thenM` \ (exps', fvs) ->
- return (ExplicitList placeHolderType exps', fvs)
+rnExpr (ExplicitList _ _ exps)
+ = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
+ ; (exps', fvs) <- rnExprs exps
+ ; if opt_OverloadedLists
+ then do {
+ ; (from_list_n_name, fvs') <- lookupSyntaxName fromListNName
+ ; return (ExplicitList placeHolderType (Just from_list_n_name) exps', fvs `plusFV` fvs') }
+ else
+ return (ExplicitList placeHolderType Nothing exps', fvs) }
rnExpr (ExplicitPArr _ exps)
= rnExprs exps `thenM` \ (exps', fvs) ->
@@ -299,9 +310,15 @@ rnExpr (HsType a)
= rnLHsType HsTypeCtx a `thenM` \ (t, fvT) ->
return (HsType t, fvT)
-rnExpr (ArithSeq _ seq)
- = rnArithSeq seq `thenM` \ (new_seq, fvs) ->
- return (ArithSeq noPostTcExpr new_seq, fvs)
+rnExpr (ArithSeq _ _ seq)
+ = do { opt_OverloadedLists <- xoptM Opt_OverloadedLists
+ ; (new_seq, fvs) <- rnArithSeq seq
+ ; if opt_OverloadedLists
+ then do {
+ ; (from_list_name, fvs') <- lookupSyntaxName fromListName
+ ; return (ArithSeq noPostTcExpr (Just from_list_name) new_seq, fvs `plusFV` fvs') }
+ else
+ return (ArithSeq noPostTcExpr Nothing new_seq, fvs) }
rnExpr (PArrSeq _ seq)
= rnArithSeq seq `thenM` \ (new_seq, fvs) ->
diff --git a/compiler/rename/RnPat.lhs b/compiler/rename/RnPat.lhs
index 9738585aa4..a039f36b25 100644
--- a/compiler/rename/RnPat.lhs
+++ b/compiler/rename/RnPat.lhs
@@ -61,6 +61,8 @@ import SrcLoc
import FastString
import Literal ( inCharRange )
import Control.Monad ( when )
+import TysWiredIn ( nilDataCon )
+import DataCon ( dataConName )
\end{code}
@@ -375,11 +377,20 @@ rnPatAndThen mk p@(ViewPat expr pat ty)
rnPatAndThen mk (ConPatIn con stuff)
-- rnConPatAndThen takes care of reconstructing the pattern
- = rnConPatAndThen mk con stuff
-
-rnPatAndThen mk (ListPat pats _)
- = do { pats' <- rnLPatsAndThen mk pats
- ; return (ListPat pats' placeHolderType) }
+ -- The pattern for the empty list needs to be replaced by an empty explicit list pattern when overloaded lists is turned on.
+ = case unLoc con == nameRdrName (dataConName nilDataCon) of
+ True -> do { ol_flag <- liftCps $ xoptM Opt_OverloadedLists
+ ; if ol_flag then rnPatAndThen mk (ListPat [] placeHolderType Nothing)
+ else rnConPatAndThen mk con stuff}
+ False -> rnConPatAndThen mk con stuff
+
+rnPatAndThen mk (ListPat pats _ _)
+ = do { opt_OverloadedLists <- liftCps $ xoptM Opt_OverloadedLists
+ ; pats' <- rnLPatsAndThen mk pats
+ ; case opt_OverloadedLists of
+ True -> do { (to_list_name,_) <- liftCps $ lookupSyntaxName toListName
+ ; return (ListPat pats' placeHolderType (Just (placeHolderType, to_list_name)))}
+ False -> return (ListPat pats' placeHolderType Nothing) }
rnPatAndThen mk (PArrPat pats _)
= do { pats' <- rnLPatsAndThen mk pats
diff --git a/compiler/rename/RnSource.lhs b/compiler/rename/RnSource.lhs
index 7ff473f8c7..cc410388df 100644
--- a/compiler/rename/RnSource.lhs
+++ b/compiler/rename/RnSource.lhs
@@ -44,6 +44,7 @@ import Digraph ( SCC, flattenSCC, stronglyConnCompFromEdgedVertices )
import Control.Monad
import Data.List( partition )
+import Data.Traversable (traverse)
import Maybes( orElse )
\end{code}
@@ -339,7 +340,7 @@ rnAnnDecl (HsAnnotation provenance expr) = do
rnAnnProvenance :: AnnProvenance RdrName -> RnM (AnnProvenance Name, FreeVars)
rnAnnProvenance provenance = do
- provenance' <- modifyAnnProvenanceNameM lookupTopBndrRn provenance
+ provenance' <- traverse lookupTopBndrRn provenance
return (provenance', maybe emptyFVs unitFV (annProvenanceName_maybe provenance'))
\end{code}
View Lorry Controller Status