diff options
| author | simonmar <unknown> | 2003-12-10 14:15:38 +0000 |
|---|---|---|
| committer | simonmar <unknown> | 2003-12-10 14:15:38 +0000 |
| commit | 550421384b8364cdaf3135f7859c9f7d7ee1fff1 (patch) | |
| tree | a786c7336f8404cf741da30c2760d5c65d00c9da | |
| parent | 60ea58ab5cbf8428997d5aa8ec9163a50fe5aed3 (diff) | |
| download | haskell-550421384b8364cdaf3135f7859c9f7d7ee1fff1.tar.gz | |
[project @ 2003-12-10 14:15:16 by simonmar]
Add accurate source location annotations to HsSyn
-------------------------------------------------
Every syntactic entity in HsSyn is now annotated with a SrcSpan, which
details the exact beginning and end points of that entity in the
original source file. All honest compilers should do this, and it was
about time GHC did the right thing.
The most obvious benefit is that we now have much more accurate error
messages; when running GHC inside emacs for example, the cursor will
jump to the exact location of an error, not just a line somewhere
nearby. We haven't put a huge amount of effort into making sure all
the error messages are accurate yet, so there could be some tweaking
still needed, although the majority of messages I've seen have been
spot-on.
Error messages now contain a column number in addition to the line
number, eg.
read001.hs:25:10: Variable not in scope: `+#'
To get the full text span info, use the new option -ferror-spans. eg.
read001.hs:25:10-11: Variable not in scope: `+#'
I'm not sure whether we should do this by default. Emacs won't
understand the new error format, for one thing.
In a more elaborate editor setting (eg. Visual Studio), we can arrange
to actually highlight the subexpression containing an error. Eventually
this information will be used so we can find elements in the abstract
syntax corresponding to text locations, for performing high-level editor
functions (eg. "tell me the type of this expression I just highlighted").
Performance of the compiler doesn't seem to be adversely affected.
Parsing is still quicker than in 6.0.1, for example.
Implementation:
This was an excrutiatingly painful change to make: both Simon P.J. and
myself have been working on it for the last three weeks or so. The
basic changes are:
- a new datatype SrcSpan, which represents a beginning and end position
in a source file.
- To reduce the pain as much as possible, we also defined:
data Located e = L SrcSpan e
- Every datatype in HsSyn has an equivalent Located version. eg.
type LHsExpr id = Located (HsExpr id)
and pretty much everywhere we used to use HsExpr we now use
LHsExpr. Believe me, we thought about this long and hard, and
all the other options were worse :-)
Additional changes/cleanups we made at the same time:
- The abstract syntax for bindings is now less arcane. MonoBinds
and HsBinds with their built-in list constructors have gone away,
replaced by HsBindGroup and HsBind (see HsSyn/HsBinds.lhs).
- The various HsSyn type synonyms have now gone away (eg. RdrNameHsExpr,
RenamedHsExpr, and TypecheckedHsExpr are now HsExpr RdrName,
HsExpr Name, and HsExpr Id respectively).
- Utilities over HsSyn are now collected in a new module HsUtils.
More stuff still needs to be moved in here.
- MachChar now has a real Char instead of an Int. All GHC versions that
can compile GHC now support 32-bit Chars, so this was a simplification.
100 files changed, 6868 insertions, 6574 deletions
diff --git a/ghc/compiler/HsVersions.h b/ghc/compiler/HsVersions.h index 853e58661e..ff6e5ae186 100644 --- a/ghc/compiler/HsVersions.h +++ b/ghc/compiler/HsVersions.h @@ -52,6 +52,12 @@ name = Util.global (value) :: IORef (ty); \ {-# NOINLINE name #-} #endif +#if __GLASGOW_HASKELL__ >= 620 +#define UNBOX_FIELD !! +#else +#define UNBOX_FIELD ! +#endif + #define COMMA , #ifdef DEBUG diff --git a/ghc/compiler/Makefile b/ghc/compiler/Makefile index 2f618ba645..ec9eb414b0 100644 --- a/ghc/compiler/Makefile +++ b/ghc/compiler/Makefile @@ -354,13 +354,13 @@ prelude/PrelRules_HC_OPTS = -fvia-C main/ParsePkgConf_HC_OPTS += -fno-warn-incomplete-patterns # Use -fvia-C since the NCG can't handle the narrow16Int# (and intToInt16#?) # primops on all platforms. -parser/Parser_HC_OPTS += -Onot -fno-warn-incomplete-patterns -fvia-C +parser/Parser_HC_OPTS += -fno-warn-incomplete-patterns -fvia-C -# The latest GHC version doesn't have a -K option yet, and it doesn't -# seem to be necessary anymore for the modules below. -ifeq "$(compiling_with_4xx)" "YES" -parser/Parser_HC_OPTS += -K2m -endif +# Careful optimisation of the parser: we don't want to throw everything +# at it, because that takes too long and doesn't buy much, but we do want +# to inline certain key external functions, so we instruct GHC not to +# throw away inlinings as it would normally do in -Onot mode: +parser/Parser_HC_OPTS += -Onot -fno-ignore-interface-pragmas ifeq "$(HOSTPLATFORM)" "hppa1.1-hp-hpux9" rename/RnMonad_HC_OPTS = -O2 -O2-for-C @@ -368,6 +368,8 @@ endif utils/Digraph_HC_OPTS = -fglasgow-exts +basicTypes/SrcLoc_HC_OPTS = -funbox-strict-fields + ifeq "$(bootstrapped)" "YES" utils/Binary_HC_OPTS = -funbox-strict-fields endif @@ -569,6 +571,9 @@ MAINTAINER_CLEAN_FILES += parser/Parser.info main/ParsePkgConf.info MKDEPENDHS_SRCS = MKDEPENDC_SRCS = +# Make doesn't work this out for itself, it seems +parser/Parser.y : parser/Parser.y.pp + include $(TOP)/mk/target.mk # ----------------------------------------------------------------------------- diff --git a/ghc/compiler/basicTypes/Literal.lhs b/ghc/compiler/basicTypes/Literal.lhs index 3781abefe9..35d9ba0fea 100644 --- a/ghc/compiler/basicTypes/Literal.lhs +++ b/ghc/compiler/basicTypes/Literal.lhs @@ -96,7 +96,7 @@ function applications, etc., etc., has not yet been done. data Literal = ------------------ -- First the primitive guys - MachChar Int -- Char# At least 31 bits + MachChar Char -- Char# At least 31 bits | MachStr FastString | MachNullAddr -- the NULL pointer, the only pointer value @@ -211,8 +211,8 @@ inIntRange, inWordRange :: Integer -> Bool inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT inWordRange x = x >= 0 && x <= tARGET_MAX_WORD -inCharRange :: Int -> Bool -inCharRange c = c >= 0 && c <= tARGET_MAX_CHAR +inCharRange :: Char -> Bool +inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR isZeroLit :: Literal -> Bool isZeroLit (MachInt 0) = True @@ -250,8 +250,8 @@ narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8)) narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16)) narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32)) -char2IntLit (MachChar c) = MachInt (toInteger c) -int2CharLit (MachInt i) = MachChar (fromInteger i) +char2IntLit (MachChar c) = MachInt (toInteger (ord c)) +int2CharLit (MachInt i) = MachChar (chr (fromInteger i)) float2IntLit (MachFloat f) = MachInt (truncate f) int2FloatLit (MachInt i) = MachFloat (fromInteger i) @@ -366,7 +366,7 @@ pprLit lit code_style = codeStyle sty in case lit of - MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show ch)] + MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show (ord ch))] | otherwise -> pprHsChar ch MachStr s | code_style -> pprFSInCStyle s @@ -439,7 +439,7 @@ Hash values should be zero or a positive integer. No negatives please. \begin{code} hashLiteral :: Literal -> Int -hashLiteral (MachChar c) = c + 1000 -- Keep it out of range of common ints +hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints hashLiteral (MachStr s) = hashFS s hashLiteral (MachNullAddr) = 0 hashLiteral (MachInt i) = hashInteger i diff --git a/ghc/compiler/basicTypes/RdrName.lhs b/ghc/compiler/basicTypes/RdrName.lhs index 12fbf73f01..b7b9ed238c 100644 --- a/ghc/compiler/basicTypes/RdrName.lhs +++ b/ghc/compiler/basicTypes/RdrName.lhs @@ -51,7 +51,7 @@ import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS ) import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe, nameOccName, isExternalName, nameSrcLoc ) import Maybes ( seqMaybe ) -import SrcLoc ( SrcLoc, isGoodSrcLoc ) +import SrcLoc ( SrcLoc, isGoodSrcLoc, SrcSpan ) import BasicTypes( DeprecTxt ) import Outputable import Util ( thenCmp ) @@ -433,7 +433,7 @@ data ImportSpec -- Describes a particular import declaration -- the defining module for this thing! is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause) is_qual :: Bool, -- True <=> qualified (only) - is_loc :: SrcLoc } -- Location of import statment + is_loc :: SrcSpan } -- Location of import statment -- Comparison of provenance is just used for grouping -- error messages (in RnEnv.warnUnusedBinds) diff --git a/ghc/compiler/basicTypes/SrcLoc.lhs b/ghc/compiler/basicTypes/SrcLoc.lhs index cd3513568c..8b25be9c4c 100644 --- a/ghc/compiler/basicTypes/SrcLoc.lhs +++ b/ghc/compiler/basicTypes/SrcLoc.lhs @@ -1,5 +1,5 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The University of Glasgow, 1992-2003 % %************************************************************************ %* * @@ -23,16 +23,27 @@ module SrcLoc ( srcLocFile, -- return the file name part srcLocLine, -- return the line part srcLocCol, -- return the column part + + + SrcSpan, -- Abstract + noSrcSpan, + mkGeneralSrcSpan, + isGoodSrcSpan, + mkSrcSpan, srcLocSpan, + combineSrcSpans, + srcSpanFile, + srcSpanStartLine, srcSpanEndLine, + srcSpanStartCol, srcSpanEndCol, + srcSpanStart, srcSpanEnd, + + Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc ) where #include "HsVersions.h" import Util ( thenCmp ) import Outputable -import FastTypes import FastString - -import GLAEXTS ( (+#), quotInt# ) \end{code} %************************************************************************ @@ -46,8 +57,10 @@ this is the obvious stuff: \begin{code} data SrcLoc = SrcLoc FastString -- A precise location (file name) - FastInt -- line - FastInt -- column + !Int -- line number, begins at 1 + !Int -- column number, begins at 0 + -- Don't ask me why lines start at 1 and columns start at + -- zero. That's just the way it is, so there. --SDM | ImportedLoc String -- Module name @@ -81,8 +94,8 @@ rare case. Things to make 'em: \begin{code} -mkSrcLoc x line col = SrcLoc x (iUnbox line) (iUnbox col) -noSrcLoc = UnhelpfulLoc FSLIT("<no locn>") +mkSrcLoc x line col = SrcLoc x line col +noSrcLoc = UnhelpfulLoc FSLIT("<no location info>") generatedSrcLoc = UnhelpfulLoc FSLIT("<compiler-generated code>") wiredInSrcLoc = UnhelpfulLoc FSLIT("<wired into compiler>") interactiveSrcLoc = UnhelpfulLoc FSLIT("<interactive session>") @@ -101,22 +114,22 @@ srcLocFile (SrcLoc fname _ _) = fname srcLocFile other = FSLIT("<unknown file") srcLocLine :: SrcLoc -> Int -srcLocLine (SrcLoc _ l c) = iBox l +srcLocLine (SrcLoc _ l c) = l srcLocLine other = panic "srcLocLine: unknown line" srcLocCol :: SrcLoc -> Int -srcLocCol (SrcLoc _ l c) = iBox c +srcLocCol (SrcLoc _ l c) = c srcLocCol other = panic "srcLocCol: unknown col" advanceSrcLoc :: SrcLoc -> Char -> SrcLoc advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (tab c) -advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l +# 1#) 0# -advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c +# 1#) +advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l + 1) 0 +advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1) advanceSrcLoc loc _ = loc -- Better than nothing -- Advance to the next tab stop. Tabs are at column positions 0, 8, 16, etc. -tab :: FastInt -> FastInt -tab c = (c `quotInt#` 8# +# 1#) *# 8# +tab :: Int -> Int +tab c = (c `quot` 8 + 1) * 8 \end{code} %************************************************************************ @@ -145,8 +158,8 @@ cmpSrcLoc (ImportedLoc _) other = LT cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2) = (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) `thenCmp` (c1 `cmpline` c2) where - l1 `cmpline` l2 | l1 <# l2 = LT - | l1 ==# l2 = EQ + l1 `cmpline` l2 | l1 < l2 = LT + | l1 == l2 = EQ | otherwise = GT cmpSrcLoc (SrcLoc _ _ _) other = GT @@ -155,13 +168,228 @@ instance Outputable SrcLoc where = getPprStyle $ \ sty -> if userStyle sty || debugStyle sty then hcat [ ftext src_path, char ':', - int (iBox src_line) - {- TODO: char ':', int (iBox src_col) -} + int src_line, + char ':', int src_col ] else - hcat [text "{-# LINE ", int (iBox src_line), space, + hcat [text "{-# LINE ", int src_line, space, char '\"', ftext src_path, text " #-}"] ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> quotes (text mod) ppr (UnhelpfulLoc s) = ftext s \end{code} + +%************************************************************************ +%* * +\subsection[SrcSpan]{Source Spans} +%* * +%************************************************************************ + +\begin{code} +{- | +A SrcSpan delimits a portion of a text file. It could be represented +by a pair of (line,column) coordinates, but in fact we optimise +slightly by using more compact representations for single-line and +zero-length spans, both of which are quite common. + +The end position is defined to be the column *after* the end of the +span. That is, a span of (1,1)-(1,2) is one character long, and a +span of (1,1)-(1,1) is zero characters long. +-} +data SrcSpan + = SrcSpanOneLine -- a common case: a single line + { srcSpanFile :: FastString, + srcSpanLine :: !Int, + srcSpanSCol :: !Int, + srcSpanECol :: !Int + } + + | SrcSpanMultiLine + { srcSpanFile :: FastString, + srcSpanSLine :: !Int, + srcSpanSCol :: !Int, + srcSpanELine :: !Int, + srcSpanECol :: !Int + } + + | SrcSpanPoint + { srcSpanFile :: FastString, + srcSpanLine :: !Int, + srcSpanCol :: !Int + } + + | ImportedSpan String -- Module name + + | UnhelpfulSpan FastString -- Just a general indication + -- also used to indicate an empty span + + deriving Eq + +-- We want to order SrcSpans first by the start point, then by the end point. +instance Ord SrcSpan where + a `compare` b = + (srcSpanStart a `compare` srcSpanStart b) `thenCmp` + (srcSpanEnd a `compare` srcSpanEnd b) + +noSrcSpan = UnhelpfulSpan FSLIT("<no location info>") + +mkGeneralSrcSpan :: FastString -> SrcSpan +mkGeneralSrcSpan = UnhelpfulSpan + +isGoodSrcSpan SrcSpanOneLine{} = True +isGoodSrcSpan SrcSpanMultiLine{} = True +isGoodSrcSpan SrcSpanPoint{} = True +isGoodSrcSpan _ = False + +srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l +srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l +srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l +srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine" + +srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l +srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l +srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l +srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine" + +srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l +srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l +srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l +srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol" + +srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c +srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c +srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c +srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol" + +srcSpanStart (ImportedSpan str) = ImportedLoc str +srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanStart s = + mkSrcLoc (srcSpanFile s) + (srcSpanStartLine s) + (srcSpanStartCol s) + +srcSpanEnd (ImportedSpan str) = ImportedLoc str +srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str +srcSpanEnd s = + mkSrcLoc (srcSpanFile s) + (srcSpanEndLine s) + (srcSpanEndCol s) + +srcLocSpan :: SrcLoc -> SrcSpan +srcLocSpan (ImportedLoc str) = ImportedSpan str +srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str +srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col + +mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan +mkSrcSpan (ImportedLoc str) _ = ImportedSpan str +mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str +mkSrcSpan _ (ImportedLoc str) = ImportedSpan str +mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str +mkSrcSpan loc1 loc2 + | line1 == line2 = if col1 == col2 + then SrcSpanPoint file line1 col1 + else SrcSpanOneLine file line1 col1 col2 + | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 + where + line1 = srcLocLine loc1 + line2 = srcLocLine loc2 + col1 = srcLocCol loc1 + col2 = srcLocCol loc2 + file = srcLocFile loc1 + +combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan +combineSrcSpans (ImportedSpan str) _ = ImportedSpan str +combineSrcSpans (UnhelpfulSpan str) r = r -- this seems more useful +combineSrcSpans _ (ImportedSpan str) = ImportedSpan str +combineSrcSpans l (UnhelpfulSpan str) = l +combineSrcSpans start end + | line1 == line2 = if col1 == col2 + then SrcSpanPoint file line1 col1 + else SrcSpanOneLine file line1 col1 col2 + | otherwise = SrcSpanMultiLine file line1 col1 line2 col2 + where + line1 = srcSpanStartLine start + line2 = srcSpanEndLine end + col1 = srcSpanStartCol start + col2 = srcSpanEndCol end + file = srcSpanFile start + +instance Outputable SrcSpan where + ppr span + = getPprStyle $ \ sty -> + if userStyle sty || debugStyle sty then + pprUserSpan span + else + hcat [text "{-# LINE ", int (srcSpanStartLine span), space, + char '\"', ftext (srcSpanFile span), text " #-}"] + + +pprUserSpan (SrcSpanOneLine src_path line start_col end_col) + = hcat [ ftext src_path, char ':', + int line, + char ':', int start_col + ] + <> if end_col - start_col <= 1 + then empty + -- for single-character or point spans, we just output the starting + -- column number + else char '-' <> int (end_col-1) + +pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol) + = hcat [ ftext src_path, char ':', + parens (int sline <> char ',' <> int scol), + char '-', + parens (int eline <> char ',' <> + if ecol == 0 then int ecol else int (ecol-1)) + ] + +pprUserSpan (SrcSpanPoint src_path line col) + = hcat [ ftext src_path, char ':', + int line, + char ':', int col + ] + +pprUserSpan (ImportedSpan mod) = ptext SLIT("Imported from") <+> quotes (text mod) +pprUserSpan (UnhelpfulSpan s) = ftext s +\end{code} + +%************************************************************************ +%* * +\subsection[Located]{Attaching SrcSpans to things} +%* * +%************************************************************************ + +\begin{code} +-- | We attach SrcSpans to lots of things, so let's have a datatype for it. +data Located e = L SrcSpan e + +unLoc :: Located e -> e +unLoc (L _ e) = e + +getLoc :: Located e -> SrcSpan +getLoc (L l _) = l + +noLoc :: e -> Located e +noLoc e = L noSrcSpan e + +combineLocs :: Located a -> Located b -> SrcSpan +combineLocs a b = combineSrcSpans (getLoc a) (getLoc b) + +addCLoc :: Located a -> Located b -> c -> Located c +addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c + +-- not clear whether to add a general Eq instance, but this is useful sometimes: +eqLocated :: Eq a => Located a -> Located a -> Bool +eqLocated a b = unLoc a == unLoc b + +-- not clear whether to add a general Eq instance, but this is useful sometimes: +cmpLocated :: Ord a => Located a -> Located a -> Ordering +cmpLocated a b = unLoc a `compare` unLoc b + +instance Functor Located where + fmap f (L l e) = L l (f e) + +instance Outputable e => Outputable (Located e) where + ppr (L span e) = ppr e + -- do we want to dump the span in debugSty mode? +\end{code} diff --git a/ghc/compiler/codeGen/CgCon.lhs b/ghc/compiler/codeGen/CgCon.lhs index 47ac572ddf..4b8e8c2bac 100644 --- a/ghc/compiler/codeGen/CgCon.lhs +++ b/ghc/compiler/codeGen/CgCon.lhs @@ -51,6 +51,7 @@ import Util import Outputable import List ( partition ) +import Char ( ord ) \end{code} %************************************************************************ @@ -172,7 +173,8 @@ buildDynCon binder cc con [arg_amode] | maybeCharLikeCon con && in_range_char_lit arg_amode = returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con)) where - in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE + in_range_char_lit (CLit (MachChar val)) = + ord val <= mAX_CHARLIKE && ord val >= mIN_CHARLIKE in_range_char_lit _other_amode = False \end{code} diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 5915c2b119..405767e005 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -25,8 +25,8 @@ import Subst ( substTyWith ) import Name ( getSrcLoc ) import PprCore import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass, - addErrLocHdrLine ) -import SrcLoc ( SrcLoc, noSrcLoc ) + mkLocMessage ) +import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan ) import Type ( Type, tyVarsOfType, eqType, splitFunTy_maybe, mkTyVarTy, splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp, @@ -521,7 +521,7 @@ addErr errs_so_far msg locs context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1 | otherwise = cxt1 - mk_msg msg = addErrLocHdrLine loc context msg + mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg) addLoc :: LintLocInfo -> LintM a -> LintM a addLoc extra_loc m loc scope errs diff --git a/ghc/compiler/coreSyn/MkExternalCore.lhs b/ghc/compiler/coreSyn/MkExternalCore.lhs index 66fa9711e3..8ad5c7f185 100644 --- a/ghc/compiler/coreSyn/MkExternalCore.lhs +++ b/ghc/compiler/coreSyn/MkExternalCore.lhs @@ -164,9 +164,7 @@ make_alt (DEFAULT,[],e) = C.Adefault (make_exp e) make_lit :: Literal -> C.Lit make_lit l = case l of - MachChar i | i <= 0xff -> C.Lchar (chr i) t - MachChar i | otherwise -> C.Lint (toEnum i) t - -- For big characters, use an integer literal with a character type sig + MachChar i -> C.Lchar i t MachStr s -> C.Lstring (unpackFS s) t MachNullAddr -> C.Lint 0 t MachInt i -> C.Lint i t diff --git a/ghc/compiler/deSugar/Check.lhs b/ghc/compiler/deSugar/Check.lhs index 2fc2e8e089..d1ae572578 100644 --- a/ghc/compiler/deSugar/Check.lhs +++ b/ghc/compiler/deSugar/Check.lhs @@ -11,19 +11,19 @@ module Check ( check , ExhaustivePat ) where import HsSyn -import TcHsSyn ( TypecheckedPat, hsPatType ) +import TcHsSyn ( hsPatType ) import TcType ( tcTyConAppTyCon ) import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet, CanItFail(..), tidyLitPat, tidyNPat, ) -import Id ( idType ) +import Id ( Id, idType ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels ) import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc ) import TysWiredIn import PrelNames ( unboundKey ) import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon ) import BasicTypes ( Boxity(..) ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, Located(..), getLoc, unLoc, noLoc ) import UniqSet import Util ( takeList, splitAtList, notNull ) import Outputable @@ -131,23 +131,25 @@ untidy_pars :: WarningPat -> WarningPat untidy_pars p = untidy True p untidy :: NeedPars -> WarningPat -> WarningPat -untidy _ p@(WildPat _) = p -untidy _ p@(VarPat name) = p -untidy _ (LitPat lit) = LitPat (untidy_lit lit) -untidy _ p@(ConPatIn name (PrefixCon [])) = p -untidy b (ConPatIn name ps) = pars b (ConPatIn name (untidy_con ps)) -untidy _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty -untidy _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed -untidy _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" -untidy _ (SigPatIn _ _) = panic "Check.untidy: SigPat" +untidy b (L loc p) = L loc (untidy' b p) + where + untidy' _ p@(WildPat _) = p + untidy' _ p@(VarPat name) = p + untidy' _ (LitPat lit) = LitPat (untidy_lit lit) + untidy' _ p@(ConPatIn name (PrefixCon [])) = p + untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps))) + untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty + untidy' _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed + untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!" + untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat" untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats) untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2) untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs] -pars :: NeedPars -> WarningPat -> WarningPat +pars :: NeedPars -> WarningPat -> Pat Name pars True p = ParPat p -pars _ p = p +pars _ p = unLoc p untidy_lit :: HsLit -> HsLit untidy_lit (HsCharPrim c) = HsChar c @@ -186,7 +188,7 @@ check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet) check' [] = ([([],[])],emptyUniqSet) check' [EqnInfo n ctx ps (MatchResult CanFail _)] - | all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n) + | all_vars ps = ([(takeList ps (repeat wildPat),[])], unitUniqSet n) check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs) | all_vars ps = (pats, addOneToUniqSet indexs n) @@ -251,7 +253,7 @@ process_literals used_lits qs default_eqns = ASSERT2( okGroup qs, pprGroup qs ) map remove_var (filter (is_var . firstPat) qs) (pats',indexs') = check' default_eqns - pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats + pats_default = [(wildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats indexs_default = unionUniqSets indexs' indexs \end{code} @@ -264,7 +266,7 @@ construct_literal_matrix lit qs = (map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs) where (pats,indexs) = (check' (remove_first_column_lit lit qs)) - new_lit = LitPat lit + new_lit = nlLitPat lit remove_first_column_lit :: HsLit -> [EquationInfo] @@ -299,7 +301,7 @@ nothing to do. \begin{code} first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet) -first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs) +first_column_only_vars qs = (map (\ (xs,ys) -> (wildPat:xs,ys)) pats,indexs) where (pats,indexs) = check' (map remove_var qs) @@ -314,13 +316,13 @@ constructors or not explicitly. The reasoning is similar to @process_literals@, the difference is that here the default case is not always needed. \begin{code} -no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +no_need_default_case :: [Pat Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs) where pats_indexs = map (\x -> construct_matrix x qs) cons (pats,indexs) = unzip pats_indexs -need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +need_default_case :: [Pat Id] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet) need_default_case used_cons unused_cons qs | null default_eqns = (pats_default_no_eqns,indexs) | otherwise = (pats_default,indexs_default) @@ -334,7 +336,7 @@ need_default_case used_cons unused_cons qs pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats indexs_default = unionUniqSets indexs' indexs -construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet) +construct_matrix :: Pat Id -> [EquationInfo] -> ([ExhaustivePat],EqnSet) construct_matrix con qs = (map (make_con con) pats,indexs) where @@ -356,7 +358,7 @@ is transformed in: \end{verbatim} \begin{code} -remove_first_column :: TypecheckedPat -- Constructor +remove_first_column :: Pat Id -- Constructor -> [EquationInfo] -> [EquationInfo] remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs @@ -365,14 +367,14 @@ remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs where new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats] shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) = - EqnInfo n ctx (ps'++ps) result + EqnInfo n ctx (map unLoc ps'++ps) result shift_var (EqnInfo n ctx (WildPat _ :ps) result) = EqnInfo n ctx (new_wilds ++ ps) result shift_var _ = panic "Check.Shift_var:No done" make_row_vars :: [HsLit] -> EquationInfo -> ExhaustivePat make_row_vars used_lits (EqnInfo _ _ pats _ ) = - (VarPat new_var:takeList (tail pats) (repeat new_wild_pat),[(new_var,used_lits)]) + (nlVarPat new_var:takeList (tail pats) (repeat wildPat),[(new_var,used_lits)]) where new_var = hash_x hash_x = mkInternalName unboundKey {- doesn't matter much -} @@ -380,17 +382,17 @@ hash_x = mkInternalName unboundKey {- doesn't matter much -} noSrcLoc make_row_vars_for_constructor :: EquationInfo -> [WarningPat] -make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat new_wild_pat) +make_row_vars_for_constructor (EqnInfo _ _ pats _ ) = takeList (tail pats) (repeat wildPat) -compare_cons :: TypecheckedPat -> TypecheckedPat -> Bool +compare_cons :: Pat Id -> Pat Id -> Bool compare_cons (ConPatOut id1 _ _ _ _) (ConPatOut id2 _ _ _ _) = id1 == id2 -remove_dups :: [TypecheckedPat] -> [TypecheckedPat] +remove_dups :: [Pat Id] -> [Pat Id] remove_dups [] = [] remove_dups (x:xs) | or (map (\y -> compare_cons x y) xs) = remove_dups xs | otherwise = x : remove_dups xs -get_used_cons :: [EquationInfo] -> [TypecheckedPat] +get_used_cons :: [EquationInfo] -> [Pat Id] get_used_cons qs = remove_dups [con | (EqnInfo _ _ (con@(ConPatOut _ _ _ _ _):_) _) <- qs ] remove_dups' :: [HsLit] -> [HsLit] @@ -413,7 +415,7 @@ get_used_lits' ((EqnInfo _ _ ((NPatOut lit _ _):_) _):qs) = get_used_lits' (q:qs) = get_used_lits qs -get_unused_cons :: [TypecheckedPat] -> [DataCon] +get_unused_cons :: [Pat Id] -> [DataCon] get_unused_cons used_cons = unused_cons where (ConPatOut _ _ ty _ _) = head used_cons @@ -423,10 +425,10 @@ get_unused_cons used_cons = unused_cons unused_cons = uniqSetToList (mkUniqSet all_cons `minusUniqSet` mkUniqSet used_cons_as_id) -all_vars :: [TypecheckedPat] -> Bool -all_vars [] = True -all_vars (WildPat _:ps) = all_vars ps -all_vars _ = False +all_vars :: [Pat Id] -> Bool +all_vars [] = True +all_vars (WildPat _:ps) = all_vars ps +all_vars _ = False remove_var :: EquationInfo -> EquationInfo remove_var (EqnInfo n ctx (WildPat _:ps) result) = EqnInfo n ctx ps result @@ -434,10 +436,10 @@ remove_var _ = panic "Check.remove_var: equation does not begin with a variable" ----------------------- -eqnPats :: EquationInfo -> [TypecheckedPat] +eqnPats :: EquationInfo -> [Pat Id] eqnPats (EqnInfo _ _ ps _) = ps -firstPat :: EquationInfo -> TypecheckedPat +firstPat :: EquationInfo -> Pat Id firstPat eqn_info = head (eqnPats eqn_info) okGroup :: [EquationInfo] -> Bool @@ -452,33 +454,33 @@ okGroup (e:es) = n_pats > 0 && and [length (eqnPats e) == n_pats | e <- es] pprGroup es = vcat (map pprEqnInfo es) pprEqnInfo e = ppr (eqnPats e) -is_con :: TypecheckedPat -> Bool +is_con :: Pat Id -> Bool is_con (ConPatOut _ _ _ _ _) = True is_con _ = False -is_lit :: TypecheckedPat -> Bool +is_lit :: Pat Id -> Bool is_lit (LitPat _) = True is_lit (NPatOut _ _ _) = True is_lit _ = False -is_npat :: TypecheckedPat -> Bool +is_npat :: Pat Id -> Bool is_npat (NPatOut _ _ _) = True is_npat _ = False -is_nplusk :: TypecheckedPat -> Bool +is_nplusk :: Pat Id -> Bool is_nplusk (NPlusKPatOut _ _ _ _) = True is_nplusk _ = False -is_var :: TypecheckedPat -> Bool +is_var :: Pat Id -> Bool is_var (WildPat _) = True is_var _ = False -is_var_con :: DataCon -> TypecheckedPat -> Bool +is_var_con :: DataCon -> Pat Id -> Bool is_var_con con (WildPat _) = True is_var_con con (ConPatOut id _ _ _ _) | id == con = True is_var_con con _ = False -is_var_lit :: HsLit -> TypecheckedPat -> Bool +is_var_lit :: HsLit -> Pat Id -> Bool is_var_lit lit (WildPat _) = True is_var_lit lit (LitPat lit') | lit == lit' = True is_var_lit lit (NPatOut lit' _ _) | lit == lit' = True @@ -525,7 +527,7 @@ not the second. \fbox{\ ???\ } \begin{code} isInfixCon con = isDataSymOcc (getOccName con) -is_nil (ConPatIn con (PrefixCon [])) = con == getName nilDataCon +is_nil (ConPatIn con (PrefixCon [])) = unLoc con == getName nilDataCon is_nil _ = False is_list (ListPat _ _) = True @@ -537,15 +539,17 @@ make_list p q | is_nil q = ListPat [p] placeHolderType make_list p (ListPat ps ty) = ListPat (p:ps) ty make_list _ _ = panic "Check.make_list: Invalid argument" -make_con :: TypecheckedPat -> ExhaustivePat -> ExhaustivePat -make_con (ConPatOut id _ _ _ _) (p:q:ps, constraints) - | return_list id q = (make_list p q : ps, constraints) - | isInfixCon id = (ConPatIn (getName id) (InfixCon p q) : ps, constraints) +make_con :: Pat Id -> ExhaustivePat -> ExhaustivePat +make_con (ConPatOut id _ _ _ _) (lp:lq:ps, constraints) + | return_list id q = (noLoc (make_list lp q) : ps, constraints) + | isInfixCon id = (nlInfixConPat (getName id) lp lq : ps, constraints) + where p = unLoc lp + q = unLoc lq make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) - | isTupleTyCon tc = (TuplePat pats_con (tupleTyConBoxity tc) : rest_pats, constraints) - | isPArrFakeCon id = (PArrPat pats_con placeHolderType : rest_pats, constraints) - | otherwise = (ConPatIn name (PrefixCon pats_con) : rest_pats, constraints) + | isTupleTyCon tc = (noLoc (TuplePat pats_con (tupleTyConBoxity tc)) : rest_pats, constraints) + | isPArrFakeCon id = (noLoc (PArrPat pats_con placeHolderType) : rest_pats, constraints) + | otherwise = (nlConPat name pats_con : rest_pats, constraints) where name = getName id (pats_con, rest_pats) = splitAtList pats ps @@ -558,14 +562,11 @@ make_con (ConPatOut id (PrefixCon pats) _ _ _) (ps, constraints) -- representation make_whole_con :: DataCon -> WarningPat -make_whole_con con | isInfixCon con = ConPatIn name (InfixCon new_wild_pat new_wild_pat) - | otherwise = ConPatIn name (PrefixCon pats) +make_whole_con con | isInfixCon con = nlInfixConPat name wildPat wildPat + | otherwise = nlConPat name pats where name = getName con - pats = [new_wild_pat | t <- dataConOrigArgTys con] - -new_wild_pat :: WarningPat -new_wild_pat = WildPat placeHolderType + pats = [wildPat | t <- dataConOrigArgTys con] \end{code} This equation makes the same thing as @tidy@ in @Match.lhs@, the @@ -582,83 +583,85 @@ simplify_eqns ((EqnInfo n ctx pats result):qs) = where pats' = map simplify_pat pats -simplify_pat :: TypecheckedPat -> TypecheckedPat +simplify_lpat :: LPat Id -> LPat Id +simplify_lpat p = fmap simplify_pat p +simplify_pat :: Pat Id -> Pat Id simplify_pat pat@(WildPat gt) = pat simplify_pat (VarPat id) = WildPat (idType id) -simplify_pat (ParPat p) = simplify_pat p -simplify_pat (LazyPat p) = simplify_pat p -simplify_pat (AsPat id p) = simplify_pat p -simplify_pat (SigPatOut p ty fn) = simplify_pat p -- I'm not sure this is right +simplify_pat (ParPat p) = unLoc (simplify_lpat p) +simplify_pat (LazyPat p) = unLoc (simplify_lpat p) +simplify_pat (AsPat id p) = unLoc (simplify_lpat p) +simplify_pat (SigPatOut p ty fn) = unLoc (simplify_lpat p) -- I'm not sure this is right simplify_pat (ConPatOut id ps ty tvs dicts) = ConPatOut id (simplify_con id ps) ty tvs dicts -simplify_pat (ListPat ps ty) = foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) - (mkNilPat list_ty) - (map simplify_pat ps) - where list_ty = mkListTy ty +simplify_pat (ListPat ps ty) = + unLoc $ foldr (\ x y -> mkPrefixConPat consDataCon [x,y] list_ty) + (mkNilPat list_ty) + (map simplify_lpat ps) + where list_ty = mkListTy ty -- introduce fake parallel array constructors to be able to handle parallel -- arrays with the existing machinery for constructor pattern -- simplify_pat (PArrPat ps ty) = ConPatOut (parrFakeCon arity) - (PrefixCon (map simplify_pat ps)) + (PrefixCon (map simplify_lpat ps)) (mkPArrTy ty) [] [] where arity = length ps simplify_pat (TuplePat ps boxity) = ConPatOut (tupleCon boxity arity) - (PrefixCon (map simplify_pat ps)) + (PrefixCon (map simplify_lpat ps)) (mkTupleTy boxity arity (map hsPatType ps)) [] [] where arity = length ps -simplify_pat pat@(LitPat lit) = tidyLitPat lit pat +simplify_pat pat@(LitPat lit) = unLoc (tidyLitPat lit (noLoc pat)) -- unpack string patterns fully, so we can see when they overlap with -- each other, or even explicit lists of Chars. simplify_pat pat@(NPatOut (HsString s) _ _) = - foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,pat]) stringTy [] []) - (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackIntFS s) + foldr (\c pat -> ConPatOut consDataCon (PrefixCon [mk_char_lit c,noLoc pat]) stringTy [] []) + (ConPatOut nilDataCon (PrefixCon []) stringTy [] []) (unpackFS s) where - mk_char_lit c = ConPatOut charDataCon (PrefixCon [LitPat (HsCharPrim c)]) + mk_char_lit c = noLoc $ + ConPatOut charDataCon (PrefixCon [nlLitPat (HsCharPrim c)]) charTy [] [] -simplify_pat pat@(NPatOut lit lit_ty hsexpr) = tidyNPat lit lit_ty pat +simplify_pat pat@(NPatOut lit lit_ty hsexpr) = unLoc (tidyNPat lit lit_ty (noLoc pat)) simplify_pat (NPlusKPatOut id hslit hsexpr1 hsexpr2) - = WildPat (idType id) + = WildPat (idType (unLoc id)) simplify_pat (DictPat dicts methods) = case num_of_d_and_ms of 0 -> simplify_pat (TuplePat [] Boxed) 1 -> simplify_pat (head dict_and_method_pats) - _ -> simplify_pat (TuplePat dict_and_method_pats Boxed) + _ -> simplify_pat (TuplePat (map noLoc dict_and_method_pats) Boxed) where num_of_d_and_ms = length dicts + length methods dict_and_method_pats = map VarPat (dicts ++ methods) ----------------- -simplify_con con (PrefixCon ps) = PrefixCon (map simplify_pat ps) -simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_pat p1, simplify_pat p2] +simplify_con con (PrefixCon ps) = PrefixCon (map simplify_lpat ps) +simplify_con con (InfixCon p1 p2) = PrefixCon [simplify_lpat p1, simplify_lpat p2] simplify_con con (RecCon fs) - | null fs = PrefixCon [wild_pat | t <- dataConOrigArgTys con] + | null fs = PrefixCon [wildPat | t <- dataConOrigArgTys con] -- Special case for null patterns; maybe not a record at all - | otherwise = PrefixCon (map (simplify_pat.snd) all_pats) + | otherwise = PrefixCon (map (simplify_lpat.snd) all_pats) where -- pad out all the missing fields with WildPats. - field_pats = map (\ f -> (getName f, wild_pat)) + field_pats = map (\ f -> (getName f, wildPat)) (dataConFieldLabels con) - all_pats = foldr (\ (id,p) acc -> insertNm (getName id) p acc) + all_pats = foldr (\ (id,p) acc -> insertNm (getName (unLoc id)) p acc) field_pats fs insertNm nm p [] = [(nm,p)] insertNm nm p (x@(n,_):xs) | nm == n = (nm,p):xs | otherwise = x : insertNm nm p xs - - wild_pat = WildPat (panic "Check.simplify_con") \end{code} diff --git a/ghc/compiler/deSugar/Desugar.lhs b/ghc/compiler/deSugar/Desugar.lhs index 153cc1a323..d95ca8ceb6 100644 --- a/ghc/compiler/deSugar/Desugar.lhs +++ b/ghc/compiler/deSugar/Desugar.lhs @@ -12,9 +12,8 @@ import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn ) import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..), Dependencies(..), TypeEnv, unQualInScope, availsToNameSet ) -import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..), - HsExpr(..), HsBinds(..), MonoBinds(..) ) -import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr ) +import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr, + HsBindGroup(..), LRuleDecl, HsBind(..) ) import TcRnTypes ( TcGblEnv(..), ImportAvails(..) ) import MkIface ( mkUsageInfo ) import Id ( Id, setIdLocalExported, idName ) @@ -23,8 +22,8 @@ import CoreSyn import PprCore ( pprIdRules, pprCoreExpr ) import Subst ( substExpr, mkSubst, mkInScopeSet ) import DsMonad -import DsExpr ( dsExpr ) -import DsBinds ( dsMonoBinds, AutoScc(..) ) +import DsExpr ( dsLExpr ) +import DsBinds ( dsHsBinds, AutoScc(..) ) import DsForeign ( dsForeigns ) import DsExpr () -- Forces DsExpr to be compiled; DsBinds only -- depends on DsExpr.hi-boot. @@ -34,15 +33,15 @@ import RdrName ( GlobalRdrEnv ) import NameSet import VarEnv import VarSet -import Bag ( isEmptyBag, mapBag, emptyBag ) +import Bag ( isEmptyBag, mapBag, emptyBag, bagToList ) import CoreLint ( showPass, endPass ) import CoreFVs ( ruleRhsFreeVars ) import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings, - addShortWarnLocLine, errorsFound ) + mkWarnMsg, errorsFound, WarnMsg ) import Outputable import qualified Pretty import UniqSupply ( mkSplitUniqSupply ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), SrcSpan, unLoc ) import DATA_IOREF ( readIORef ) import FastString \end{code} @@ -127,13 +126,13 @@ deSugar hsc_env -- Desugarer warnings are SDocs; here we -- add the info about whether or not to print unqualified - mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc) - mk_warn (loc, sdoc) = addShortWarnLocLine loc print_unqual sdoc + mk_warn :: (SrcSpan,SDoc) -> WarnMsg + mk_warn (loc, sdoc) = mkWarnMsg loc print_unqual sdoc deSugarExpr :: HscEnv -> Module -> GlobalRdrEnv -> TypeEnv - -> TypecheckedHsExpr + -> LHsExpr Id -> IO CoreExpr deSugarExpr hsc_env this_mod rdr_env type_env tc_expr = do { showPass dflags "Desugar" @@ -143,7 +142,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr ; let { is_boot = emptyModuleEnv } -- Assume no hi-boot files when -- doing stuff from the command line ; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env is_boot $ - dsExpr tc_expr + dsLExpr tc_expr -- Display any warnings -- Note: if -Werror is used, we don't signal an error here. @@ -159,8 +158,8 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr dflags = hsc_dflags hsc_env print_unqual = unQualInScope rdr_env - mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc) - mk_warn (loc,sdoc) = addShortWarnLocLine loc print_unqual sdoc + mk_warn :: (SrcSpan,SDoc) -> WarnMsg + mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc dsProgram ghci_mode (TcGblEnv { tcg_exports = exports, @@ -168,7 +167,7 @@ dsProgram ghci_mode (TcGblEnv { tcg_exports = exports, tcg_binds = binds, tcg_fords = fords, tcg_rules = rules }) - = dsMonoBinds auto_scc binds [] `thenDs` \ core_prs -> + = dsHsBinds auto_scc binds [] `thenDs` \ core_prs -> dsForeigns fords `thenDs` \ (ds_fords, foreign_prs) -> let all_prs = foreign_prs ++ core_prs @@ -254,24 +253,25 @@ ppr_ds_rules rules %************************************************************************ \begin{code} -dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule) -dsRule in_scope (HsRule name act vars lhs rhs loc) - = putSrcLocDs loc $ +dsRule :: IdSet -> LRuleDecl Id -> DsM (Id, CoreRule) +dsRule in_scope (L loc (HsRule name act vars lhs rhs)) + = putSrcSpanDs loc $ ds_lhs all_vars lhs `thenDs` \ (fn, args) -> - dsExpr rhs `thenDs` \ core_rhs -> + dsLExpr rhs `thenDs` \ core_rhs -> returnDs (fn, Rule name act tpl_vars args core_rhs) where - tpl_vars = [var | RuleBndr var <- vars] + tpl_vars = [var | RuleBndr (L _ var) <- vars] all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars) ds_lhs all_vars lhs = let - (dict_binds, body) = case lhs of - (HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body) - other -> (EmptyMonoBinds, lhs) + (dict_binds, body) = + case unLoc lhs of + (HsLet [HsBindGroup dict_binds _ _] body) -> (dict_binds, body) + other -> (emptyBag, lhs) in - ds_dict_binds dict_binds `thenDs` \ dict_binds' -> - dsExpr body `thenDs` \ body' -> + mappM ds_dict_bind (bagToList dict_binds) `thenDs` \ dict_binds' -> + dsLExpr body `thenDs` \ body' -> -- Substitute the dict bindings eagerly, -- and take the body apart into a (f args) form @@ -293,10 +293,7 @@ ds_lhs all_vars lhs in returnDs pair -ds_dict_binds EmptyMonoBinds = returnDs [] -ds_dict_binds (AndMonoBinds b1 b2) = ds_dict_binds b1 `thenDs` \ env1 -> - ds_dict_binds b2 `thenDs` \ env2 -> - returnDs (env1 ++ env2) -ds_dict_binds (VarMonoBind id rhs) = dsExpr rhs `thenDs` \ rhs' -> - returnDs [(id,rhs')] +ds_dict_bind (L _ (VarBind id rhs)) = + dsLExpr rhs `thenDs` \ rhs' -> + returnDs (id,rhs') \end{code} diff --git a/ghc/compiler/deSugar/DsArrows.lhs b/ghc/compiler/deSugar/DsArrows.lhs index c04c9ee766..42271beced 100644 --- a/ghc/compiler/deSugar/DsArrows.lhs +++ b/ghc/compiler/deSugar/DsArrows.lhs @@ -10,33 +10,21 @@ module DsArrows ( dsProcExpr ) where import Match ( matchSimply ) import DsUtils ( mkErrorAppDs, - mkCoreTupTy, mkCoreTup, selectMatchVar, + mkCoreTupTy, mkCoreTup, selectMatchVarL, mkTupleCase, mkBigCoreTup, mkTupleType, mkTupleExpr, mkTupleSelector, dsReboundNames, lookupReboundName ) import DsMonad -import HsSyn ( HsExpr(..), - Stmt(..), HsMatchContext(..), HsStmtContext(..), - Match(..), GRHSs(..), GRHS(..), - HsCmdTop(..), HsArrAppType(..), - ReboundNames, - collectHsBinders, - collectStmtBinders, collectStmtsBinders, - matchContextErrString - ) -import TcHsSyn ( TypecheckedHsCmd, TypecheckedHsCmdTop, - TypecheckedHsExpr, TypecheckedPat, - TypecheckedMatch, TypecheckedGRHS, - TypecheckedStmt, hsPatType, - TypecheckedMatchContext ) +import HsSyn +import TcHsSyn ( hsPatType ) -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not -- So WATCH OUT; check each use of split*Ty functions. -- Sigh. This is a pain. -import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet ) import TcType ( Type, tcSplitAppTy ) import Type ( mkTyConApp ) @@ -45,6 +33,7 @@ import CoreFVs ( exprFreeVars ) import CoreUtils ( mkIfThenElse, bindNonRec, exprType ) import Id ( Id, idType ) +import Name ( Name ) import PrelInfo ( pAT_ERROR_ID ) import DataCon ( dataConWrapId ) import TysWiredIn ( tupleCon ) @@ -59,7 +48,7 @@ import HsPat ( collectPatBinders, collectPatsBinders ) import VarSet ( IdSet, mkVarSet, varSetElems, intersectVarSet, minusVarSet, unionVarSet, unionVarSets, elemVarSet ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), unLoc, noLoc, getLoc ) \end{code} \begin{code} @@ -122,7 +111,7 @@ do_map_arrow :: DsCmdEnv -> Type -> Type -> Type -> do_map_arrow ids b_ty c_ty d_ty f c = do_compose ids b_ty c_ty d_ty (do_arr ids b_ty c_ty f) c -mkFailExpr :: TypecheckedMatchContext -> Type -> DsM CoreExpr +mkFailExpr :: HsMatchContext Id -> Type -> DsM CoreExpr mkFailExpr ctxt ty = mkErrorAppDs pAT_ERROR_ID ty (matchContextErrString ctxt) @@ -232,14 +221,14 @@ matchVarStack env_id (stack_id:stack_ids) body \end{code} \begin{code} -mkHsTupleExpr :: [TypecheckedHsExpr] -> TypecheckedHsExpr +mkHsTupleExpr :: [HsExpr Id] -> HsExpr Id mkHsTupleExpr [e] = e -mkHsTupleExpr es = ExplicitTuple es Boxed +mkHsTupleExpr es = ExplicitTuple (map noLoc es) Boxed -mkHsPairExpr :: TypecheckedHsExpr -> TypecheckedHsExpr -> TypecheckedHsExpr +mkHsPairExpr :: HsExpr Id -> HsExpr Id -> HsExpr Id mkHsPairExpr e1 e2 = mkHsTupleExpr [e1, e2] -mkHsEnvStackExpr :: [Id] -> [Id] -> TypecheckedHsExpr +mkHsEnvStackExpr :: [Id] -> [Id] -> HsExpr Id mkHsEnvStackExpr env_ids stack_ids = foldl mkHsPairExpr (mkHsTupleExpr (map HsVar env_ids)) (map HsVar stack_ids) \end{code} @@ -255,13 +244,11 @@ Translation of arrow abstraction -- where (xs) is the tuple of variables bound by p dsProcExpr - :: TypecheckedPat - -> TypecheckedHsCmdTop - -> SrcLoc + :: LPat Id + -> LHsCmdTop Id -> DsM CoreExpr -dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn - = putSrcLocDs locn $ - mkCmdEnv ids `thenDs` \ meth_ids -> +dsProcExpr pat (L _ (HsCmdTop cmd [] cmd_ty ids)) + = mkCmdEnv ids `thenDs` \ meth_ids -> let locals = mkVarSet (collectPatBinders pat) in @@ -271,7 +258,7 @@ dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn env_ty = mkTupleType env_ids in mkFailExpr ProcExpr env_ty `thenDs` \ fail_expr -> - selectMatchVar pat `thenDs` \ var -> + selectMatchVarL pat `thenDs` \ var -> matchSimply (Var var) ProcExpr pat (mkTupleExpr env_ids) fail_expr `thenDs` \ match_code -> let @@ -281,7 +268,6 @@ dsProcExpr pat (HsCmdTop cmd [] cmd_ty ids) locn core_cmd in returnDs (bindCmdEnv meth_ids proc_code) - \end{code} Translation of command judgements of the form @@ -289,15 +275,17 @@ Translation of command judgements of the form A | xs |- c :: [ts] t \begin{code} +dsLCmd ids local_vars env_ids stack res_ty cmd + = dsCmd ids local_vars env_ids stack res_ty (unLoc cmd) -dsCmd :: DsCmdEnv -- arrow combinators +dsCmd :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this command -> [Id] -- list of vars in the input to this command -- This is typically fed back, -- so don't pull on it too early -> [Type] -- type of the stack -> Type -- return type of the command - -> TypecheckedHsCmd -- command to desugar + -> HsCmd Id -- command to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -307,14 +295,14 @@ dsCmd :: DsCmdEnv -- arrow combinators -- A | xs |- f -< arg :: [] t' ---> arr (\ (xs) -> arg) >>> f dsCmd ids local_vars env_ids [] res_ty - (HsArrApp arrow arg arrow_ty HsFirstOrderApp _ _) + (HsArrApp arrow arg arrow_ty HsFirstOrderApp _) = let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty env_ty = mkTupleType env_ids in - dsExpr arrow `thenDs` \ core_arrow -> - dsExpr arg `thenDs` \ core_arg -> + dsLExpr arrow `thenDs` \ core_arrow -> + dsLExpr arg `thenDs` \ core_arg -> matchEnvStack env_ids [] core_arg `thenDs` \ core_make_arg -> returnDs (do_map_arrow ids env_ty arg_ty res_ty core_make_arg @@ -327,14 +315,14 @@ dsCmd ids local_vars env_ids [] res_ty -- A | xs |- f -<< arg :: [] t' ---> arr (\ (xs) -> (f,arg)) >>> app dsCmd ids local_vars env_ids [] res_ty - (HsArrApp arrow arg arrow_ty HsHigherOrderApp _ _) + (HsArrApp arrow arg arrow_ty HsHigherOrderApp _) = let (a_arg_ty, _res_ty') = tcSplitAppTy arrow_ty (_a_ty, arg_ty) = tcSplitAppTy a_arg_ty env_ty = mkTupleType env_ids in - dsExpr arrow `thenDs` \ core_arrow -> - dsExpr arg `thenDs` \ core_arg -> + dsLExpr arrow `thenDs` \ core_arrow -> + dsLExpr arg `thenDs` \ core_arg -> matchEnvStack env_ids [] (mkCorePairExpr core_arrow core_arg) `thenDs` \ core_make_pair -> returnDs (do_map_arrow ids env_ty (mkCorePairTy arrow_ty arg_ty) res_ty @@ -351,7 +339,7 @@ dsCmd ids local_vars env_ids [] res_ty -- ---> arr (\ ((xs)*ts) -> let z = e in (((ys),z)*ts)) >>> c dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) - = dsExpr arg `thenDs` \ core_arg -> + = dsLExpr arg `thenDs` \ core_arg -> let arg_ty = exprType core_arg stack' = arg_ty:stack @@ -384,7 +372,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsApp cmd arg) -- ---> arr (\ ((((xs), p1), ... pk)*ts) -> ((ys)*ts)) >>> c dsCmd ids local_vars env_ids stack res_ty - (HsLam (Match pats _ (GRHSs [GRHS [ResultStmt body _] _loc] _ _cmd_ty))) + (HsLam (L _ (Match pats _ (GRHSs [L _ (GRHS [L _ (ResultStmt body)])] _ _cmd_ty)))) = let pat_vars = mkVarSet (collectPatsBinders pats) local_vars' = local_vars `unionVarSet` pat_vars @@ -415,7 +403,7 @@ dsCmd ids local_vars env_ids stack res_ty free_vars `minusVarSet` pat_vars) dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) - = dsCmd ids local_vars env_ids stack res_ty cmd + = dsLCmd ids local_vars env_ids stack res_ty cmd -- A, xs |- e :: Bool -- A | xs1 |- c1 :: [ts] t @@ -427,8 +415,8 @@ dsCmd ids local_vars env_ids stack res_ty (HsPar cmd) -- if e then Left ((xs1)*ts) else Right ((xs2)*ts)) >>> -- c1 ||| c2 -dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd _loc) - = dsExpr cond `thenDs` \ core_cond -> +dsCmd ids local_vars env_ids stack res_ty (HsIf cond then_cmd else_cmd) + = dsLExpr cond `thenDs` \ core_cond -> dsfixCmd ids local_vars stack res_ty then_cmd `thenDs` \ (core_then, fvs_then, then_ids) -> dsfixCmd ids local_vars stack res_ty else_cmd @@ -485,8 +473,8 @@ case bodies, containing the following fields: bodies with |||. \begin{code} -dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) - = dsExpr exp `thenDs` \ core_exp -> +dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches) + = dsLExpr exp `thenDs` \ core_exp -> mappM newSysLocalDs stack `thenDs` \ stack_ids -> -- Extract and desugar the leaf commands in the case, building tuple @@ -496,9 +484,9 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) leaves = concatMap leavesMatch matches make_branch (leaf, bound_vars) = dsfixCmd ids (local_vars `unionVarSet` bound_vars) stack res_ty leaf - `thenDs` \ (core_leaf, fvs, leaf_ids) -> + `thenDs` \ (core_leaf, fvs, leaf_ids) -> returnDs (fvs `minusVarSet` bound_vars, - [mkHsEnvStackExpr leaf_ids stack_ids], + [noLoc $ mkHsEnvStackExpr leaf_ids stack_ids], envStackType leaf_ids stack, core_leaf) in @@ -507,10 +495,10 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) dsLookupDataCon leftDataConName `thenDs` \ left_con -> dsLookupDataCon rightDataConName `thenDs` \ right_con -> let - left_id = HsVar (dataConWrapId left_con) - right_id = HsVar (dataConWrapId right_con) - left_expr ty1 ty2 e = HsApp (TyApp left_id [ty1, ty2]) e - right_expr ty1 ty2 e = HsApp (TyApp right_id [ty1, ty2]) e + left_id = nlHsVar (dataConWrapId left_con) + right_id = nlHsVar (dataConWrapId right_con) + left_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp left_id [ty1, ty2]) e + right_expr ty1 ty2 e = noLoc $ HsApp (noLoc $ TyApp right_id [ty1, ty2]) e -- Prefix each tuple with a distinct series of Left's and Right's, -- in a balanced way, keeping track of the types. @@ -526,13 +514,13 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) = foldb merge_branches branches -- Replace the commands in the case with these tagged tuples, - -- yielding a TypecheckedHsExpr we can feed to dsExpr. + -- yielding a HsExpr Id we can feed to dsExpr. (_, matches') = mapAccumL (replaceLeavesMatch res_ty) leaves' matches in_ty = envStackType env_ids stack fvs_exp = exprFreeVars core_exp `intersectVarSet` local_vars in - dsExpr (HsCase exp matches' src_loc) `thenDs` \ core_body -> + dsExpr (HsCase exp matches') `thenDs` \ core_body -> matchEnvStack env_ids stack_ids core_body `thenDs` \ core_matches -> returnDs(do_map_arrow ids in_ty sum_ty res_ty core_matches core_choices, @@ -546,7 +534,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsCase exp matches src_loc) dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) = let - defined_vars = mkVarSet (collectHsBinders binds) + defined_vars = mkVarSet (map unLoc (collectGroupBinders binds)) local_vars' = local_vars `unionVarSet` defined_vars in dsfixCmd ids local_vars' stack res_ty body @@ -566,7 +554,7 @@ dsCmd ids local_vars env_ids stack res_ty (HsLet binds body) core_body, exprFreeVars core_binds `intersectVarSet` local_vars) -dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _ _loc) +dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _) = dsCmdDo ids local_vars env_ids res_ty stmts -- A |- e :: forall e. a1 (e*ts1) t1 -> ... an (e*tsn) tn -> a (e*ts) t @@ -574,11 +562,11 @@ dsCmd ids local_vars env_ids [] res_ty (HsDo _ctxt stmts _ _ _loc) -- ----------------------------------- -- A | xs |- (|e c1 ... cn|) :: [ts] t ---> e [t_xs] c1 ... cn -dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _) +dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args) = let env_ty = mkTupleType env_ids in - dsExpr op `thenDs` \ core_op -> + dsLExpr op `thenDs` \ core_op -> mapAndUnzipDs (dsTrimCmdArg local_vars env_ids) args `thenDs` \ (core_args, fv_sets) -> returnDs (mkApps (App core_op (Type env_ty)) core_args, @@ -591,10 +579,10 @@ dsCmd _ids local_vars env_ids _stack _res_ty (HsArrForm op _ args _) dsTrimCmdArg :: IdSet -- set of local vars available to this command -> [Id] -- list of vars in the input to this command - -> TypecheckedHsCmdTop -- command argument to desugar + -> LHsCmdTop Id -- command argument to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free -dsTrimCmdArg local_vars env_ids (HsCmdTop cmd stack cmd_ty ids) +dsTrimCmdArg local_vars env_ids (L _ (HsCmdTop cmd stack cmd_ty ids)) = mkCmdEnv ids `thenDs` \ meth_ids -> dsfixCmd meth_ids local_vars stack cmd_ty cmd `thenDs` \ (core_cmd, free_vars, env_ids') -> @@ -617,13 +605,13 @@ dsfixCmd -> IdSet -- set of local vars available to this command -> [Type] -- type of the stack -> Type -- return type of the command - -> TypecheckedHsCmd -- command to desugar + -> LHsCmd Id -- command to desugar -> DsM (CoreExpr, -- desugared expression IdSet, -- set of local vars that occur free [Id]) -- set as a list, fed back dsfixCmd ids local_vars stack cmd_ty cmd = fixDs (\ ~(_,_,env_ids') -> - dsCmd ids local_vars env_ids' stack cmd_ty cmd + dsLCmd ids local_vars env_ids' stack cmd_ty cmd `thenDs` \ (core_cmd, free_vars) -> returnDs (core_cmd, free_vars, varSetElems free_vars)) @@ -641,7 +629,7 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- This is typically fed back, -- so don't pull on it too early -> Type -- return type of the statement - -> [TypecheckedStmt] -- statements to desugar + -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -649,12 +637,12 @@ dsCmdDo :: DsCmdEnv -- arrow combinators -- -------------------------- -- A | xs |- do { c } :: [] t -dsCmdDo ids local_vars env_ids res_ty [ResultStmt cmd _locn] - = dsCmd ids local_vars env_ids [] res_ty cmd +dsCmdDo ids local_vars env_ids res_ty [L _ (ResultStmt cmd)] + = dsLCmd ids local_vars env_ids [] res_ty cmd dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) = let - bound_vars = mkVarSet (collectStmtBinders stmt) + bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt)) local_vars' = local_vars `unionVarSet` bound_vars in fixDs (\ ~(_,_,env_ids') -> @@ -662,7 +650,7 @@ dsCmdDo ids local_vars env_ids res_ty (stmt:stmts) `thenDs` \ (core_stmts, fv_stmts) -> returnDs (core_stmts, fv_stmts, varSetElems fv_stmts)) `thenDs` \ (core_stmts, fv_stmts, env_ids') -> - dsCmdStmt ids local_vars env_ids env_ids' stmt + dsCmdLStmt ids local_vars env_ids env_ids' stmt `thenDs` \ (core_stmt, fv_stmt) -> returnDs (do_compose ids (mkTupleType env_ids) @@ -677,6 +665,8 @@ A statement maps one local environment to another, and is represented as an arrow from one tuple type to another. A statement sequence is translated to a composition of such arrows. \begin{code} +dsCmdLStmt ids local_vars env_ids out_ids cmd + = dsCmdStmt ids local_vars env_ids out_ids (unLoc cmd) dsCmdStmt :: DsCmdEnv -- arrow combinators @@ -685,7 +675,7 @@ dsCmdStmt -- This is typically fed back, -- so don't pull on it too early -> [Id] -- list of vars in the output of this statement - -> TypecheckedStmt -- statement to desugar + -> Stmt Id -- statement to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free @@ -697,7 +687,7 @@ dsCmdStmt -- ---> arr (\ (xs) -> ((xs1),(xs'))) >>> first c >>> -- arr snd >>> ss -dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc) +dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty) = dsfixCmd ids local_vars [] c_ty cmd `thenDs` \ (core_cmd, fv_cmd, env_ids1) -> matchEnvStack env_ids [] @@ -729,7 +719,7 @@ dsCmdStmt ids local_vars env_ids out_ids (ExprStmt cmd c_ty _loc) -- It would be simpler and more consistent to do this using second, -- but that's likely to be defined in terms of first. -dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) +dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd) = dsfixCmd ids local_vars [] (hsPatType pat) cmd `thenDs` \ (core_cmd, fv_cmd, env_ids1) -> let @@ -749,7 +739,7 @@ dsCmdStmt ids local_vars env_ids out_ids (BindStmt pat cmd _loc) -- projection function -- \ (p, (xs2)) -> (zs) - selectMatchVar pat `thenDs` \ pat_id -> + selectMatchVarL pat `thenDs` \ pat_id -> newSysLocalDs env_ty2 `thenDs` \ env_id -> newUniqueSupply `thenDs` \ uniqs -> let @@ -874,7 +864,7 @@ dsRecCmd ids local_vars stmts later_ids rec_ids rhss -- mk_pair_fn = \ (out_ids) -> ((later_ids),(rhss)) - mappM dsExpr rhss `thenDs` \ core_rhss -> + mappM dsLExpr rhss `thenDs` \ core_rhss -> let later_tuple = mkTupleExpr later_ids later_ty = mkTupleType later_ids @@ -931,7 +921,7 @@ dsfixCmdStmts :: DsCmdEnv -- arrow combinators -> IdSet -- set of local vars available to this statement -> [Id] -- output vars of these statements - -> [TypecheckedStmt] -- statements to desugar + -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression IdSet, -- set of local vars that occur free [Id]) -- input vars @@ -947,21 +937,21 @@ dsCmdStmts -> IdSet -- set of local vars available to this statement -> [Id] -- list of vars in the input to these statements -> [Id] -- output vars of these statements - -> [TypecheckedStmt] -- statements to desugar + -> [LStmt Id] -- statements to desugar -> DsM (CoreExpr, -- desugared expression IdSet) -- set of local vars that occur free dsCmdStmts ids local_vars env_ids out_ids [stmt] - = dsCmdStmt ids local_vars env_ids out_ids stmt + = dsCmdLStmt ids local_vars env_ids out_ids stmt dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) = let - bound_vars = mkVarSet (collectStmtBinders stmt) + bound_vars = mkVarSet (map unLoc (collectLStmtBinders stmt)) local_vars' = local_vars `unionVarSet` bound_vars in dsfixCmdStmts ids local_vars' out_ids stmts `thenDs` \ (core_stmts, fv_stmts, env_ids') -> - dsCmdStmt ids local_vars env_ids env_ids' stmt + dsCmdLStmt ids local_vars env_ids env_ids' stmt `thenDs` \ (core_stmt, fv_stmt) -> returnDs (do_compose ids (mkTupleType env_ids) @@ -976,11 +966,11 @@ dsCmdStmts ids local_vars env_ids out_ids (stmt:stmts) Match a list of expressions against a list of patterns, left-to-right. \begin{code} -matchSimplys :: [CoreExpr] -- Scrutinees - -> TypecheckedMatchContext -- Match kind - -> [TypecheckedPat] -- Patterns they should match - -> CoreExpr -- Return this if they all match - -> CoreExpr -- Return this if they don't +matchSimplys :: [CoreExpr] -- Scrutinees + -> HsMatchContext Name -- Match kind + -> [LPat Id] -- Patterns they should match + -> CoreExpr -- Return this if they all match + -> CoreExpr -- Return this if they don't -> DsM CoreExpr matchSimplys [] _ctxt [] result_expr _fail_expr = returnDs result_expr matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr @@ -992,15 +982,18 @@ matchSimplys (exp:exps) ctxt (pat:pats) result_expr fail_expr List of leaf expressions, with set of variables bound in each \begin{code} -leavesMatch :: TypecheckedMatch -> [(TypecheckedHsExpr, IdSet)] -leavesMatch (Match pats _ (GRHSs grhss binds _ty)) +leavesMatch :: LMatch Id -> [(LHsExpr Id, IdSet)] +leavesMatch (L _ (Match pats _ (GRHSs grhss binds _ty))) = let - defined_vars = mkVarSet (collectPatsBinders pats) `unionVarSet` - mkVarSet (collectHsBinders binds) + defined_vars = mkVarSet (collectPatsBinders pats) + `unionVarSet` + mkVarSet (map unLoc (collectGroupBinders binds)) in - [(expr, mkVarSet (collectStmtsBinders stmts) `unionVarSet` defined_vars) | - GRHS stmts _locn <- grhss, - let ResultStmt expr _ = last stmts] + [(expr, + mkVarSet (map unLoc (collectStmtsBinders stmts)) + `unionVarSet` defined_vars) + | L _ (GRHS stmts) <- grhss, + let L _ (ResultStmt expr) = last stmts] \end{code} Replace the leaf commands in a match @@ -1008,23 +1001,23 @@ Replace the leaf commands in a match \begin{code} replaceLeavesMatch :: Type -- new result type - -> [TypecheckedHsExpr] -- replacement leaf expressions of that type - -> TypecheckedMatch -- the matches of a case command - -> ([TypecheckedHsExpr],-- remaining leaf expressions - TypecheckedMatch) -- updated match -replaceLeavesMatch res_ty leaves (Match pat mt (GRHSs grhss binds _ty)) + -> [LHsExpr Id] -- replacement leaf expressions of that type + -> LMatch Id -- the matches of a case command + -> ([LHsExpr Id],-- remaining leaf expressions + LMatch Id) -- updated match +replaceLeavesMatch res_ty leaves (L loc (Match pat mt (GRHSs grhss binds _ty))) = let (leaves', grhss') = mapAccumL replaceLeavesGRHS leaves grhss in - (leaves', Match pat mt (GRHSs grhss' binds res_ty)) + (leaves', L loc (Match pat mt (GRHSs grhss' binds res_ty))) replaceLeavesGRHS - :: [TypecheckedHsExpr] -- replacement leaf expressions of that type - -> TypecheckedGRHS -- rhss of a case command - -> ([TypecheckedHsExpr],-- remaining leaf expressions - TypecheckedGRHS) -- updated GRHS -replaceLeavesGRHS (leaf:leaves) (GRHS stmts srcloc) - = (leaves, GRHS (init stmts ++ [ResultStmt leaf srcloc]) srcloc) + :: [LHsExpr Id] -- replacement leaf expressions of that type + -> LGRHS Id -- rhss of a case command + -> ([LHsExpr Id],-- remaining leaf expressions + LGRHS Id) -- updated GRHS +replaceLeavesGRHS (leaf:leaves) (L loc (GRHS stmts)) + = (leaves, L loc (GRHS (init stmts ++ [L (getLoc leaf) (ResultStmt leaf)]))) \end{code} Balanced fold of a non-empty list. diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index ff2403e6f4..0d5cb7ec46 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -8,12 +8,12 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at lower levels it is preserved with @let@/@letrec@s). \begin{code} -module DsBinds ( dsMonoBinds, AutoScc(..) ) where +module DsBinds ( dsHsBinds, AutoScc(..) ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr( dsExpr ) +import {-# SOURCE #-} DsExpr( dsLExpr ) import DsMonad import DsGRHSs ( dsGuarded ) import DsUtils @@ -21,7 +21,6 @@ import DsUtils import HsSyn -- lots of things import CoreSyn -- lots of things import CoreUtils ( exprType, mkInlineMe, mkSCC ) -import TcHsSyn ( TypecheckedMonoBinds ) import Match ( matchWrapper ) import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs ) @@ -33,7 +32,11 @@ import TcType ( mkTyVarTy ) import Subst ( substTyWith ) import TysWiredIn ( voidTy ) import Outputable +import SrcLoc ( Located(..) ) import Maybe ( isJust ) +import Bag ( Bag, bagToList ) + +import Monad ( foldM ) \end{code} %************************************************************************ @@ -43,19 +46,28 @@ import Maybe ( isJust ) %************************************************************************ \begin{code} -dsMonoBinds :: AutoScc -- scc annotation policy (see below) - -> TypecheckedMonoBinds - -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) - -> DsM [(Id,CoreExpr)] -- Result +dsHsBinds :: AutoScc -- scc annotation policy (see below) + -> Bag (LHsBind Id) + -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) + -> DsM [(Id,CoreExpr)] -- Result + +dsHsBinds auto_scc binds rest = + foldM (dsLHsBind auto_scc) rest (bagToList binds) -dsMonoBinds _ EmptyMonoBinds rest = returnDs rest +dsLHsBind :: AutoScc + -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) + -> LHsBind Id + -> DsM [(Id,CoreExpr)] -- Result +dsLHsBind auto_scc rest (L loc bind) + = putSrcSpanDs loc $ dsHsBind auto_scc rest bind -dsMonoBinds auto_scc (AndMonoBinds binds_1 binds_2) rest - = dsMonoBinds auto_scc binds_2 rest `thenDs` \ rest' -> - dsMonoBinds auto_scc binds_1 rest' +dsHsBind :: AutoScc + -> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append) + -> HsBind Id + -> DsM [(Id,CoreExpr)] -- Result -dsMonoBinds _ (VarMonoBind var expr) rest - = dsExpr expr `thenDs` \ core_expr -> +dsHsBind auto_scc rest (VarBind var expr) + = dsLExpr expr `thenDs` \ core_expr -> -- Dictionary bindings are always VarMonoBinds, so -- we only need do this here @@ -73,15 +85,13 @@ dsMonoBinds _ (VarMonoBind var expr) rest returnDs ((var, core_expr'') : rest) -dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest - = putSrcLocDs locn $ - matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> - addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> +dsHsBind auto_scc rest (FunBind (L _ fun) _ matches) + = matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) -> + addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair -> returnDs (pair : rest) -dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest - = putSrcLocDs locn $ - dsGuarded grhss `thenDs` \ body_expr -> +dsHsBind auto_scc rest (PatBind pat grhss) + = dsGuarded grhss `thenDs` \ body_expr -> mkSelectorBinds pat body_expr `thenDs` \ sel_binds -> mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds -> returnDs (sel_binds ++ rest) @@ -90,9 +100,9 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest -- For the (rare) case when there are some mixed-up -- dictionary bindings (for which a Rec is convenient) -- we reply on the enclosing dsBind to wrap a Rec around. -dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest - = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> - let +dsHsBind auto_scc rest (AbsBinds [] [] exports inlines binds) + = dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> + let core_prs' = addLocalInlines exports inlines core_prs exports' = [(global, Var local) | (_, global, local) <- exports] in @@ -100,10 +110,10 @@ dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest -- Another common case: one exported variable -- Non-recursive bindings come through this way -dsMonoBinds auto_scc - (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest +dsHsBind auto_scc rest + (AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) = ASSERT( all (`elem` tyvars) all_tyvars ) - dsMonoBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs -> + dsHsBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs -> let -- Always treat the binds as recursive, because the typechecker -- makes rather mixed-up dictionary bindings @@ -117,8 +127,8 @@ dsMonoBinds auto_scc in returnDs (export' : rest) -dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest - = dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> +dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports inlines binds) + = dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs -> let -- Rec because of mixed-up dictionary bindings core_bind = Rec (addLocalInlines exports inlines core_prs) diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index 4ae835f2c9..f30993cadc 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -238,7 +238,7 @@ unboxArg arg ]) | otherwise - = getSrcLocDs `thenDs` \ l -> + = getSrcSpanDs `thenDs` \ l -> pprPanic "unboxArg: " (ppr l <+> ppr arg_ty) where arg_ty = exprType arg diff --git a/ghc/compiler/deSugar/DsExpr.hi-boot-5 b/ghc/compiler/deSugar/DsExpr.hi-boot-5 index 11c0fa08fc..7e5bbaab7f 100644 --- a/ghc/compiler/deSugar/DsExpr.hi-boot-5 +++ b/ghc/compiler/deSugar/DsExpr.hi-boot-5 @@ -1,4 +1,5 @@ __interface DsExpr 1 0 where __export DsExpr dsExpr dsLet; -1 dsExpr :: TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr ; -1 dsLet :: TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; +1 dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr ; +1 dsLExpr :: HsExpr.HsLExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr ; +1 dsLet :: [HsBinds.HsBindGroup Var.Id] -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; diff --git a/ghc/compiler/deSugar/DsExpr.hi-boot-6 b/ghc/compiler/deSugar/DsExpr.hi-boot-6 index 5fffa1c510..9a9a2d20f8 100644 --- a/ghc/compiler/deSugar/DsExpr.hi-boot-6 +++ b/ghc/compiler/deSugar/DsExpr.hi-boot-6 @@ -1,4 +1,5 @@ module DsExpr where -dsExpr :: TcHsSyn.TypecheckedHsExpr -> DsMonad.DsM CoreSyn.CoreExpr -dsLet :: TcHsSyn.TypecheckedHsBinds -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr +dsExpr :: HsExpr.HsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr +dsLExpr :: HsExpr.LHsExpr Var.Id -> DsMonad.DsM CoreSyn.CoreExpr +dsLet :: [HsBinds.HsBindGroup Var.Id] -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index f447d9d52e..4bcc2c9802 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -4,18 +4,18 @@ \section[DsExpr]{Matching expressions (Exprs)} \begin{code} -module DsExpr ( dsExpr, dsLet, dsLit ) where +module DsExpr ( dsExpr, dsLExpr, dsLet, dsLit ) where #include "HsVersions.h" import Match ( matchWrapper, matchSimply ) import MatchLit ( dsLit ) -import DsBinds ( dsMonoBinds, AutoScc(..) ) +import DsBinds ( dsHsBinds, AutoScc(..) ) import DsGRHSs ( dsGuarded ) import DsListComp ( dsListComp, dsPArrComp ) import DsUtils ( mkErrorAppDs, mkStringLit, mkConsExpr, mkNilExpr, - mkCoreTupTy, selectMatchVar, + mkCoreTupTy, selectMatchVarL, dsReboundNames, lookupReboundName ) import DsArrows ( dsProcExpr ) import DsMonad @@ -25,13 +25,8 @@ import DsMonad import DsMeta ( dsBracket ) #endif -import HsSyn ( HsExpr(..), Pat(..), ArithSeqInfo(..), - Stmt(..), HsMatchContext(..), HsStmtContext(..), - Match(..), HsBinds(..), MonoBinds(..), HsConDetails(..), - ReboundNames, - mkSimpleMatch, isDoExpr - ) -import TcHsSyn ( TypecheckedHsExpr, TypecheckedHsBinds, TypecheckedStmt, hsPatType ) +import HsSyn +import TcHsSyn ( hsPatType ) -- NB: The desugarer, which straddles the source and Core worlds, sometimes -- needs to see source types (newtypes etc), and sometimes not @@ -58,8 +53,9 @@ import BasicTypes ( RecFlag(..), Boxity(..), ipNameName ) import PrelNames ( toPName, returnMName, bindMName, thenMName, failMName, mfixName ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( Located(..), unLoc, getLoc, noLoc ) import Util ( zipEqual, zipWithEqual ) +import Bag ( bagToList ) import Outputable import FastString \end{code} @@ -83,28 +79,24 @@ This must be transformed to a case expression and, if the type has more than one constructor, may fail. \begin{code} -dsLet :: TypecheckedHsBinds -> CoreExpr -> DsM CoreExpr +dsLet :: [HsBindGroup Id] -> CoreExpr -> DsM CoreExpr +dsLet groups body = foldlDs dsBindGroup body (reverse groups) -dsLet EmptyBinds body - = returnDs body - -dsLet (ThenBinds b1 b2) body - = dsLet b2 body `thenDs` \ body' -> - dsLet b1 body' - -dsLet (IPBinds binds) body +dsBindGroup :: CoreExpr -> HsBindGroup Id -> DsM CoreExpr +dsBindGroup body (HsIPBinds binds) = foldlDs dsIPBind body binds where - dsIPBind body (n, e) - = dsExpr e `thenDs` \ e' -> + dsIPBind body (L _ (IPBind n e)) + = dsLExpr e `thenDs` \ e' -> returnDs (Let (NonRec (ipNameName n) e') body) -- Special case for bindings which bind unlifted variables -- We need to do a case right away, rather than building -- a tuple and doing selections. -- Silently ignore INLINE pragmas... -dsLet bind@(MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body - | or [isUnLiftedType (idType g) | (_, g, l) <- exports] +dsBindGroup body bind@(HsBindGroup hsbinds sigs is_rec) + | [L _ (AbsBinds [] [] exports inlines binds)] <- bagToList hsbinds, + or [isUnLiftedType (idType g) | (_, g, l) <- exports] = ASSERT (case is_rec of {NonRecursive -> True; other -> False}) -- Unlifted bindings are always non-recursive -- and are always a Fun or Pat monobind @@ -112,35 +104,36 @@ dsLet bind@(MonoBind (AbsBinds [] [] exports inlines binds) sigs is_rec) body -- ToDo: in some bizarre case it's conceivable that there -- could be dict binds in the 'binds'. (See the notes -- below. Then pattern-match would fail. Urk.) - case binds of - FunMonoBind fun _ matches loc - -> putSrcLocDs loc $ + let + body_w_exports = foldr bind_export body exports + bind_export (tvs, g, l) body = ASSERT( null tvs ) + bindNonRec g (Var l) body + + mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID + (exprType body) + (showSDoc (ppr pat)) + in + case bagToList binds of + [L loc (FunBind (L _ fun) _ matches)] + -> putSrcSpanDs loc $ matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, rhs) -> ASSERT( null args ) -- Functions aren't lifted returnDs (bindNonRec fun rhs body_w_exports) - PatMonoBind pat grhss loc - -> putSrcLocDs loc $ + [L loc (PatBind pat grhss)] + -> putSrcSpanDs loc $ dsGuarded grhss `thenDs` \ rhs -> mk_error_app pat `thenDs` \ error_expr -> matchSimply rhs PatBindRhs pat body_w_exports error_expr other -> pprPanic "dsLet: unlifted" (ppr bind $$ ppr body) - where - body_w_exports = foldr bind_export body exports - bind_export (tvs, g, l) body = ASSERT( null tvs ) - bindNonRec g (Var l) body - - mk_error_app pat = mkErrorAppDs iRREFUT_PAT_ERROR_ID - (exprType body) - (showSDoc (ppr pat)) -- Ordinary case for bindings -dsLet (MonoBind binds sigs is_rec) body - = dsMonoBinds NoSccs binds [] `thenDs` \ prs -> +dsBindGroup body (HsBindGroup binds sigs is_rec) + = dsHsBinds NoSccs binds [] `thenDs` \ prs -> returnDs (Let (Rec prs) body) -- Use a Rec regardless of is_rec. - -- Why? Because it allows the MonoBinds to be all + -- Why? Because it allows the binds to be all -- mixed up, which is what happens in one rare case -- Namely, for an AbsBind with no tyvars and no dicts, -- but which does have dictionary bindings. @@ -158,9 +151,12 @@ dsLet (MonoBind binds sigs is_rec) body %************************************************************************ \begin{code} -dsExpr :: TypecheckedHsExpr -> DsM CoreExpr +dsLExpr :: LHsExpr Id -> DsM CoreExpr +dsLExpr (L loc e) = putSrcSpanDs loc $ dsExpr e + +dsExpr :: HsExpr Id -> DsM CoreExpr -dsExpr (HsPar x) = dsExpr x +dsExpr (HsPar x) = dsLExpr x dsExpr (HsVar var) = returnDs (Var var) dsExpr (HsIPVar ip) = returnDs (Var (ipNameName ip)) dsExpr (HsLit lit) = dsLit lit @@ -171,8 +167,8 @@ dsExpr expr@(HsLam a_Match) returnDs (mkLams binders matching_code) dsExpr expr@(HsApp fun arg) - = dsExpr fun `thenDs` \ core_fun -> - dsExpr arg `thenDs` \ core_arg -> + = dsLExpr fun `thenDs` \ core_fun -> + dsLExpr arg `thenDs` \ core_arg -> returnDs (core_fun `App` core_arg) \end{code} @@ -199,36 +195,36 @@ will sort it out. \begin{code} dsExpr (OpApp e1 op _ e2) - = dsExpr op `thenDs` \ core_op -> + = dsLExpr op `thenDs` \ core_op -> -- for the type of y, we need the type of op's 2nd argument - dsExpr e1 `thenDs` \ x_core -> - dsExpr e2 `thenDs` \ y_core -> + dsLExpr e1 `thenDs` \ x_core -> + dsLExpr e2 `thenDs` \ y_core -> returnDs (mkApps core_op [x_core, y_core]) dsExpr (SectionL expr op) - = dsExpr op `thenDs` \ core_op -> + = dsLExpr op `thenDs` \ core_op -> -- for the type of y, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) -- Must look through an implicit-parameter type; -- newtype impossible; hence Type.splitFunTys in - dsExpr expr `thenDs` \ x_core -> + dsLExpr expr `thenDs` \ x_core -> newSysLocalDs x_ty `thenDs` \ x_id -> newSysLocalDs y_ty `thenDs` \ y_id -> returnDs (bindNonRec x_id x_core $ Lam y_id (mkApps core_op [Var x_id, Var y_id])) --- dsExpr (SectionR op expr) -- \ x -> op x expr +-- dsLExpr (SectionR op expr) -- \ x -> op x expr dsExpr (SectionR op expr) - = dsExpr op `thenDs` \ core_op -> + = dsLExpr op `thenDs` \ core_op -> -- for the type of x, we need the type of op's 2nd argument let (x_ty:y_ty:_, _) = splitFunTys (exprType core_op) -- See comment with SectionL in - dsExpr expr `thenDs` \ y_core -> + dsLExpr expr `thenDs` \ y_core -> newSysLocalDs x_ty `thenDs` \ x_id -> newSysLocalDs y_ty `thenDs` \ y_id -> @@ -236,7 +232,7 @@ dsExpr (SectionR op expr) Lam x_id (mkApps core_op [Var x_id, Var y_id])) dsExpr (HsSCC cc expr) - = dsExpr expr `thenDs` \ core_expr -> + = dsLExpr expr `thenDs` \ core_expr -> getModuleDs `thenDs` \ mod_name -> returnDs (Note (SCC (mkUserCC cc mod_name)) core_expr) @@ -244,61 +240,55 @@ dsExpr (HsSCC cc expr) -- hdaume: core annotation dsExpr (HsCoreAnn fs expr) - = dsExpr expr `thenDs` \ core_expr -> + = dsLExpr expr `thenDs` \ core_expr -> returnDs (Note (CoreNote $ unpackFS fs) core_expr) -- special case to handle unboxed tuple patterns. -dsExpr (HsCase discrim matches src_loc) +dsExpr (HsCase discrim matches) | all ubx_tuple_match matches - = putSrcLocDs src_loc $ - dsExpr discrim `thenDs` \ core_discrim -> + = dsLExpr discrim `thenDs` \ core_discrim -> matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) -> case matching_code of Case (Var x) bndr alts | x == discrim_var -> returnDs (Case core_discrim bndr alts) - _ -> panic ("dsExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code)) + _ -> panic ("dsLExpr: tuple pattern:\n" ++ showSDoc (ppr matching_code)) where - ubx_tuple_match (Match [TuplePat ps Unboxed] _ _) = True + ubx_tuple_match (L _ (Match [L _ (TuplePat _ Unboxed)] _ _)) = True ubx_tuple_match _ = False -dsExpr (HsCase discrim matches src_loc) - = putSrcLocDs src_loc $ - dsExpr discrim `thenDs` \ core_discrim -> +dsExpr (HsCase discrim matches) + = dsLExpr discrim `thenDs` \ core_discrim -> matchWrapper CaseAlt matches `thenDs` \ ([discrim_var], matching_code) -> returnDs (bindNonRec discrim_var core_discrim matching_code) dsExpr (HsLet binds body) - = dsExpr body `thenDs` \ body' -> + = dsLExpr body `thenDs` \ body' -> dsLet binds body' -- We need the `ListComp' form to use `deListComp' (rather than the "do" form) -- because the interpretation of `stmts' depends on what sort of thing it is. -- -dsExpr (HsDo ListComp stmts _ result_ty src_loc) +dsExpr (HsDo ListComp stmts _ result_ty) = -- Special case for list comprehensions - putSrcLocDs src_loc $ dsListComp stmts elt_ty where (_, [elt_ty]) = tcSplitTyConApp result_ty -dsExpr (HsDo do_or_lc stmts ids result_ty src_loc) +dsExpr (HsDo do_or_lc stmts ids result_ty) | isDoExpr do_or_lc - = putSrcLocDs src_loc $ - dsDo do_or_lc stmts ids result_ty + = dsDo do_or_lc stmts ids result_ty -dsExpr (HsDo PArrComp stmts _ result_ty src_loc) +dsExpr (HsDo PArrComp stmts _ result_ty) = -- Special case for array comprehensions - putSrcLocDs src_loc $ - dsPArrComp stmts elt_ty + dsPArrComp (map unLoc stmts) elt_ty where (_, [elt_ty]) = tcSplitTyConApp result_ty -dsExpr (HsIf guard_expr then_expr else_expr src_loc) - = putSrcLocDs src_loc $ - dsExpr guard_expr `thenDs` \ core_guard -> - dsExpr then_expr `thenDs` \ core_then -> - dsExpr else_expr `thenDs` \ core_else -> +dsExpr (HsIf guard_expr then_expr else_expr) + = dsLExpr guard_expr `thenDs` \ core_guard -> + dsLExpr then_expr `thenDs` \ core_then -> + dsLExpr else_expr `thenDs` \ core_else -> returnDs (mkIfThenElse core_guard core_then core_else) \end{code} @@ -308,11 +298,11 @@ dsExpr (HsIf guard_expr then_expr else_expr src_loc) % ~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} dsExpr (TyLam tyvars expr) - = dsExpr expr `thenDs` \ core_expr -> + = dsLExpr expr `thenDs` \ core_expr -> returnDs (mkLams tyvars core_expr) dsExpr (TyApp expr tys) - = dsExpr expr `thenDs` \ core_expr -> + = dsLExpr expr `thenDs` \ core_expr -> returnDs (mkTyApps core_expr tys) \end{code} @@ -325,7 +315,7 @@ dsExpr (ExplicitList ty xs) = go xs where go [] = returnDs (mkNilExpr ty) - go (x:xs) = dsExpr x `thenDs` \ core_x -> + go (x:xs) = dsLExpr x `thenDs` \ core_x -> go xs `thenDs` \ core_xs -> returnDs (mkConsExpr ty core_x core_xs) @@ -345,45 +335,45 @@ dsExpr (ExplicitPArr ty xs) returnDs (mkApps (Var toP) [Type ty, coreList]) dsExpr (ExplicitTuple expr_list boxity) - = mappM dsExpr expr_list `thenDs` \ core_exprs -> + = mappM dsLExpr expr_list `thenDs` \ core_exprs -> returnDs (mkConApp (tupleCon boxity (length expr_list)) (map (Type . exprType) core_exprs ++ core_exprs)) dsExpr (ArithSeqOut expr (From from)) - = dsExpr expr `thenDs` \ expr2 -> - dsExpr from `thenDs` \ from2 -> + = dsLExpr expr `thenDs` \ expr2 -> + dsLExpr from `thenDs` \ from2 -> returnDs (App expr2 from2) dsExpr (ArithSeqOut expr (FromTo from two)) - = dsExpr expr `thenDs` \ expr2 -> - dsExpr from `thenDs` \ from2 -> - dsExpr two `thenDs` \ two2 -> + = dsLExpr expr `thenDs` \ expr2 -> + dsLExpr from `thenDs` \ from2 -> + dsLExpr two `thenDs` \ two2 -> returnDs (mkApps expr2 [from2, two2]) dsExpr (ArithSeqOut expr (FromThen from thn)) - = dsExpr expr `thenDs` \ expr2 -> - dsExpr from `thenDs` \ from2 -> - dsExpr thn `thenDs` \ thn2 -> + = dsLExpr expr `thenDs` \ expr2 -> + dsLExpr from `thenDs` \ from2 -> + dsLExpr thn `thenDs` \ thn2 -> returnDs (mkApps expr2 [from2, thn2]) dsExpr (ArithSeqOut expr (FromThenTo from thn two)) - = dsExpr expr `thenDs` \ expr2 -> - dsExpr from `thenDs` \ from2 -> - dsExpr thn `thenDs` \ thn2 -> - dsExpr two `thenDs` \ two2 -> + = dsLExpr expr `thenDs` \ expr2 -> + dsLExpr from `thenDs` \ from2 -> + dsLExpr thn `thenDs` \ thn2 -> + dsLExpr two `thenDs` \ two2 -> returnDs (mkApps expr2 [from2, thn2, two2]) dsExpr (PArrSeqOut expr (FromTo from two)) - = dsExpr expr `thenDs` \ expr2 -> - dsExpr from `thenDs` \ from2 -> - dsExpr two `thenDs` \ two2 -> + = dsLExpr expr `thenDs` \ expr2 -> + dsLExpr from `thenDs` \ from2 -> + dsLExpr two `thenDs` \ two2 -> returnDs (mkApps expr2 [from2, two2]) dsExpr (PArrSeqOut expr (FromThenTo from thn two)) - = dsExpr expr `thenDs` \ expr2 -> - dsExpr from `thenDs` \ from2 -> - dsExpr thn `thenDs` \ thn2 -> - dsExpr two `thenDs` \ two2 -> + = dsLExpr expr `thenDs` \ expr2 -> + dsLExpr from `thenDs` \ from2 -> + dsLExpr thn `thenDs` \ thn2 -> + dsLExpr two `thenDs` \ two2 -> returnDs (mkApps expr2 [from2, thn2, two2]) dsExpr (PArrSeqOut expr _) @@ -415,17 +405,17 @@ constructor @C@, setting all of @C@'s fields to bottom. \begin{code} dsExpr (RecordConOut data_con con_expr rbinds) - = dsExpr con_expr `thenDs` \ con_expr' -> + = dsLExpr con_expr `thenDs` \ con_expr' -> let (arg_tys, _) = tcSplitFunTys (exprType con_expr') -- A newtype in the corner should be opaque; -- hence TcType.tcSplitFunTys mk_arg (arg_ty, lbl) - = case [rhs | (sel_id,rhs) <- rbinds, + = case [rhs | (L _ sel_id, rhs) <- rbinds, lbl == recordSelectorFieldLabel sel_id] of (rhs:rhss) -> ASSERT( null rhss ) - dsExpr rhs + dsLExpr rhs [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showSDoc (ppr lbl)) unlabelled_bottom arg_ty = mkErrorAppDs rEC_CON_ERROR_ID arg_ty "" @@ -463,11 +453,10 @@ dictionaries. \begin{code} dsExpr (RecordUpdOut record_expr record_in_ty record_out_ty []) - = dsExpr record_expr + = dsLExpr record_expr dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) - = getSrcLocDs `thenDs` \ src_loc -> - dsExpr record_expr `thenDs` \ record_expr' -> + = dsLExpr record_expr `thenDs` \ record_expr' -> -- Desugar the rbinds, and generate let-bindings if -- necessary so that we don't lose sharing @@ -477,10 +466,10 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) out_inst_tys = tcTyConAppArgs record_out_ty -- Newtype opaque mk_val_arg field old_arg_id - = case [rhs | (sel_id, rhs) <- rbinds, + = case [rhs | (L _ sel_id, rhs) <- rbinds, field == recordSelectorFieldLabel sel_id] of (rhs:rest) -> ASSERT(null rest) rhs - [] -> HsVar old_arg_id + [] -> nlHsVar old_arg_id mk_alt con = newSysLocalsDs (dataConInstOrigArgTys con in_inst_tys) `thenDs` \ arg_ids -> @@ -488,13 +477,14 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) let val_args = zipWithEqual "dsExpr:RecordUpd" mk_val_arg (dataConFieldLabels con) arg_ids - rhs = foldl HsApp (TyApp (HsVar (dataConWrapId con)) out_inst_tys) - val_args + rhs = foldl (\a b -> nlHsApp a b) + (noLoc $ TyApp (nlHsVar (dataConWrapId con)) + out_inst_tys) + val_args in - returnDs (mkSimpleMatch [ConPatOut con (PrefixCon (map VarPat arg_ids)) record_in_ty [] []] + returnDs (mkSimpleMatch [noLoc $ ConPatOut con (PrefixCon (map nlVarPat arg_ids)) record_in_ty [] []] rhs - record_out_ty - src_loc) + record_out_ty) in -- Record stuff doesn't work for existentials -- The type checker checks for this, but we need @@ -512,7 +502,8 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) where updated_fields :: [FieldLabel] - updated_fields = [recordSelectorFieldLabel sel_id | (sel_id,_) <- rbinds] + updated_fields = [ recordSelectorFieldLabel sel_id + | (L _ sel_id,_) <- rbinds] -- Get the type constructor from the first field label, -- so that we are sure it'll have all its DataCons @@ -538,13 +529,13 @@ dsExpr expr@(RecordUpdOut record_expr record_in_ty record_out_ty rbinds) complicated; reminiscent of fully-applied constructors. \begin{code} dsExpr (DictLam dictvars expr) - = dsExpr expr `thenDs` \ core_expr -> + = dsLExpr expr `thenDs` \ core_expr -> returnDs (mkLams dictvars core_expr) ------------------ dsExpr (DictApp expr dicts) -- becomes a curried application - = dsExpr expr `thenDs` \ core_expr -> + = dsLExpr expr `thenDs` \ core_expr -> returnDs (foldl (\f d -> f `App` (Var d)) core_expr dicts) \end{code} @@ -555,11 +546,11 @@ Here is where we desugar the Template Haskell brackets and escapes #ifdef GHCI /* Only if bootstrapping */ dsExpr (HsBracketOut x ps) = dsBracket x ps -dsExpr (HsSplice n e _) = pprPanic "dsExpr:splice" (ppr e) +dsExpr (HsSplice n e) = pprPanic "dsExpr:splice" (ppr e) #endif -- Arrow notation extension -dsExpr (HsProc pat cmd src_loc) = dsProcExpr pat cmd src_loc +dsExpr (HsProc pat cmd) = dsProcExpr pat cmd \end{code} @@ -576,11 +567,13 @@ dsExpr (PArrSeqIn _) = panic "dsExpr:PArrSeqIn" %-------------------------------------------------------------------- -Basically does the translation given in the Haskell~1.3 report: +Desugar 'do' and 'mdo' expressions (NOT list comprehensions, they're +handled in DsListComp). Basically does the translation given in the +Haskell 98 report: \begin{code} dsDo :: HsStmtContext Name - -> [TypecheckedStmt] + -> [LStmt Id] -> ReboundNames Id -- id for: [return,fail,>>=,>>] and possibly mfixName -> Type -- Element type; the whole expression has type (m t) -> DsM CoreExpr @@ -594,50 +587,35 @@ dsDo do_or_lc stmts ids result_ty then_id = lookupReboundName ds_meths thenMName (m_ty, b_ty) = tcSplitAppTy result_ty -- result_ty must be of the form (m b) - is_do = isDoExpr do_or_lc -- True for both MDo and Do -- For ExprStmt, see the comments near HsExpr.Stmt about -- exactly what ExprStmts mean! -- -- In dsDo we can only see DoStmt and ListComp (no guards) - go [ResultStmt expr locn] - | is_do = do_expr expr locn - | otherwise = do_expr expr locn `thenDs` \ expr2 -> - returnDs (mkApps return_id [Type b_ty, expr2]) + go [ResultStmt expr] = dsLExpr expr - go (ExprStmt expr a_ty locn : stmts) - | is_do -- Do expression - = do_expr expr locn `thenDs` \ expr2 -> + + go (ExprStmt expr a_ty : stmts) + = dsLExpr expr `thenDs` \ expr2 -> go stmts `thenDs` \ rest -> returnDs (mkApps then_id [Type a_ty, Type b_ty, expr2, rest]) - - | otherwise -- List comprehension - = do_expr expr locn `thenDs` \ expr2 -> - go stmts `thenDs` \ rest -> - let - msg = "Pattern match failure in do expression, " ++ showSDoc (ppr locn) - in - mkStringLit msg `thenDs` \ core_msg -> - returnDs (mkIfThenElse expr2 rest - (App (App fail_id (Type b_ty)) core_msg)) go (LetStmt binds : stmts) = go stmts `thenDs` \ rest -> dsLet binds rest - go (BindStmt pat expr locn : stmts) + go (BindStmt pat expr : stmts) = go stmts `thenDs` \ body -> - putSrcLocDs locn $ -- Rest is associated with this location - dsExpr expr `thenDs` \ rhs -> - mkStringLit (mk_msg locn) `thenDs` \ core_msg -> + dsLExpr expr `thenDs` \ rhs -> + mkStringLit (mk_msg (getLoc pat)) `thenDs` \ core_msg -> let -- In a do expression, pattern-match failure just calls -- the monadic 'fail' rather than throwing an exception fail_expr = mkApps fail_id [Type b_ty, core_msg] a_ty = hsPatType pat in - selectMatchVar pat `thenDs` \ var -> + selectMatchVarL pat `thenDs` \ var -> matchSimply (Var var) (StmtCtxt do_or_lc) pat body fail_expr `thenDs` \ match_code -> returnDs (mkApps bind_id [Type a_ty, Type b_ty, rhs, Lam var match_code]) @@ -648,11 +626,10 @@ dsDo do_or_lc stmts ids result_ty bind_stmt = dsRecStmt m_ty ds_meths rec_stmts later_vars rec_vars rec_rets in - go stmts `thenDs` \ stmts_code -> + go (map unLoc stmts) `thenDs` \ stmts_code -> returnDs (foldr Let stmts_code meth_binds) where - do_expr expr locn = putSrcLocDs locn (dsExpr expr) mk_msg locn = "Pattern match failure in do expression at " ++ showSDoc (ppr locn) \end{code} @@ -666,35 +643,34 @@ We turn (RecStmt [v1,..vn] stmts) into: \begin{code} dsRecStmt :: Type -- Monad type constructor :: * -> * -> [(Name,Id)] -- Rebound Ids - -> [TypecheckedStmt] - -> [Id] -> [Id] -> [TypecheckedHsExpr] - -> TypecheckedStmt + -> [LStmt Id] + -> [Id] -> [Id] -> [LHsExpr Id] + -> Stmt Id dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets = ASSERT( length vars == length rets ) - BindStmt tup_pat mfix_app noSrcLoc + BindStmt tup_pat mfix_app where vars@(var1:rest) = later_vars ++ rec_vars -- Always at least one - rets@(ret1:_) = map HsVar later_vars ++ rec_rets + rets@(ret1:_) = map nlHsVar later_vars ++ rec_rets one_var = null rest - mfix_app = HsApp (TyApp (HsVar mfix_id) [tup_ty]) mfix_arg - mfix_arg = HsLam (mkSimpleMatch [tup_pat] body tup_ty noSrcLoc) + mfix_app = nlHsApp (noLoc $ TyApp (nlHsVar mfix_id) [tup_ty]) mfix_arg + mfix_arg = noLoc $ HsLam (mkSimpleMatch [tup_pat] body tup_ty) tup_expr | one_var = ret1 - | otherwise = ExplicitTuple rets Boxed + | otherwise = noLoc $ ExplicitTuple rets Boxed tup_ty = mkCoreTupTy (map idType vars) -- Deals with singleton case - tup_pat | one_var = VarPat var1 - | otherwise = LazyPat (TuplePat (map VarPat vars) Boxed) + tup_pat | one_var = nlVarPat var1 + | otherwise = noLoc $ LazyPat (noLoc $ TuplePat (map nlVarPat vars) Boxed) - body = HsDo DoExpr (stmts ++ [return_stmt]) - [(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack + body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt]) + [(n, nlHsVar id) | (n,id) <- ds_meths] -- A bit of a hack (mkAppTy m_ty tup_ty) - noSrcLoc Var return_id = lookupReboundName ds_meths returnMName Var mfix_id = lookupReboundName ds_meths mfixName - return_stmt = ResultStmt return_app noSrcLoc - return_app = HsApp (TyApp (HsVar return_id) [tup_ty]) tup_expr + return_stmt = noLoc $ ResultStmt return_app + return_app = nlHsApp (noLoc $ TyApp (nlHsVar return_id) [tup_ty]) tup_expr \end{code} diff --git a/ghc/compiler/deSugar/DsForeign.lhs b/ghc/compiler/deSugar/DsForeign.lhs index 77aa4120ce..05dcb05221 100644 --- a/ghc/compiler/deSugar/DsForeign.lhs +++ b/ghc/compiler/deSugar/DsForeign.lhs @@ -16,9 +16,8 @@ import CoreSyn import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper ) import DsMonad -import HsSyn ( ForeignDecl(..), ForeignExport(..), +import HsSyn ( ForeignDecl(..), ForeignExport(..), LForeignDecl, ForeignImport(..), CImportSpec(..) ) -import TcHsSyn ( TypecheckedForeignDecl ) import CoreUtils ( exprType, mkInlineMe ) import Id ( Id, idType, idName, mkSysLocal, setInlinePragma ) import Literal ( Literal(..) ) @@ -46,6 +45,7 @@ import PrimRep ( getPrimRepSizeInBytes ) import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName, checkDotnetResName ) import BasicTypes ( Activation( NeverActive ) ) +import SrcLoc ( Located(..), unLoc ) import Outputable import Maybe ( fromJust ) import FastString @@ -68,7 +68,7 @@ so we reuse the desugaring code in @DsCCall@ to deal with these. type Binding = (Id, CoreExpr) -- No rec/nonrec structure; -- the occurrence analyser will sort it all out -dsForeigns :: [TypecheckedForeignDecl] +dsForeigns :: [LForeignDecl Id] -> DsM (ForeignStubs, [Binding]) dsForeigns [] = returnDs (NoStubs, []) @@ -76,9 +76,9 @@ dsForeigns fos = foldlDs combine (ForeignStubs empty empty [] [], []) fos where combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (ForeignImport id _ spec depr loc) + (L loc (ForeignImport id _ spec depr)) = traceIf (text "fi start" <+> ppr id) `thenDs` \ _ -> - dsFImport id spec `thenDs` \ (bs, h, c, mbhd) -> + dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) -> warnDepr depr loc `thenDs` \ _ -> traceIf (text "fi end" <+> ppr id) `thenDs` \ _ -> returnDs (ForeignStubs (h $$ acc_h) @@ -88,7 +88,7 @@ dsForeigns fos bs ++ acc_f) combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f) - (ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc) + (L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr)) = dsFExport id (idType id) ext_nm cconv False `thenDs` \(h, c, _) -> warnDepr depr loc `thenDs` \_ -> diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index 75c76d6209..60c67bc440 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -8,13 +8,14 @@ module DsGRHSs ( dsGuarded, dsGRHSs ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) +import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet ) import {-# SOURCE #-} Match ( matchSinglePat ) -import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) ) -import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext ) +import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), + HsMatchContext(..), Pat(..), LStmt ) import CoreSyn ( CoreExpr ) import Type ( Type ) +import Var ( Id ) import DsMonad import DsUtils @@ -22,6 +23,8 @@ import Unique ( Uniquable(..) ) import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID ) import TysWiredIn ( trueDataConId ) import PrelNames ( otherwiseIdKey, hasKey ) +import Name ( Name ) +import SrcLoc ( unLoc, Located(..) ) \end{code} @dsGuarded@ is used for both @case@ expressions and pattern bindings. @@ -36,7 +39,7 @@ producing an expression with a runtime error in the corner if necessary. The type argument gives the type of the @ei@. \begin{code} -dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr +dsGuarded :: GRHSs Id -> DsM CoreExpr dsGuarded grhss = dsGRHSs PatBindRhs [] grhss `thenDs` \ (err_ty, match_result) -> @@ -47,8 +50,8 @@ dsGuarded grhss In contrast, @dsGRHSs@ produces a @MatchResult@. \begin{code} -dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from - -> TypecheckedGRHSs -- Guarded RHSs +dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from + -> GRHSs Id -- Guarded RHSs -> DsM (Type, MatchResult) dsGRHSs kind pats (GRHSs grhss binds ty) @@ -60,8 +63,8 @@ dsGRHSs kind pats (GRHSs grhss binds ty) in returnDs (ty, match_result2) -dsGRHS kind pats (GRHS guard locn) - = matchGuard guard (DsMatchContext kind pats locn) +dsGRHS kind pats (L loc (GRHS guard)) + = matchGuard (map unLoc guard) (DsMatchContext kind pats loc) \end{code} @@ -72,29 +75,29 @@ dsGRHS kind pats (GRHS guard locn) %************************************************************************ \begin{code} -matchGuard :: [TypecheckedStmt] -- Guard +matchGuard :: [Stmt Id] -- Guard -> DsMatchContext -- Context -> DsM MatchResult -- See comments with HsExpr.Stmt re what an ExprStmt means -- Here we must be in a guard context (not do-expression, nor list-comp) -matchGuard [ResultStmt expr locn] ctx - = putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr -> +matchGuard [ResultStmt expr] ctx + = dsLExpr expr `thenDs` \ core_expr -> returnDs (cantFailMatchResult core_expr) -- ExprStmts must be guards -- Turn an "otherwise" guard is a no-op -matchGuard (ExprStmt (HsVar v) _ _ : stmts) ctx +matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx | v `hasKey` otherwiseIdKey || v `hasKey` getUnique trueDataConId -- trueDataConId doesn't have the same -- unique as trueDataCon = matchGuard stmts ctx -matchGuard (ExprStmt expr _ locn : stmts) ctx - = matchGuard stmts ctx `thenDs` \ match_result -> - putSrcLocDs locn (dsExpr expr) `thenDs` \ pred_expr -> +matchGuard (ExprStmt expr _ : stmts) ctx + = matchGuard stmts ctx `thenDs` \ match_result -> + dsLExpr expr `thenDs` \ pred_expr -> returnDs (mkGuardedMatchResult pred_expr match_result) matchGuard (LetStmt binds : stmts) ctx @@ -102,9 +105,9 @@ matchGuard (LetStmt binds : stmts) ctx returnDs (adjustMatchResultDs (dsLet binds) match_result) -- NB the dsLet occurs inside the match_result -matchGuard (BindStmt pat rhs locn : stmts) ctx +matchGuard (BindStmt pat rhs : stmts) ctx = matchGuard stmts ctx `thenDs` \ match_result -> - putSrcLocDs locn (dsExpr rhs) `thenDs` \ core_rhs -> + dsLExpr rhs `thenDs` \ core_rhs -> matchSinglePat core_rhs ctx pat match_result \end{code} diff --git a/ghc/compiler/deSugar/DsListComp.lhs b/ghc/compiler/deSugar/DsListComp.lhs index fc3a689773..41bb4d70ff 100644 --- a/ghc/compiler/deSugar/DsListComp.lhs +++ b/ghc/compiler/deSugar/DsListComp.lhs @@ -8,14 +8,11 @@ module DsListComp ( dsListComp, dsPArrComp ) where #include "HsVersions.h" -import {-# SOURCE #-} DsExpr ( dsExpr, dsLet ) +import {-# SOURCE #-} DsExpr ( dsExpr, dsLExpr, dsLet ) import BasicTypes ( Boxity(..) ) -import HsSyn ( Pat(..), HsExpr(..), Stmt(..), - HsMatchContext(..), HsStmtContext(..), - collectHsBinders ) -import TcHsSyn ( TypecheckedStmt, TypecheckedPat, TypecheckedHsExpr, - hsPatType ) +import HsSyn +import TcHsSyn ( hsPatType ) import CoreSyn import DsMonad -- the monadery used in the desugarer @@ -34,7 +31,7 @@ import Match ( matchSimply ) import PrelNames ( foldrName, buildName, replicatePName, mapPName, filterPName, zipPName, crossPName ) import PrelInfo ( pAT_ERROR_ID ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noLoc, Located(..), unLoc ) import Panic ( panic ) \end{code} @@ -45,12 +42,14 @@ turned on'' (if you read Gill {\em et al.}'s paper on the subject). There will be at least one ``qualifier'' in the input. \begin{code} -dsListComp :: [TypecheckedStmt] +dsListComp :: [LStmt Id] -> Type -- Type of list elements -> DsM CoreExpr - -dsListComp quals elt_ty +dsListComp lquals elt_ty = getDOptsDs `thenDs` \dflags -> + let + quals = map unLoc lquals + in if opt_RulesOff || dopt Opt_IgnoreInterfacePragmas dflags -- Either rules are switched off, or we are ignoring what there are; -- Either way foldr/build won't happen, so use the more efficient @@ -142,8 +141,7 @@ The introduced tuples are Boxed, but only because I couldn't get it to work with the Unboxed variety. \begin{code} - -deListComp :: [TypecheckedStmt] -> CoreExpr -> DsM CoreExpr +deListComp :: [Stmt Id] -> CoreExpr -> DsM CoreExpr deListComp (ParStmt stmtss_w_bndrs : quals) list = mappM do_list_comp stmtss_w_bndrs `thenDs` \ exps -> @@ -157,26 +155,26 @@ deListComp (ParStmt stmtss_w_bndrs : quals) list bndrs_s = map snd stmtss_w_bndrs -- pat is the pattern ((x1,..,xn), (y1,..,ym)) in the example above - pat = TuplePat pats Boxed + pat = noLoc (TuplePat pats Boxed) pats = map mk_hs_tuple_pat bndrs_s -- Types of (x1,..,xn), (y1,..,yn) etc qual_tys = map mk_bndrs_tys bndrs_s do_list_comp (stmts, bndrs) - = dsListComp (stmts ++ [ResultStmt (mk_hs_tuple_expr bndrs) noSrcLoc]) + = dsListComp (stmts ++ [noLoc $ ResultStmt (mk_hs_tuple_expr bndrs)]) (mk_bndrs_tys bndrs) mk_bndrs_tys bndrs = mkCoreTupTy (map idType bndrs) -- Last: the one to return -deListComp [ResultStmt expr locn] list -- Figure 7.4, SLPJ, p 135, rule C above - = dsExpr expr `thenDs` \ core_expr -> +deListComp [ResultStmt expr] list -- Figure 7.4, SLPJ, p 135, rule C above + = dsLExpr expr `thenDs` \ core_expr -> returnDs (mkConsExpr (exprType core_expr) core_expr list) -- Non-last: must be a guard -deListComp (ExprStmt guard ty locn : quals) list -- rule B above - = dsExpr guard `thenDs` \ core_guard -> +deListComp (ExprStmt guard ty : quals) list -- rule B above + = dsLExpr guard `thenDs` \ core_guard -> deListComp quals list `thenDs` \ core_rest -> returnDs (mkIfThenElse core_guard core_rest list) @@ -185,8 +183,8 @@ deListComp (LetStmt binds : quals) list = deListComp quals list `thenDs` \ core_rest -> dsLet binds core_rest -deListComp (BindStmt pat list1 locn : quals) core_list2 -- rule A' above - = dsExpr list1 `thenDs` \ core_list1 -> +deListComp (BindStmt pat list1 : quals) core_list2 -- rule A' above + = dsLExpr list1 `thenDs` \ core_list1 -> deBindComp pat core_list1 quals core_list2 \end{code} @@ -253,14 +251,14 @@ mkZipBind elt_tys (DataAlt consDataCon, [a', as'], rest)] -- Helper functions that makes an HsTuple only for non-1-sized tuples -mk_hs_tuple_expr :: [Id] -> TypecheckedHsExpr -mk_hs_tuple_expr [] = HsVar unitDataConId -mk_hs_tuple_expr [id] = HsVar id -mk_hs_tuple_expr ids = ExplicitTuple [ HsVar i | i <- ids ] Boxed - -mk_hs_tuple_pat :: [Id] -> TypecheckedPat -mk_hs_tuple_pat [b] = VarPat b -mk_hs_tuple_pat bs = TuplePat (map VarPat bs) Boxed +mk_hs_tuple_expr :: [Id] -> LHsExpr Id +mk_hs_tuple_expr [] = nlHsVar unitDataConId +mk_hs_tuple_expr [id] = nlHsVar id +mk_hs_tuple_expr ids = noLoc $ ExplicitTuple [ nlHsVar i | i <- ids ] Boxed + +mk_hs_tuple_pat :: [Id] -> LPat Id +mk_hs_tuple_pat [b] = nlVarPat b +mk_hs_tuple_pat bs = noLoc $ TuplePat (map nlVarPat bs) Boxed \end{code} @@ -285,17 +283,17 @@ TE[ e | p <- l , q ] c n = let \begin{code} dfListComp :: Id -> Id -- 'c' and 'n' - -> [TypecheckedStmt] -- the rest of the qual's + -> [Stmt Id] -- the rest of the qual's -> DsM CoreExpr -- Last: the one to return -dfListComp c_id n_id [ResultStmt expr locn] - = dsExpr expr `thenDs` \ core_expr -> +dfListComp c_id n_id [ResultStmt expr] + = dsLExpr expr `thenDs` \ core_expr -> returnDs (mkApps (Var c_id) [core_expr, Var n_id]) -- Non-last: must be a guard -dfListComp c_id n_id (ExprStmt guard ty locn : quals) - = dsExpr guard `thenDs` \ core_guard -> +dfListComp c_id n_id (ExprStmt guard ty : quals) + = dsLExpr guard `thenDs` \ core_guard -> dfListComp c_id n_id quals `thenDs` \ core_rest -> returnDs (mkIfThenElse core_guard core_rest (Var n_id)) @@ -304,9 +302,9 @@ dfListComp c_id n_id (LetStmt binds : quals) = dfListComp c_id n_id quals `thenDs` \ core_rest -> dsLet binds core_rest -dfListComp c_id n_id (BindStmt pat list1 locn : quals) +dfListComp c_id n_id (BindStmt pat list1 : quals) -- evaluate the two lists - = dsExpr list1 `thenDs` \ core_list1 -> + = dsLExpr list1 `thenDs` \ core_list1 -> -- find the required type let x_ty = hsPatType pat @@ -346,7 +344,7 @@ dfListComp c_id n_id (BindStmt pat list1 locn : quals) -- -- [:e | qss:] = <<[:e | qss:]>> () [:():] -- -dsPArrComp :: [TypecheckedStmt] +dsPArrComp :: [Stmt Id] -> Type -- Don't use; called with `undefined' below -> DsM CoreExpr dsPArrComp qs _ = @@ -355,18 +353,18 @@ dsPArrComp qs _ = mkIntExpr 1, mkCoreTup []] in - dePArrComp qs (TuplePat [] Boxed) unitArray + dePArrComp qs (noLoc (TuplePat [] Boxed)) unitArray -- the work horse -- -dePArrComp :: [TypecheckedStmt] - -> TypecheckedPat -- the current generator pattern - -> CoreExpr -- the current generator expression +dePArrComp :: [Stmt Id] + -> LPat Id -- the current generator pattern + -> CoreExpr -- the current generator expression -> DsM CoreExpr -- -- <<[:e' | :]>> pa ea = mapP (\pa -> e') ea -- -dePArrComp [ResultStmt e' _] pa cea = +dePArrComp [ResultStmt e'] pa cea = dsLookupGlobalId mapPName `thenDs` \mapP -> let ty = parrElemType cea in @@ -376,7 +374,7 @@ dePArrComp [ResultStmt e' _] pa cea = -- -- <<[:e' | b, qs:]>> pa ea = <<[:e' | qs:]>> pa (filterP (\pa -> b) ea) -- -dePArrComp (ExprStmt b _ _ : qs) pa cea = +dePArrComp (ExprStmt b _ : qs) pa cea = dsLookupGlobalId filterPName `thenDs` \filterP -> let ty = parrElemType cea in @@ -388,10 +386,10 @@ dePArrComp (ExprStmt b _ _ : qs) pa cea = -- in -- <<[:e' | qs:]>> (pa, p) (crossP ea ef) -- -dePArrComp (BindStmt p e _ : qs) pa cea = +dePArrComp (BindStmt p e : qs) pa cea = dsLookupGlobalId filterPName `thenDs` \filterP -> dsLookupGlobalId crossPName `thenDs` \crossP -> - dsExpr e `thenDs` \ce -> + dsLExpr e `thenDs` \ce -> let ty'cea = parrElemType cea ty'ce = parrElemType ce false = Var falseDataConId @@ -401,7 +399,7 @@ dePArrComp (BindStmt p e _ : qs) pa cea = matchSimply (Var v) (StmtCtxt PArrComp) p true false `thenDs` \pred -> let cef = mkApps (Var filterP) [Type ty'ce, mkLams [v] pred, ce] ty'cef = ty'ce -- filterP preserves the type - pa' = TuplePat [pa, p] Boxed + pa' = noLoc (TuplePat [pa, p] Boxed) in dePArrComp qs pa' (mkApps (Var crossP) [Type ty'cea, Type ty'cef, cea, cef]) -- @@ -413,7 +411,7 @@ dePArrComp (BindStmt p e _ : qs) pa cea = -- dePArrComp (LetStmt ds : qs) pa cea = dsLookupGlobalId mapPName `thenDs` \mapP -> - let xs = collectHsBinders ds + let xs = map unLoc (collectGroupBinders ds) ty'cea = parrElemType cea in newSysLocalDs ty'cea `thenDs` \v -> @@ -426,7 +424,7 @@ dePArrComp (LetStmt ds : qs) pa cea = in mkErrorAppDs pAT_ERROR_ID errTy errMsg `thenDs` \cerr -> matchSimply (Var v) (StmtCtxt PArrComp) pa projBody cerr `thenDs` \ccase -> - let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed + let pa' = noLoc $ TuplePat [pa, noLoc (TuplePat (map nlVarPat xs) Boxed)] Boxed proj = mkLams [v] ccase in dePArrComp qs pa' (mkApps (Var mapP) [Type ty'cea, proj, cea]) @@ -440,11 +438,11 @@ dePArrComp (LetStmt ds : qs) pa cea = dePArrComp (ParStmt [] : qss2) pa cea = dePArrComp qss2 pa cea dePArrComp (ParStmt ((qs, xs):qss) : qss2) pa cea = dsLookupGlobalId zipPName `thenDs` \zipP -> - let pa' = TuplePat [pa, TuplePat (map VarPat xs) Boxed] Boxed + let pa' = noLoc $ TuplePat [pa, noLoc (TuplePat (map nlVarPat xs) Boxed)] Boxed ty'cea = parrElemType cea - resStmt = ResultStmt (ExplicitTuple (map HsVar xs) Boxed) noSrcLoc + resStmt = ResultStmt (noLoc $ ExplicitTuple (map nlHsVar xs) Boxed) in - dsPArrComp (qs ++ [resStmt]) undefined `thenDs` \cqs -> + dsPArrComp (map unLoc qs ++ [resStmt]) undefined `thenDs` \cqs -> let ty'cqs = parrElemType cqs cea' = mkApps (Var zipP) [Type ty'cea, Type ty'cqs, cea, cqs] in @@ -453,12 +451,12 @@ dePArrComp (ParStmt ((qs, xs):qss) : qss2) pa cea = -- generate Core corresponding to `\p -> e' -- deLambda :: Type -- type of the argument - -> TypecheckedPat -- argument pattern - -> TypecheckedHsExpr -- body + -> LPat Id -- argument pattern + -> LHsExpr Id -- body -> DsM (CoreExpr, Type) deLambda ty p e = newSysLocalDs ty `thenDs` \v -> - dsExpr e `thenDs` \ce -> + dsLExpr e `thenDs` \ce -> let errTy = exprType ce errMsg = "DsListComp.deLambda: internal error!" in diff --git a/ghc/compiler/deSugar/DsMeta.hs b/ghc/compiler/deSugar/DsMeta.hs index f1a83e9b8a..e312028316 100644 --- a/ghc/compiler/deSugar/DsMeta.hs +++ b/ghc/compiler/deSugar/DsMeta.hs @@ -27,21 +27,7 @@ import DsMonad import qualified Language.Haskell.TH as TH -import HsSyn ( Pat(..), HsExpr(..), Stmt(..), HsLit(..), HsOverLit(..), - Match(..), GRHSs(..), GRHS(..), HsBracket(..), - HsStmtContext(ListComp,DoExpr), ArithSeqInfo(..), - HsBinds(..), MonoBinds(..), HsConDetails(..), - TyClDecl(..), HsGroup(..), HsBang(..), - HsType(..), HsContext(..), HsPred(..), - HsTyVarBndr(..), Sig(..), ForeignDecl(..), - InstDecl(..), ConDecl(..), BangType(..), - PendingSplice, splitHsInstDeclTy, - placeHolderType, tyClDeclNames, - collectHsBinders, collectPatBinders, - collectMonoBinders, collectPatsBinders, - hsTyVarName, hsConArgs - ) - +import HsSyn import PrelNames ( rationalTyConName, integerTyConName, negateName ) import OccName ( isDataOcc, isTvOcc, occNameUserString ) -- To avoid clashes with DsMeta.varName we must make a local alias for OccName.varName @@ -51,29 +37,24 @@ import OccName ( isDataOcc, isTvOcc, occNameUserString ) import qualified OccName import Module ( Module, mkModule, mkModuleName, moduleUserString ) -import Id ( Id, idType, mkLocalId ) +import Id ( Id, mkLocalId ) import OccName ( mkOccFS ) import Name ( Name, mkExternalName, localiseName, nameOccName, nameModule, isExternalName, getSrcLoc ) import NameEnv -import NameSet import Type ( Type, mkGenTyConApp ) import TcType ( tcTyConAppArgs ) -import TyCon ( DataConDetails(..), tyConName ) -import TysWiredIn ( stringTy, parrTyCon ) +import TyCon ( tyConName ) +import TysWiredIn ( parrTyCon ) import CoreSyn import CoreUtils ( exprType ) -import SrcLoc ( noSrcLoc ) -import Maybes ( orElse ) -import Maybe ( catMaybes, fromMaybe ) -import Panic ( panic ) +import SrcLoc ( noSrcLoc, unLoc, Located(..), SrcSpan, srcLocSpan ) +import Maybe ( catMaybes ) import Unique ( mkPreludeTyConUnique, mkPreludeMiscIdUnique, getKey, Uniquable(..) ) -import BasicTypes ( NewOrData(..), StrictnessMark(..), isBoxed ) -import SrcLoc ( SrcLoc ) +import BasicTypes ( NewOrData(..), isBoxed ) import Packages ( thPackage ) import Outputable -import FastString ( mkFastString ) -import FastTypes ( iBox ) +import Bag ( bagToList ) import Monad ( zipWithM ) import List ( sortBy ) @@ -87,12 +68,12 @@ dsBracket :: HsBracket Name -> [PendingSplice] -> DsM CoreExpr dsBracket brack splices = dsExtendMetaEnv new_bit (do_brack brack) where - new_bit = mkNameEnv [(n, Splice e) | (n,e) <- splices] + new_bit = mkNameEnv [(n, Splice (unLoc e)) | (n,e) <- splices] do_brack (VarBr n) = do { MkC e1 <- lookupOcc n ; return e1 } - do_brack (ExpBr e) = do { MkC e1 <- repE e ; return e1 } - do_brack (PatBr p) = do { MkC p1 <- repP p ; return p1 } - do_brack (TypBr t) = do { MkC t1 <- repTy t ; return t1 } + do_brack (ExpBr e) = do { MkC e1 <- repLE e ; return e1 } + do_brack (PatBr p) = do { MkC p1 <- repLP p ; return p1 } + do_brack (TypBr t) = do { MkC t1 <- repLTy t ; return t1 } do_brack (DecBr ds) = do { MkC ds1 <- repTopDs ds ; return ds1 } {- -------------- Examples -------------------- @@ -116,7 +97,7 @@ dsBracket brack splices repTopDs :: HsGroup Name -> DsM (Core (TH.Q [TH.Dec])) repTopDs group - = do { let { bndrs = groupBinders group } ; + = do { let { bndrs = map unLoc (groupBinders group) } ; ss <- mkGenSyms bndrs ; -- Bind all the names mainly to avoid repeated use of explicit strings. @@ -128,11 +109,11 @@ repTopDs group decls <- addBinds ss (do { - val_ds <- rep_binds' (hs_valds group) ; - tycl_ds <- mapM repTyClD' (hs_tyclds group) ; + val_ds <- mapM rep_bind_group (hs_valds group) ; + tycl_ds <- mapM repTyClD (hs_tyclds group) ; inst_ds <- mapM repInstD' (hs_instds group) ; -- more needed - return (de_loc $ sort_by_loc $ val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; + return (de_loc $ sort_by_loc $ concat val_ds ++ catMaybes tycl_ds ++ inst_ds) }) ; decl_ty <- lookupType decQTyConName ; let { core_list = coreList' decl_ty decls } ; @@ -147,9 +128,9 @@ repTopDs group groupBinders (HsGroup { hs_valds = val_decls, hs_tyclds = tycl_decls, hs_fords = foreign_decls }) -- Collect the binders of a Group - = collectHsBinders val_decls ++ - [n | d <- tycl_decls, (n,_) <- tyClDeclNames d] ++ - [n | ForeignImport n _ _ _ _ <- foreign_decls] + = collectGroupBinders val_decls ++ + [n | d <- tycl_decls, n <- tyClDeclNames (unLoc d)] ++ + [n | L _ (ForeignImport n _ _ _) <- foreign_decls] {- Note [Binders and occurrences] @@ -176,19 +157,14 @@ in repTyClD and repC. -} -repTyClD :: TyClDecl Name -> DsM (Maybe (Core TH.DecQ)) -repTyClD decl = do x <- repTyClD' decl - return (fmap snd x) - -repTyClD' :: TyClDecl Name -> DsM (Maybe (SrcLoc, Core TH.DecQ)) +repTyClD :: LTyClDecl Name -> DsM (Maybe (SrcSpan, Core TH.DecQ)) -repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, - tcdName = tc, tcdTyVars = tvs, - tcdCons = cons, tcdDerivs = mb_derivs, - tcdLoc = loc}) - = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] +repTyClD (L loc (TyData { tcdND = DataType, tcdCtxt = cxt, + tcdLName = tc, tcdTyVars = tvs, + tcdCons = cons, tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repContext cxt ; + cxt1 <- repLContext cxt ; cons1 <- mapM repC cons ; cons2 <- coreList conQTyConName cons1 ; derivs1 <- repDerivs mb_derivs ; @@ -196,56 +172,53 @@ repTyClD' (TyData { tcdND = DataType, tcdCtxt = cxt, repData cxt1 tc1 bndrs1 cons2 derivs1 } ; return $ Just (loc, dec) } -repTyClD' (TyData { tcdND = NewType, tcdCtxt = cxt, - tcdName = tc, tcdTyVars = tvs, - tcdCons = [con], tcdDerivs = mb_derivs, - tcdLoc = loc}) - = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] +repTyClD (L loc (TyData { tcdND = NewType, tcdCtxt = cxt, + tcdLName = tc, tcdTyVars = tvs, + tcdCons = [con], tcdDerivs = mb_derivs })) + = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repContext cxt ; + cxt1 <- repLContext cxt ; con1 <- repC con ; derivs1 <- repDerivs mb_derivs ; bndrs1 <- coreList nameTyConName bndrs ; repNewtype cxt1 tc1 bndrs1 con1 derivs1 } ; return $ Just (loc, dec) } -repTyClD' (TySynonym { tcdName = tc, tcdTyVars = tvs, tcdSynRhs = ty, - tcdLoc = loc}) - = do { tc1 <- lookupOcc tc ; -- See note [Binders and occurrences] +repTyClD (L loc (TySynonym { tcdLName = tc, tcdTyVars = tvs, tcdSynRhs = ty })) + = do { tc1 <- lookupLOcc tc ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - ty1 <- repTy ty ; + ty1 <- repLTy ty ; bndrs1 <- coreList nameTyConName bndrs ; repTySyn tc1 bndrs1 ty1 } ; return (Just (loc, dec)) } -repTyClD' (ClassDecl { tcdCtxt = cxt, tcdName = cls, +repTyClD (L loc (ClassDecl { tcdCtxt = cxt, tcdLName = cls, tcdTyVars = tvs, tcdFDs = [], -- We don't understand functional dependencies - tcdSigs = sigs, tcdMeths = meth_binds, - tcdLoc = loc}) - = do { cls1 <- lookupOcc cls ; -- See note [Binders and occurrences] + tcdSigs = sigs, tcdMeths = meth_binds })) + = do { cls1 <- lookupLOcc cls ; -- See note [Binders and occurrences] dec <- addTyVarBinds tvs $ \bndrs -> do { - cxt1 <- repContext cxt ; + cxt1 <- repLContext cxt ; sigs1 <- rep_sigs sigs ; - binds1 <- rep_monobind meth_binds ; + binds1 <- rep_binds meth_binds ; decls1 <- coreList decQTyConName (sigs1 ++ binds1) ; bndrs1 <- coreList nameTyConName bndrs ; repClass cxt1 cls1 bndrs1 decls1 } ; return $ Just (loc, dec) } -- Un-handled cases -repTyClD' d = do { addDsWarn (hang msg 4 (ppr d)) ; - return Nothing - } +repTyClD (L loc d) = do { dsWarn (loc, hang msg 4 (ppr d)) ; + return Nothing + } where msg = ptext SLIT("Cannot desugar this Template Haskell declaration:") -repInstD' (InstDecl ty binds _ loc) +repInstD' (L loc (InstDecl ty binds _)) -- Ignore user pragmas for now - = do { cxt1 <- repContext cxt + = do { cxt1 <- repContext cxt ; inst_ty1 <- repPred (HsClassP cls tys) - ; ss <- mkGenSyms (collectMonoBinders binds) - ; binds1 <- addBinds ss (rep_monobind binds) + ; ss <- mkGenSyms (collectHsBindBinders binds) + ; binds1 <- addBinds ss (rep_binds binds) ; decls1 <- coreList decQTyConName binds1 ; decls2 <- wrapNongenSyms ss decls1 -- wrapNonGenSyms: do not clone the class op names! @@ -253,23 +226,23 @@ repInstD' (InstDecl ty binds _ loc) ; i <- repInst cxt1 inst_ty1 decls2 ; return (loc, i)} where - (tvs, cxt, cls, tys) = splitHsInstDeclTy ty - + (_, cxt, cls, tys) = splitHsInstDeclTy (unLoc ty) ------------------------------------------------------- -- Constructors ------------------------------------------------------- -repC :: ConDecl Name -> DsM (Core TH.ConQ) -repC (ConDecl con [] [] details loc) - = do { con1 <- lookupOcc con ; -- See note [Binders and occurrences] +repC :: LConDecl Name -> DsM (Core TH.ConQ) +repC (L loc (ConDecl con [] (L _ []) details)) + = do { con1 <- lookupLOcc con ; -- See note [Binders and occurrences] repConstr con1 details } -repBangTy :: BangType Name -> DsM (Core (TH.StrictTypeQ)) -repBangTy (BangType str ty) = do MkC s <- rep2 strName [] - MkC t <- repTy ty - rep2 strictTypeName [s, t] - where strName = case str of +repBangTy :: LBangType Name -> DsM (Core (TH.StrictTypeQ)) +repBangTy (L _ (BangType str ty)) = do + MkC s <- rep2 strName [] + MkC t <- repLTy ty + rep2 strictTypeName [s, t] + where strName = case str of HsNoBang -> notStrictName other -> isStrictName @@ -277,40 +250,40 @@ repBangTy (BangType str ty) = do MkC s <- rep2 strName [] -- Deriving clause ------------------------------------------------------- -repDerivs :: Maybe (HsContext Name) -> DsM (Core [TH.Name]) +repDerivs :: Maybe (LHsContext Name) -> DsM (Core [TH.Name]) repDerivs Nothing = coreList nameTyConName [] -repDerivs (Just ctxt) +repDerivs (Just (L _ ctxt)) = do { strs <- mapM rep_deriv ctxt ; coreList nameTyConName strs } where - rep_deriv :: HsPred Name -> DsM (Core TH.Name) + rep_deriv :: LHsPred Name -> DsM (Core TH.Name) -- Deriving clauses must have the simple H98 form - rep_deriv (HsClassP cls []) = lookupOcc cls - rep_deriv other = panic "rep_deriv" + rep_deriv (L _ (HsClassP cls [])) = lookupOcc cls + rep_deriv other = panic "rep_deriv" ------------------------------------------------------- -- Signatures in a class decl, or a group of bindings ------------------------------------------------------- -rep_sigs :: [Sig Name] -> DsM [Core TH.DecQ] +rep_sigs :: [LSig Name] -> DsM [Core TH.DecQ] rep_sigs sigs = do locs_cores <- rep_sigs' sigs return $ de_loc $ sort_by_loc locs_cores -rep_sigs' :: [Sig Name] -> DsM [(SrcLoc, Core TH.DecQ)] +rep_sigs' :: [LSig Name] -> DsM [(SrcSpan, Core TH.DecQ)] -- We silently ignore ones we don't recognise rep_sigs' sigs = do { sigs1 <- mapM rep_sig sigs ; return (concat sigs1) } -rep_sig :: Sig Name -> DsM [(SrcLoc, Core TH.DecQ)] +rep_sig :: LSig Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Singleton => Ok -- Empty => Too hard, signature ignored -rep_sig (Sig nm ty loc) = rep_proto nm ty loc -rep_sig other = return [] +rep_sig (L loc (Sig nm ty)) = rep_proto nm ty loc +rep_sig other = return [] -rep_proto :: Name -> HsType Name -> SrcLoc -> DsM [(SrcLoc, Core TH.DecQ)] -rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; - ty1 <- repTy ty ; +rep_proto :: Located Name -> LHsType Name -> SrcSpan -> DsM [(SrcSpan, Core TH.DecQ)] +rep_proto nm ty loc = do { nm1 <- lookupLOcc nm ; + ty1 <- repLTy ty ; sig <- repProto nm1 ty1 ; return [(loc, sig)] } @@ -323,12 +296,12 @@ rep_proto nm ty loc = do { nm1 <- lookupOcc nm ; -- the computations passed as the second argument is executed in that extended -- meta environment and gets the *new* names on Core-level as an argument -- -addTyVarBinds :: [HsTyVarBndr Name] -- the binders to be added +addTyVarBinds :: [LHsTyVarBndr Name] -- the binders to be added -> ([Core TH.Name] -> DsM (Core (TH.Q a))) -- action in the ext env -> DsM (Core (TH.Q a)) addTyVarBinds tvs m = do - let names = map hsTyVarName tvs + let names = map (hsTyVarName.unLoc) tvs freshNames <- mkGenSyms names term <- addBinds freshNames $ do bndrs <- mapM lookupBinder names @@ -337,34 +310,43 @@ addTyVarBinds tvs m = -- represent a type context -- +repLContext :: LHsContext Name -> DsM (Core TH.CxtQ) +repLContext (L _ ctxt) = repContext ctxt + repContext :: HsContext Name -> DsM (Core TH.CxtQ) repContext ctxt = do - preds <- mapM repPred ctxt + preds <- mapM repLPred ctxt predList <- coreList typeQTyConName preds repCtxt predList -- represent a type predicate -- +repLPred :: LHsPred Name -> DsM (Core TH.TypeQ) +repLPred (L _ p) = repPred p + repPred :: HsPred Name -> DsM (Core TH.TypeQ) repPred (HsClassP cls tys) = do tcon <- repTy (HsTyVar cls) - tys1 <- repTys tys + tys1 <- repLTys tys repTapps tcon tys1 repPred (HsIParam _ _) = panic "DsMeta.repTy: Can't represent predicates with implicit parameters" -- yield the representation of a list of types -- -repTys :: [HsType Name] -> DsM [Core TH.TypeQ] -repTys tys = mapM repTy tys +repLTys :: [LHsType Name] -> DsM [Core TH.TypeQ] +repLTys tys = mapM repLTy tys -- represent a type -- +repLTy :: LHsType Name -> DsM (Core TH.TypeQ) +repLTy (L _ ty) = repTy ty + repTy :: HsType Name -> DsM (Core TH.TypeQ) repTy (HsForAllTy _ tvs ctxt ty) = addTyVarBinds tvs $ \bndrs -> do - ctxt1 <- repContext ctxt - ty1 <- repTy ty + ctxt1 <- repLContext ctxt + ty1 <- repLTy ty bndrs1 <- coreList nameTyConName bndrs repTForall bndrs1 ctxt1 ty1 @@ -376,32 +358,32 @@ repTy (HsTyVar n) tc1 <- lookupOcc n repNamedTyCon tc1 repTy (HsAppTy f a) = do - f1 <- repTy f - a1 <- repTy a + f1 <- repLTy f + a1 <- repLTy a repTapp f1 a1 repTy (HsFunTy f a) = do - f1 <- repTy f - a1 <- repTy a + f1 <- repLTy f + a1 <- repLTy a tcon <- repArrowTyCon repTapps tcon [f1, a1] repTy (HsListTy t) = do - t1 <- repTy t + t1 <- repLTy t tcon <- repListTyCon repTapp tcon t1 repTy (HsPArrTy t) = do - t1 <- repTy t + t1 <- repLTy t tcon <- repTy (HsTyVar (tyConName parrTyCon)) repTapp tcon t1 repTy (HsTupleTy tc tys) = do - tys1 <- repTys tys + tys1 <- repLTys tys tcon <- repTupleTyCon (length tys) repTapps tcon tys1 -repTy (HsOpTy ty1 n ty2) = repTy ((HsTyVar n `HsAppTy` ty1) - `HsAppTy` ty2) -repTy (HsParTy t) = repTy t +repTy (HsOpTy ty1 n ty2) = repLTy ((nlHsTyVar (unLoc n) `nlHsAppTy` ty1) + `nlHsAppTy` ty2) +repTy (HsParTy t) = repLTy t repTy (HsNumTy i) = panic "DsMeta.repTy: Can't represent number types (for generics)" -repTy (HsPredTy pred) = repPred pred +repTy (HsPredTy pred) = repLPred pred repTy (HsKindSig ty kind) = panic "DsMeta.repTy: Can't represent explicit kind signatures yet" @@ -410,13 +392,16 @@ repTy (HsKindSig ty kind) = -- Expressions ----------------------------------------------------------------------------- -repEs :: [HsExpr Name] -> DsM (Core [TH.ExpQ]) -repEs es = do { es' <- mapM repE es ; - coreList expQTyConName es' } +repLEs :: [LHsExpr Name] -> DsM (Core [TH.ExpQ]) +repLEs es = do { es' <- mapM repLE es ; + coreList expQTyConName es' } -- FIXME: some of these panics should be converted into proper error messages -- unless we can make sure that constructs, which are plainly not -- supported in TH already lead to error messages at an earlier stage +repLE :: LHsExpr Name -> DsM (Core TH.ExpQ) +repLE (L _ e) = repE e + repE :: HsExpr Name -> DsM (Core TH.ExpQ) repE (HsVar x) = do { mb_val <- dsLookupMetaEnv x @@ -433,80 +418,80 @@ repE (HsIPVar x) = panic "DsMeta.repE: Can't represent implicit parameters" repE (HsOverLit l) = do { a <- repOverloadedLiteral l; repLit a } repE (HsLit l) = do { a <- repLiteral l; repLit a } repE (HsLam m) = repLambda m -repE (HsApp x y) = do {a <- repE x; b <- repE y; repApp a b} +repE (HsApp x y) = do {a <- repLE x; b <- repLE y; repApp a b} repE (OpApp e1 op fix e2) = - do { arg1 <- repE e1; - arg2 <- repE e2; - the_op <- repE op ; + do { arg1 <- repLE e1; + arg2 <- repLE e2; + the_op <- repLE op ; repInfixApp arg1 the_op arg2 } repE (NegApp x nm) = do - a <- repE x + a <- repLE x negateVar <- lookupOcc negateName >>= repVar negateVar `repApp` a -repE (HsPar x) = repE x -repE (SectionL x y) = do { a <- repE x; b <- repE y; repSectionL a b } -repE (SectionR x y) = do { a <- repE x; b <- repE y; repSectionR a b } -repE (HsCase e ms loc) = do { arg <- repE e +repE (HsPar x) = repLE x +repE (SectionL x y) = do { a <- repLE x; b <- repLE y; repSectionL a b } +repE (SectionR x y) = do { a <- repLE x; b <- repLE y; repSectionR a b } +repE (HsCase e ms) = do { arg <- repLE e ; ms2 <- mapM repMatchTup ms ; repCaseE arg (nonEmptyCoreList ms2) } -repE (HsIf x y z loc) = do - a <- repE x - b <- repE y - c <- repE z +repE (HsIf x y z) = do + a <- repLE x + b <- repLE y + c <- repLE z repCond a b c repE (HsLet bs e) = do { (ss,ds) <- repBinds bs - ; e2 <- addBinds ss (repE e) + ; e2 <- addBinds ss (repLE e) ; z <- repLetE ds e2 ; wrapGenSyns ss z } -- FIXME: I haven't got the types here right yet -repE (HsDo DoExpr sts _ ty loc) - = do { (ss,zs) <- repSts sts; +repE (HsDo DoExpr sts _ ty) + = do { (ss,zs) <- repLSts sts; e <- repDoE (nonEmptyCoreList zs); wrapGenSyns ss e } -repE (HsDo ListComp sts _ ty loc) - = do { (ss,zs) <- repSts sts; +repE (HsDo ListComp sts _ ty) + = do { (ss,zs) <- repLSts sts; e <- repComp (nonEmptyCoreList zs); wrapGenSyns ss e } -repE (HsDo _ _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet" -repE (ExplicitList ty es) = do { xs <- repEs es; repListExp xs } +repE (HsDo _ _ _ _) = panic "DsMeta.repE: Can't represent mdo and [: :] yet" +repE (ExplicitList ty es) = do { xs <- repLEs es; repListExp xs } repE (ExplicitPArr ty es) = panic "DsMeta.repE: No explicit parallel arrays yet" repE (ExplicitTuple es boxed) - | isBoxed boxed = do { xs <- repEs es; repTup xs } + | isBoxed boxed = do { xs <- repLEs es; repTup xs } | otherwise = panic "DsMeta.repE: Can't represent unboxed tuples" repE (RecordCon c flds) - = do { x <- lookupOcc c; + = do { x <- lookupLOcc c; fs <- repFields flds; repRecCon x fs } repE (RecordUpd e flds) - = do { x <- repE e; + = do { x <- repLE e; fs <- repFields flds; repRecUpd x fs } -repE (ExprWithTySig e ty) = do { e1 <- repE e; t1 <- repTy ty; repSigExp e1 t1 } +repE (ExprWithTySig e ty) = do { e1 <- repLE e; t1 <- repLTy ty; repSigExp e1 t1 } repE (ArithSeqIn aseq) = case aseq of - From e -> do { ds1 <- repE e; repFrom ds1 } + From e -> do { ds1 <- repLE e; repFrom ds1 } FromThen e1 e2 -> do - ds1 <- repE e1 - ds2 <- repE e2 + ds1 <- repLE e1 + ds2 <- repLE e2 repFromThen ds1 ds2 FromTo e1 e2 -> do - ds1 <- repE e1 - ds2 <- repE e2 + ds1 <- repLE e1 + ds2 <- repLE e2 repFromTo ds1 ds2 FromThenTo e1 e2 e3 -> do - ds1 <- repE e1 - ds2 <- repE e2 - ds3 <- repE e3 + ds1 <- repLE e1 + ds2 <- repLE e2 + ds3 <- repLE e3 repFromThenTo ds1 ds2 ds3 repE (PArrSeqOut _ aseq) = panic "DsMeta.repE: parallel array seq.s missing" repE (HsCoreAnn _ _) = panic "DsMeta.repE: Can't represent CoreAnn" -- hdaume: core annotations repE (HsSCC _ _) = panic "DsMeta.repE: Can't represent SCC" repE (HsBracketOut _ _) = panic "DsMeta.repE: Can't represent Oxford brackets" -repE (HsSplice n e loc) = do { mb_val <- dsLookupMetaEnv n +repE (HsSplice n e) = do { mb_val <- dsLookupMetaEnv n ; case mb_val of Just (Splice e) -> do { e' <- dsExpr e ; return (MkC e') } @@ -517,43 +502,44 @@ repE e = ----------------------------------------------------------------------------- -- Building representations of auxillary structures like Match, Clause, Stmt, -repMatchTup :: Match Name -> DsM (Core TH.MatchQ) -repMatchTup (Match [p] ty (GRHSs guards wheres ty2)) = +repMatchTup :: LMatch Name -> DsM (Core TH.MatchQ) +repMatchTup (L _ (Match [p] ty (GRHSs guards wheres ty2))) = do { ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { - ; p1 <- repP p + ; p1 <- repLP p ; (ss2,ds) <- repBinds wheres ; addBinds ss2 $ do { ; gs <- repGuards guards ; match <- repMatch p1 gs ds ; wrapGenSyns (ss1++ss2) match }}} -repClauseTup :: Match Name -> DsM (Core TH.ClauseQ) -repClauseTup (Match ps ty (GRHSs guards wheres ty2)) = +repClauseTup :: LMatch Name -> DsM (Core TH.ClauseQ) +repClauseTup (L _ (Match ps ty (GRHSs guards wheres ty2))) = do { ss1 <- mkGenSyms (collectPatsBinders ps) ; addBinds ss1 $ do { - ps1 <- repPs ps + ps1 <- repLPs ps ; (ss2,ds) <- repBinds wheres ; addBinds ss2 $ do { gs <- repGuards guards ; clause <- repClause ps1 gs ds ; wrapGenSyns (ss1++ss2) clause }}} -repGuards :: [GRHS Name] -> DsM (Core TH.BodyQ) -repGuards [GRHS [ResultStmt e loc] loc2] - = do {a <- repE e; repNormal a } +repGuards :: [LGRHS Name] -> DsM (Core TH.BodyQ) +repGuards [L _ (GRHS [L _ (ResultStmt e)])] + = do {a <- repLE e; repNormal a } repGuards other = do { zs <- mapM process other; repGuarded (nonEmptyCoreList (map corePair zs)) } where - process (GRHS [ExprStmt e1 ty loc,ResultStmt e2 _] _) - = do { x <- repE e1; y <- repE e2; return (x, y) } + process (L _ (GRHS [L _ (ExprStmt e1 ty), + L _ (ResultStmt e2)])) + = do { x <- repLE e1; y <- repLE e2; return (x, y) } process other = panic "Non Haskell 98 guarded body" -repFields :: [(Name,HsExpr Name)] -> DsM (Core [TH.FieldExp]) +repFields :: [(Located Name, LHsExpr Name)] -> DsM (Core [TH.FieldExp]) repFields flds = do - fnames <- mapM lookupOcc (map fst flds) - es <- mapM repE (map snd flds) + fnames <- mapM lookupLOcc (map fst flds) + es <- mapM repLE (map snd flds) fs <- zipWithM (\n x -> rep2 fieldExpName [unC n, unC x]) fnames es coreList fieldExpTyConName fs @@ -583,16 +569,19 @@ repFields flds = do -- The helper function repSts computes the translation of each sub expression -- and a bunch of prefix bindings denoting the dynamic renaming. +repLSts :: [LStmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) +repLSts stmts = repSts (map unLoc stmts) + repSts :: [Stmt Name] -> DsM ([GenSymBind], [Core TH.StmtQ]) -repSts [ResultStmt e loc] = - do { a <- repE e +repSts [ResultStmt e] = + do { a <- repLE e ; e1 <- repNoBindSt a ; return ([], [e1]) } -repSts (BindStmt p e loc : ss) = - do { e2 <- repE e +repSts (BindStmt p e : ss) = + do { e2 <- repLE e ; ss1 <- mkGenSyms (collectPatBinders p) ; addBinds ss1 $ do { - ; p1 <- repP p; + ; p1 <- repLP p; ; (ss2,zs) <- repSts ss ; z <- repBindSt p1 e2 ; return (ss1++ss2, z : zs) }} @@ -601,8 +590,8 @@ repSts (LetStmt bs : ss) = ; z <- repLetSt ds ; (ss2,zs) <- addBinds ss1 (repSts ss) ; return (ss1++ss2, z : zs) } -repSts (ExprStmt e ty loc : ss) = - do { e2 <- repE e +repSts (ExprStmt e ty : ss) = + do { e2 <- repLE e ; z <- repNoBindSt e2 ; (ss2,zs) <- repSts ss ; return (ss2, z : zs) } @@ -613,84 +602,77 @@ repSts other = panic "Exotic Stmt in meta brackets" -- Bindings ----------------------------------------------------------- -repBinds :: HsBinds Name -> DsM ([GenSymBind], Core [TH.DecQ]) +repBinds :: [HsBindGroup Name] -> DsM ([GenSymBind], Core [TH.DecQ]) repBinds decs - = do { let { bndrs = collectHsBinders decs } + = do { let { bndrs = map unLoc (collectGroupBinders decs) } -- No need to worrry about detailed scopes within -- the binding group, because we are talking Names -- here, so we can safely treat it as a mutually -- recursive group ; ss <- mkGenSyms bndrs - ; core <- addBinds ss (rep_binds decs) + ; core <- addBinds ss (rep_bind_groups decs) ; core_list <- coreList decQTyConName core ; return (ss, core_list) } -rep_binds :: HsBinds Name -> DsM [Core TH.DecQ] +rep_bind_groups :: [HsBindGroup Name] -> DsM [Core TH.DecQ] -- Assumes: all the binders of the binding are alrady in the meta-env -rep_binds binds = do locs_cores <- rep_binds' binds - return $ de_loc $ sort_by_loc locs_cores +rep_bind_groups binds = do + locs_cores_s <- mapM rep_bind_group binds + return $ de_loc $ sort_by_loc (concat locs_cores_s) -rep_binds' :: HsBinds Name -> DsM [(SrcLoc, Core TH.DecQ)] +rep_bind_group :: HsBindGroup Name -> DsM [(SrcSpan, Core TH.DecQ)] -- Assumes: all the binders of the binding are alrady in the meta-env -rep_binds' EmptyBinds = return [] -rep_binds' (ThenBinds x y) - = do { core1 <- rep_binds' x - ; core2 <- rep_binds' y - ; return (core1 ++ core2) } -rep_binds' (MonoBind bs sigs _) - = do { core1 <- rep_monobind' bs +rep_bind_group (HsBindGroup bs sigs _) + = do { core1 <- mapM rep_bind (bagToList bs) ; core2 <- rep_sigs' sigs ; return (core1 ++ core2) } -rep_binds' (IPBinds _) +rep_bind_group (HsIPBinds _) = panic "DsMeta:repBinds: can't do implicit parameters" -rep_monobind :: MonoBinds Name -> DsM [Core TH.DecQ] +rep_binds :: LHsBinds Name -> DsM [Core TH.DecQ] -- Assumes: all the binders of the binding are alrady in the meta-env -rep_monobind binds = do locs_cores <- rep_monobind' binds - return $ de_loc $ sort_by_loc locs_cores +rep_binds binds = do + locs_cores <- mapM rep_bind (bagToList binds) + return $ de_loc $ sort_by_loc locs_cores -rep_monobind' :: MonoBinds Name -> DsM [(SrcLoc, Core TH.DecQ)] +rep_bind :: LHsBind Name -> DsM (SrcSpan, Core TH.DecQ) -- Assumes: all the binders of the binding are alrady in the meta-env -rep_monobind' EmptyMonoBinds = return [] -rep_monobind' (AndMonoBinds x y) = do { x1 <- rep_monobind' x; - y1 <- rep_monobind' y; - return (x1 ++ y1) } -- Note GHC treats declarations of a variable (not a pattern) -- e.g. x = g 5 as a Fun MonoBinds. This is indicated by a single match -- with an empty list of patterns -rep_monobind' (FunMonoBind fn infx [Match [] ty (GRHSs guards wheres ty2)] loc) +rep_bind (L loc (FunBind fn infx [L _ (Match [] ty (GRHSs guards wheres ty2))])) = do { (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) - ; fn' <- lookupBinder fn + ; fn' <- lookupLBinder fn ; p <- repPvar fn' ; ans <- repVal p guardcore wherecore - ; return [(loc, ans)] } + ; return (loc, ans) } -rep_monobind' (FunMonoBind fn infx ms loc) +rep_bind (L loc (FunBind fn infx ms)) = do { ms1 <- mapM repClauseTup ms - ; fn' <- lookupBinder fn + ; fn' <- lookupLBinder fn ; ans <- repFun fn' (nonEmptyCoreList ms1) - ; return [(loc, ans)] } + ; return (loc, ans) } -rep_monobind' (PatMonoBind pat (GRHSs guards wheres ty2) loc) - = do { patcore <- repP pat +rep_bind (L loc (PatBind pat (GRHSs guards wheres ty2))) + = do { patcore <- repLP pat ; (ss,wherecore) <- repBinds wheres ; guardcore <- addBinds ss (repGuards guards) ; ans <- repVal patcore guardcore wherecore - ; return [(loc, ans)] } + ; return (loc, ans) } -rep_monobind' (VarMonoBind v e) +rep_bind (L loc (VarBind v e)) = do { v' <- lookupBinder v - ; e2 <- repE e + ; e2 <- repLE e ; x <- repNormal e2 ; patcore <- repPvar v' ; empty_decls <- coreList decQTyConName [] ; ans <- repVal patcore x empty_decls - ; return [(getSrcLoc v, ans)] } + ; return (srcLocSpan (getSrcLoc v), ans) } ----------------------------------------------------------------------------- --- Since everything in a MonoBind is mutually recursive we need rename all +-- Since everything in a Bind is mutually recursive we need rename all -- all the variables simultaneously. For example: -- [| AndMonoBinds (f x = x + g 2) (g x = f 1 + 2) |] would translate to -- do { f'1 <- gensym "f" @@ -713,13 +695,12 @@ rep_monobind' (VarMonoBind v e) -- Haskell Template's Meta.Exp type so we punt if it isn't a simple thing like -- (\ p1 .. pn -> exp) by causing an error. -repLambda :: Match Name -> DsM (Core TH.ExpQ) -repLambda (Match ps _ (GRHSs [GRHS [ResultStmt e _ ] _ ] - EmptyBinds _)) +repLambda :: LMatch Name -> DsM (Core TH.ExpQ) +repLambda (L _ (Match ps _ (GRHSs [L _ (GRHS [L _ (ResultStmt e)])] [] _))) = do { let bndrs = collectPatsBinders ps ; ; ss <- mkGenSyms bndrs ; lam <- addBinds ss ( - do { xs <- repPs ps; body <- repE e; repLam xs body }) + do { xs <- repLPs ps; body <- repLE e; repLam xs body }) ; wrapGenSyns ss lam } repLambda z = panic "Can't represent a guarded lambda in Template Haskell" @@ -733,29 +714,32 @@ repLambda z = panic "Can't represent a guarded lambda in Template Haskell" -- variable should already appear in the environment. -- Process a list of patterns -repPs :: [Pat Name] -> DsM (Core [TH.Pat]) -repPs ps = do { ps' <- mapM repP ps ; - coreList patTyConName ps' } +repLPs :: [LPat Name] -> DsM (Core [TH.Pat]) +repLPs ps = do { ps' <- mapM repLP ps ; + coreList patTyConName ps' } + +repLP :: LPat Name -> DsM (Core TH.Pat) +repLP (L _ p) = repP p repP :: Pat Name -> DsM (Core TH.Pat) repP (WildPat _) = repPwild repP (LitPat l) = do { l2 <- repLiteral l; repPlit l2 } repP (VarPat x) = do { x' <- lookupBinder x; repPvar x' } -repP (LazyPat p) = do { p1 <- repP p; repPtilde p1 } -repP (AsPat x p) = do { x' <- lookupBinder x; p1 <- repP p; repPaspat x' p1 } -repP (ParPat p) = repP p -repP (ListPat ps _) = do { qs <- repPs ps; repPlist qs } -repP (TuplePat ps _) = do { qs <- repPs ps; repPtup qs } +repP (LazyPat p) = do { p1 <- repLP p; repPtilde p1 } +repP (AsPat x p) = do { x' <- lookupLBinder x; p1 <- repLP p; repPaspat x' p1 } +repP (ParPat p) = repLP p +repP (ListPat ps _) = do { qs <- repLPs ps; repPlist qs } +repP (TuplePat ps _) = do { qs <- repLPs ps; repPtup qs } repP (ConPatIn dc details) - = do { con_str <- lookupOcc dc + = do { con_str <- lookupLOcc dc ; case details of - PrefixCon ps -> do { qs <- repPs ps; repPcon con_str qs } - RecCon pairs -> do { vs <- sequence $ map lookupOcc (map fst pairs) - ; ps <- sequence $ map repP (map snd pairs) + PrefixCon ps -> do { qs <- repLPs ps; repPcon con_str qs } + RecCon pairs -> do { vs <- sequence $ map lookupLOcc (map fst pairs) + ; ps <- sequence $ map repLP (map snd pairs) ; fps <- zipWithM (\x y -> rep2 fieldPatName [unC x,unC y]) vs ps ; fps' <- coreList fieldPatTyConName fps ; repPrec con_str fps' } - InfixCon p1 p2 -> do { qs <- repPs [p1,p2]; repPcon con_str qs } + InfixCon p1 p2 -> do { qs <- repLPs [p1,p2]; repPcon con_str qs } } repP (NPatIn l (Just _)) = panic "Can't cope with negative overloaded patterns yet (repP (NPatIn _ (Just _)))" repP (NPatIn l Nothing) = do { a <- repOverloadedLiteral l; repPlit a } @@ -764,11 +748,11 @@ repP other = panic "Exotic pattern inside meta brackets" ---------------------------------------------------------- -- Declaration ordering helpers -sort_by_loc :: [(SrcLoc, a)] -> [(SrcLoc, a)] +sort_by_loc :: [(SrcSpan, a)] -> [(SrcSpan, a)] sort_by_loc xs = sortBy comp xs where comp x y = compare (fst x) (fst y) -de_loc :: [(SrcLoc, a)] -> [a] +de_loc :: [(a, b)] -> [b] de_loc = map snd ---------------------------------------------------------- @@ -804,6 +788,9 @@ addBinds bs m = dsExtendMetaEnv (mkNameEnv [(n,Bound id) | (n,id) <- bs]) m -- Look up a locally bound name -- +lookupLBinder :: Located Name -> DsM (Core TH.Name) +lookupLBinder (L _ n) = lookupBinder n + lookupBinder :: Name -> DsM (Core TH.Name) lookupBinder n = do { mb_val <- dsLookupMetaEnv n; @@ -816,9 +803,12 @@ lookupBinder n -- * If it is a global name, generate the "original name" representation (ie, -- the <module>:<name> form) for the associated entity -- -lookupOcc :: Name -> DsM (Core TH.Name) +lookupLOcc :: Located Name -> DsM (Core TH.Name) -- Lookup an occurrence; it can't be a splice. -- Use the in-scope bindings if they exist +lookupLOcc (L _ n) = lookupOcc n + +lookupOcc :: Name -> DsM (Core TH.Name) lookupOcc n = do { mb_val <- dsLookupMetaEnv n ; case mb_val of @@ -896,11 +886,6 @@ wrapNongenSyms binds (MkC body) occNameLit :: Name -> DsM (Core String) occNameLit n = coreStringLit (occNameUserString (nameOccName n)) -void = placeHolderType - -string :: String -> HsExpr Id -string s = HsLit (HsString (mkFastString s)) - -- %********************************************************************* -- %* * @@ -1083,14 +1068,14 @@ repProto (MkC s) (MkC ty) = rep2 sigDName [s, ty] repCtxt :: Core [TH.TypeQ] -> DsM (Core TH.CxtQ) repCtxt (MkC tys) = rep2 cxtName [tys] -repConstr :: Core TH.Name -> HsConDetails Name (BangType Name) +repConstr :: Core TH.Name -> HsConDetails Name (LBangType Name) -> DsM (Core TH.ConQ) repConstr con (PrefixCon ps) = do arg_tys <- mapM repBangTy ps arg_tys1 <- coreList strictTypeQTyConName arg_tys rep2 normalCName [unC con, unC arg_tys1] repConstr con (RecCon ips) - = do arg_vs <- mapM lookupOcc (map fst ips) + = do arg_vs <- mapM lookupLOcc (map fst ips) arg_tys <- mapM repBangTy (map snd ips) arg_vtys <- zipWithM (\x y -> rep2 varStrictTypeName [unC x, unC y]) arg_vs arg_tys @@ -1174,9 +1159,6 @@ repOverloadedLiteral (HsFractional f _) = do { lit <- mk_rational f; repLiteral --------------- Miscellaneous ------------------- -repLift :: Core e -> DsM (Core TH.ExpQ) -repLift (MkC x) = rep2 liftName [x] - repGensym :: Core String -> DsM (Core (TH.Q TH.Name)) repGensym (MkC lit_str) = rep2 newNameName [lit_str] @@ -1588,14 +1570,3 @@ tupleTIdKey = mkPreludeMiscIdUnique 294 arrowTIdKey = mkPreludeMiscIdUnique 295 listTIdKey = mkPreludeMiscIdUnique 296 appTIdKey = mkPreludeMiscIdUnique 293 - --- %************************************************************************ --- %* * --- Other utilities --- %* * --- %************************************************************************ - --- It is rather usatisfactory that we don't have a SrcLoc -addDsWarn :: SDoc -> DsM () -addDsWarn msg = dsWarn (noSrcLoc, msg) - diff --git a/ghc/compiler/deSugar/DsMonad.lhs b/ghc/compiler/deSugar/DsMonad.lhs index 531f72948c..fe0645ec48 100644 --- a/ghc/compiler/deSugar/DsMonad.lhs +++ b/ghc/compiler/deSugar/DsMonad.lhs @@ -11,7 +11,7 @@ module DsMonad ( newTyVarsDs, duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId, newFailLocalDs, - getSrcLocDs, putSrcLocDs, + getSrcSpanDs, putSrcSpanDs, getModuleDs, newUnique, UniqSupply, newUniqueSupply, @@ -27,8 +27,8 @@ module DsMonad ( #include "HsVersions.h" -import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr ) import TcRnMonad +import HsSyn ( HsExpr, HsMatchContext, Pat ) import IfaceEnv ( tcIfaceGlobal ) import HscTypes ( TyThing(..), TypeEnv, HscEnv, IsBootInterface, @@ -41,7 +41,7 @@ import Id ( mkSysLocal, setIdUnique, Id ) import Module ( Module, ModuleName, ModuleEnv ) import Var ( TyVar, setTyVarUnique ) import Outputable -import SrcLoc ( noSrcLoc, SrcLoc ) +import SrcLoc ( noSrcSpan, SrcSpan ) import Type ( Type ) import UniqSupply ( UniqSupply, uniqsFromSupply ) import Name ( Name, nameOccName ) @@ -69,7 +69,10 @@ foldlDs = foldlM mapAndUnzipDs = mapAndUnzipM -type DsWarning = (SrcLoc, SDoc) +type DsWarning = (SrcSpan, SDoc) + -- Not quite the same as a WarnMsg, we have an SDoc here + -- and we'll do the print_unqual stuff later on to turn it + -- into a Doc. data DsGblEnv = DsGblEnv { ds_mod :: Module, -- For SCC profiling @@ -80,7 +83,7 @@ data DsGblEnv = DsGblEnv { data DsLclEnv = DsLclEnv { ds_meta :: DsMetaEnv, -- Template Haskell bindings - ds_loc :: SrcLoc -- to put in pattern-matching error msgs + ds_loc :: SrcSpan -- to put in pattern-matching error msgs } -- Inside [| |] brackets, the desugarer looks @@ -92,8 +95,8 @@ data DsMetaVal -- Will be dynamically alpha renamed. -- The Id has type THSyntax.Var - | Splice TypecheckedHsExpr -- These bindings are introduced by - -- the PendingSplices on a HsBracketOut + | Splice (HsExpr Id) -- These bindings are introduced by + -- the PendingSplices on a HsBracketOut -- initDs returns the UniqSupply out the end (not just the result) @@ -111,7 +114,7 @@ initDs hsc_env mod type_env is_boot thing_inside ds_if_env = if_env, ds_warns = warn_var } ; lcl_env = DsLclEnv { ds_meta = emptyNameEnv, - ds_loc = noSrcLoc } } + ds_loc = noSrcSpan } } ; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside @@ -158,7 +161,7 @@ newTyVarsDs tyvar_tmpls \end{code} We can also reach out and either set/grab location information from -the @SrcLoc@ being carried around. +the @SrcSpan@ being carried around. \begin{code} getDOptsDs :: DsM DynFlags @@ -167,11 +170,11 @@ getDOptsDs = getDOpts getModuleDs :: DsM Module getModuleDs = do { env <- getGblEnv; return (ds_mod env) } -getSrcLocDs :: DsM SrcLoc -getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) } +getSrcSpanDs :: DsM SrcSpan +getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) } -putSrcLocDs :: SrcLoc -> DsM a -> DsM a -putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside +putSrcSpanDs :: SrcSpan -> DsM a -> DsM a +putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside dsWarn :: DsWarning -> DsM () dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) } @@ -221,7 +224,7 @@ dsExtendMetaEnv menv thing_inside \begin{code} data DsMatchContext - = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc + = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan | NoMatchContext deriving () \end{code} diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 2bc7c80eb4..79e757c943 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -30,16 +30,16 @@ module DsUtils ( dsReboundNames, lookupReboundName, - selectMatchVar + selectMatchVarL, selectMatchVar ) where #include "HsVersions.h" import {-# SOURCE #-} Match ( matchSimply ) -import {-# SOURCE #-} DsExpr( dsExpr ) +import {-# SOURCE #-} DsExpr( dsLExpr ) import HsSyn -import TcHsSyn ( TypecheckedPat, hsPatType ) +import TcHsSyn ( hsPatType ) import CoreSyn import Constants ( mAX_TUPLE_SIZE ) import DsMonad @@ -70,6 +70,7 @@ import PrelNames ( unpackCStringName, unpackCStringUtf8Name, lengthPName, indexPName ) import Outputable import UnicodeUtil ( intsToUtf8, stringToUtf8 ) +import SrcLoc ( Located(..), unLoc, noLoc ) import Util ( isSingleton, notNull, zipEqual ) import ListSetOps ( assocDefault ) import FastString @@ -94,10 +95,11 @@ dsReboundNames rebound_ids where -- The cheapo special case can happen when we -- make an intermediate HsDo when desugaring a RecStmt - mk_bind (std_name, HsVar id) = return ([], (std_name, id)) - mk_bind (std_name, expr) = dsExpr expr `thenDs` \ rhs -> - newSysLocalDs (exprType rhs) `thenDs` \ id -> - return ([NonRec id rhs], (std_name, id)) + mk_bind (std_name, L _ (HsVar id)) = return ([], (std_name, id)) + mk_bind (std_name, expr) + = dsLExpr expr `thenDs` \ rhs -> + newSysLocalDs (exprType rhs) `thenDs` \ id -> + return ([NonRec id rhs], (std_name, id)) lookupReboundName :: [(Name,Id)] -> Name -> CoreExpr lookupReboundName prs std_name @@ -114,23 +116,23 @@ lookupReboundName prs std_name %************************************************************************ \begin{code} -tidyLitPat :: HsLit -> TypecheckedPat -> TypecheckedPat +tidyLitPat :: HsLit -> LPat Id -> LPat Id tidyLitPat (HsChar c) pat = mkCharLitPat c -tidyLitPat lit pat = pat +tidyLitPat lit pat = pat -tidyNPat :: HsLit -> Type -> TypecheckedPat -> TypecheckedPat +tidyNPat :: HsLit -> Type -> LPat Id -> LPat Id tidyNPat (HsString s) _ pat | lengthFS s <= 1 -- Short string literals only = foldr (\c pat -> mkPrefixConPat consDataCon [mkCharLitPat c,pat] stringTy) - (mkNilPat stringTy) (unpackIntFS s) + (mkNilPat stringTy) (unpackFS s) -- The stringTy is the type of the whole pattern, not -- the type to instantiate (:) or [] with! where tidyNPat lit lit_ty default_pat - | isIntTy lit_ty = mkPrefixConPat intDataCon [LitPat (mk_int lit)] lit_ty - | isFloatTy lit_ty = mkPrefixConPat floatDataCon [LitPat (mk_float lit)] lit_ty - | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [LitPat (mk_double lit)] lit_ty + | isIntTy lit_ty = mkPrefixConPat intDataCon [noLoc $ LitPat (mk_int lit)] lit_ty + | isFloatTy lit_ty = mkPrefixConPat floatDataCon [noLoc $ LitPat (mk_float lit)] lit_ty + | isDoubleTy lit_ty = mkPrefixConPat doubleDataCon [noLoc $ LitPat (mk_double lit)] lit_ty | otherwise = default_pat where @@ -177,11 +179,14 @@ hand, which should indeed be bound to the pattern as a whole, then use it; otherwise, make one up. \begin{code} -selectMatchVar :: TypecheckedPat -> DsM Id +selectMatchVarL :: LPat Id -> DsM Id +selectMatchVarL pat = selectMatchVar (unLoc pat) + selectMatchVar (VarPat var) = returnDs var -selectMatchVar (AsPat var pat) = returnDs var -selectMatchVar (LazyPat pat) = selectMatchVar pat -selectMatchVar other_pat = newSysLocalDs (hsPatType other_pat) -- OK, better make up one... +selectMatchVar (AsPat var pat) = returnDs (unLoc var) +selectMatchVar (LazyPat pat) = selectMatchVarL pat +selectMatchVar other_pat = newSysLocalDs (hsPatType (noLoc other_pat)) + -- OK, better make up one... \end{code} @@ -209,7 +214,7 @@ data EquationInfo -- of the *first* thing matched in this group. -- Should perhaps be a list of them all! - [TypecheckedPat] -- The patterns for an eqn + [Pat Id] -- The patterns for an eqn MatchResult -- Encapsulates the guards and bindings \end{code} @@ -423,7 +428,7 @@ mkErrorAppDs :: Id -- The error function -> DsM CoreExpr mkErrorAppDs err_id ty msg - = getSrcLocDs `thenDs` \ src_loc -> + = getSrcSpanDs `thenDs` \ src_loc -> let full_msg = showSDoc (hcat [ppr src_loc, text "|", text msg]) core_msg = Lit (MachStr (mkFastString (stringToUtf8 full_msg))) @@ -439,7 +444,7 @@ mkErrorAppDs err_id ty msg %************************************************************************ \begin{code} -mkCharExpr :: Int -> CoreExpr -- Returns C# c :: Int +mkCharExpr :: Char -> CoreExpr -- Returns C# c :: Int mkIntExpr :: Integer -> CoreExpr -- Returns I# i :: Int mkIntegerExpr :: Integer -> DsM CoreExpr -- Result :: Integer mkStringLit :: String -> DsM CoreExpr -- Result :: String @@ -489,7 +494,7 @@ mkStringLitFS str | lengthFS str == 1 = let - the_char = mkCharExpr (headIntFS str) + the_char = mkCharExpr (headFS str) in returnDs (mkConsExpr charTy the_char (mkNilExpr charTy)) @@ -530,15 +535,15 @@ even more helpful. Something very similar happens for pattern-bound expressions. \begin{code} -mkSelectorBinds :: TypecheckedPat -- The pattern - -> CoreExpr -- Expression to which the pattern is bound +mkSelectorBinds :: LPat Id -- The pattern + -> CoreExpr -- Expression to which the pattern is bound -> DsM [(Id,CoreExpr)] -mkSelectorBinds (VarPat v) val_expr +mkSelectorBinds (L _ (VarPat v)) val_expr = returnDs [(v, val_expr)] mkSelectorBinds pat val_expr - | isSingleton binders || is_simple_pat pat + | isSingleton binders || is_simple_lpat pat = -- Given p = e, where p binds x,y -- we are going to make -- v = p (where v is fresh) @@ -595,15 +600,19 @@ mkSelectorBinds pat val_expr where error_expr = mkCoerce (idType bndr_var) (Var err_var) - is_simple_pat (TuplePat ps Boxed) = all is_triv_pat ps - is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_pat (hsConArgs ps) + is_simple_lpat p = is_simple_pat (unLoc p) + + is_simple_pat (TuplePat ps Boxed) = all is_triv_lpat ps + is_simple_pat (ConPatOut _ ps _ _ _) = all is_triv_lpat (hsConArgs ps) is_simple_pat (VarPat _) = True - is_simple_pat (ParPat p) = is_simple_pat p + is_simple_pat (ParPat p) = is_simple_lpat p is_simple_pat other = False + is_triv_lpat p = is_triv_pat (unLoc p) + is_triv_pat (VarPat v) = True is_triv_pat (WildPat _) = True - is_triv_pat (ParPat p) = is_triv_pat p + is_triv_pat (ParPat p) = is_triv_lpat p is_triv_pat other = False \end{code} diff --git a/ghc/compiler/deSugar/Match.hi-boot-5 b/ghc/compiler/deSugar/Match.hi-boot-5 index 2e4d223089..f8dc571284 100644 --- a/ghc/compiler/deSugar/Match.hi-boot-5 +++ b/ghc/compiler/deSugar/Match.hi-boot-5 @@ -2,5 +2,5 @@ __interface Match 1 0 where __export Match match matchExport matchSimply matchSinglePat; 1 match :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ; 1 matchExport :: [Var.Id] -> [DsUtils.EquationInfo] -> DsMonad.DsM DsUtils.MatchResult ; -1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> TcHsSyn.TypecheckedPat -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; -1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> TcHsSyn.TypecheckedPat -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ; +1 matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id -> HsPat.LPat Var.Id -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr ; +1 matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext -> HsPat.LPat Var.Id -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult ; diff --git a/ghc/compiler/deSugar/Match.hi-boot-6 b/ghc/compiler/deSugar/Match.hi-boot-6 index e7f5e1ae92..dcc479bed4 100644 --- a/ghc/compiler/deSugar/Match.hi-boot-6 +++ b/ghc/compiler/deSugar/Match.hi-boot-6 @@ -12,7 +12,7 @@ matchExport matchSimply :: CoreSyn.CoreExpr -> HsExpr.HsMatchContext Var.Id - -> TcHsSyn.TypecheckedPat + -> HsPat.LPat Var.Id -> CoreSyn.CoreExpr -> CoreSyn.CoreExpr -> DsMonad.DsM CoreSyn.CoreExpr @@ -20,6 +20,6 @@ matchSimply matchSinglePat :: CoreSyn.CoreExpr -> DsMonad.DsMatchContext - -> TcHsSyn.TypecheckedPat + -> HsPat.LPat Var.Id -> DsUtils.MatchResult -> DsMonad.DsM DsUtils.MatchResult diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index 88868e6b1c..295b780dd9 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -11,7 +11,7 @@ module Match ( match, matchExport, matchWrapper, matchSimply, matchSinglePat ) w import {-# SOURCE #-} DsExpr( dsExpr ) import CmdLineOpts ( DynFlag(..), dopt ) import HsSyn -import TcHsSyn ( TypecheckedPat, TypecheckedMatch, TypecheckedMatchContext, hsPatType ) +import TcHsSyn ( hsPatType ) import Check ( check, ExhaustivePat ) import CoreSyn import CoreUtils ( bindNonRec ) @@ -28,8 +28,9 @@ import TysWiredIn ( consDataCon, mkTupleTy, mkListTy, tupleCon, parrFakeCon, mkPArrTy ) import BasicTypes ( Boxity(..) ) import UniqSet -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcSpan, noLoc, unLoc, Located(..) ) import Util ( lengthExceeds, isSingleton, notNull ) +import Name ( Name ) import Outputable \end{code} @@ -110,7 +111,7 @@ dsIncompleteWarn ctx@(DsMatchContext kind _ _) pats = dsWarn warn | otherwise = empty pp_context NoMatchContext msg rest_of_msg_fun - = (noSrcLoc, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) + = (noSrcSpan, ptext SLIT("Some match(es)") <+> hang msg 8 (rest_of_msg_fun id)) pp_context (DsMatchContext kind pats loc) msg rest_of_msg_fun = (loc, vcat [ptext SLIT("Pattern match(es)") <+> msg, @@ -344,9 +345,9 @@ tidyEqnInfo v (EqnInfo n ctx (pat : pats) match_result) tidy1 :: Id -- The Id being scrutinised - -> TypecheckedPat -- The pattern against which it is to be matched + -> Pat Id -- The pattern against which it is to be matched -> MatchResult -- Current thing do do after matching - -> DsM (TypecheckedPat, -- Equivalent pattern + -> DsM (Pat Id, -- Equivalent pattern MatchResult) -- Augmented thing to do afterwards -- The augmentation usually takes the form -- of new bindings to be added to the front @@ -364,7 +365,7 @@ tidy1 :: Id -- The Id being scrutinised -- tidy1 v (ParPat pat) match_result - = tidy1 v pat match_result + = tidy1 v (unLoc pat) match_result -- case v of { x -> mr[] } -- = case v of { _ -> let x=v in mr[] } @@ -376,8 +377,8 @@ tidy1 v (VarPat var) match_result -- case v of { x@p -> mr[] } -- = case v of { p -> let x=v in mr[] } -tidy1 v (AsPat var pat) match_result - = tidy1 v pat match_result' +tidy1 v (AsPat (L _ var) pat) match_result + = tidy1 v (unLoc pat) match_result' where match_result' | v == var = match_result | otherwise = adjustMatchResult (bindNonRec var (Var v)) match_result @@ -409,7 +410,7 @@ tidy1 v (ConPatOut con ps pat_ty ex_tvs dicts) match_result tidy_ps = PrefixCon (tidy_con con pat_ty ex_tvs ps) tidy1 v (ListPat pats ty) match_result - = returnDs (list_ConPat, match_result) + = returnDs (unLoc list_ConPat, match_result) where list_ty = mkListTy ty list_ConPat = foldr (\ x y -> mkPrefixConPat consDataCon [x, y] list_ty) @@ -420,13 +421,13 @@ tidy1 v (ListPat pats ty) match_result -- arrays with the existing machinery for constructor pattern -- tidy1 v (PArrPat pats ty) match_result - = returnDs (parrConPat, match_result) + = returnDs (unLoc parrConPat, match_result) where arity = length pats parrConPat = mkPrefixConPat (parrFakeCon arity) pats (mkPArrTy ty) tidy1 v (TuplePat pats boxity) match_result - = returnDs (tuple_ConPat, match_result) + = returnDs (unLoc tuple_ConPat, match_result) where arity = length pats tuple_ConPat = mkPrefixConPat (tupleCon boxity arity) pats @@ -435,19 +436,19 @@ tidy1 v (TuplePat pats boxity) match_result tidy1 v (DictPat dicts methods) match_result = case num_of_d_and_ms of 0 -> tidy1 v (TuplePat [] Boxed) match_result - 1 -> tidy1 v (head dict_and_method_pats) match_result + 1 -> tidy1 v (unLoc (head dict_and_method_pats)) match_result _ -> tidy1 v (TuplePat dict_and_method_pats Boxed) match_result where num_of_d_and_ms = length dicts + length methods - dict_and_method_pats = map VarPat (dicts ++ methods) + dict_and_method_pats = map nlVarPat (dicts ++ methods) -- LitPats: we *might* be able to replace these w/ a simpler form tidy1 v pat@(LitPat lit) match_result - = returnDs (tidyLitPat lit pat, match_result) + = returnDs (unLoc (tidyLitPat lit (noLoc pat)), match_result) -- NPats: we *might* be able to replace these w/ a simpler form tidy1 v pat@(NPatOut lit lit_ty _) match_result - = returnDs (tidyNPat lit lit_ty pat, match_result) + = returnDs (unLoc (tidyNPat lit lit_ty (noLoc pat)), match_result) -- and everything else goes through unchanged... @@ -462,7 +463,7 @@ tidy_con data_con pat_ty ex_tvs (RecCon rpats) = -- Special case for C {}, which can be used for -- a constructor that isn't declared to have -- fields at all - map WildPat con_arg_tys' + map (noLoc.WildPat) con_arg_tys' | otherwise = map mk_pat tagged_arg_tys @@ -474,12 +475,13 @@ tidy_con data_con pat_ty ex_tvs (RecCon rpats) -- mk_pat picks a WildPat of the appropriate type for absent fields, -- and the specified pattern for present fields - mk_pat (arg_ty, lbl) = case [pat | (sel_id,pat) <- rpats, - recordSelectorFieldLabel sel_id == lbl - ] of - (pat:pats) -> ASSERT( null pats ) - pat - [] -> WildPat arg_ty + mk_pat (arg_ty, lbl) = + case [ pat | (sel_id,pat) <- rpats, + recordSelectorFieldLabel (unLoc sel_id) == lbl + ] of + (pat:pats) -> ASSERT( null pats ) + pat + [] -> noLoc (WildPat arg_ty) \end{code} \noindent @@ -626,9 +628,9 @@ Meanwhile, the strategy is: \begin{code} matchSigPat :: [Id] -> EquationInfo -> DsM MatchResult matchSigPat (var:vars) (EqnInfo n ctx (SigPatOut pat ty co_fn : pats) result) - = selectMatchVar pat `thenDs` \ new_var -> - dsExpr (HsApp co_fn (HsVar var)) `thenDs` \ rhs -> - match (new_var:vars) [EqnInfo n ctx (pat:pats) result] `thenDs` \ result' -> + = selectMatchVarL pat `thenDs` \ new_var -> + dsExpr (HsApp (noLoc co_fn) (nlHsVar var)) `thenDs` \ rhs -> + match (new_var:vars) [EqnInfo n ctx (unLoc pat:pats) result] `thenDs` \ result' -> returnDs (adjustMatchResult (bindNonRec new_var rhs) result') \end{code} @@ -677,8 +679,8 @@ Call @match@ with all of this information! \end{enumerate} \begin{code} -matchWrapper :: TypecheckedMatchContext -- For shadowing warning messages - -> [TypecheckedMatch] -- Matches being desugared +matchWrapper :: HsMatchContext Name -- For shadowing warning messages + -> [LMatch Id] -- Matches being desugared -> DsM ([Id], CoreExpr) -- Results \end{code} @@ -737,35 +739,35 @@ pattern. It returns an expression. \begin{code} matchSimply :: CoreExpr -- Scrutinee - -> TypecheckedMatchContext -- Match kind - -> TypecheckedPat -- Pattern it should match + -> HsMatchContext Name -- Match kind + -> LPat Id -- Pattern it should match -> CoreExpr -- Return this if it matches -> CoreExpr -- Return this if it doesn't -> DsM CoreExpr matchSimply scrut kind pat result_expr fail_expr - = getSrcLocDs `thenDs` \ locn -> + = getSrcSpanDs `thenDs` \ locn -> let - ctx = DsMatchContext kind [pat] locn + ctx = DsMatchContext kind [unLoc pat] locn match_result = cantFailMatchResult result_expr in matchSinglePat scrut ctx pat match_result `thenDs` \ match_result' -> extractMatchResult match_result' fail_expr -matchSinglePat :: CoreExpr -> DsMatchContext -> TypecheckedPat +matchSinglePat :: CoreExpr -> DsMatchContext -> LPat Id -> MatchResult -> DsM MatchResult matchSinglePat (Var var) ctx pat match_result = getDOptsDs `thenDs` \ dflags -> - match_fn dflags [var] [EqnInfo 1 ctx [pat] match_result] + match_fn dflags [var] [EqnInfo 1 ctx [unLoc pat] match_result] where match_fn dflags | dopt Opt_WarnSimplePatterns dflags = matchExport | otherwise = match matchSinglePat scrut ctx pat match_result - = selectMatchVar pat `thenDs` \ var -> + = selectMatchVarL pat `thenDs` \ var -> matchSinglePat (Var var) ctx pat match_result `thenDs` \ match_result' -> returnDs (adjustMatchResult (bindNonRec var scrut) match_result') \end{code} @@ -781,8 +783,8 @@ matchSinglePat scrut ctx pat match_result This is actually local to @matchWrapper@. \begin{code} -flattenMatches :: TypecheckedMatchContext - -> [TypecheckedMatch] +flattenMatches :: HsMatchContext Name + -> [LMatch Id] -> DsM (Type, [EquationInfo]) flattenMatches kind matches @@ -793,8 +795,9 @@ flattenMatches kind matches ASSERT( all (tcEqType result_ty) result_tys ) returnDs (result_ty, eqn_infos) where - flatten_match (Match pats _ grhss, n) - = dsGRHSs kind pats grhss `thenDs` \ (ty, match_result) -> - getSrcLocDs `thenDs` \ locn -> - returnDs (ty, EqnInfo n (DsMatchContext kind pats locn) pats match_result) + flatten_match (L _ (Match pats _ grhss), n) + = dsGRHSs kind upats grhss `thenDs` \ (ty, match_result) -> + getSrcSpanDs `thenDs` \ locn -> + returnDs (ty, EqnInfo n (DsMatchContext kind upats locn) upats match_result) + where upats = map unLoc pats \end{code} diff --git a/ghc/compiler/deSugar/MatchCon.lhs b/ghc/compiler/deSugar/MatchCon.lhs index a874218982..ed9f894834 100644 --- a/ghc/compiler/deSugar/MatchCon.lhs +++ b/ghc/compiler/deSugar/MatchCon.lhs @@ -20,6 +20,7 @@ import Subst ( mkSubst, mkInScopeSet, bindSubst, substExpr ) import CoreFVs ( exprFreeVars ) import VarEnv ( emptySubstEnv ) import ListSetOps ( equivClassesByUniq ) +import SrcLoc ( unLoc ) import Unique ( Uniquable(..) ) \end{code} @@ -99,7 +100,7 @@ Wadler's chapter in SLPJ. match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_tvs ex_dicts : _) _) : other_eqns) = -- Make new vars for the con arguments; avoid new locals where possible - mappM selectMatchVar arg_pats `thenDs` \ arg_vars -> + mappM selectMatchVarL arg_pats `thenDs` \ arg_vars -> -- Now do the business to make the alt for _this_ ConPat ... match (arg_vars ++ vars) @@ -118,7 +119,7 @@ match_con vars (eqn1@(EqnInfo _ _ (ConPatOut data_con (PrefixCon arg_pats) _ ex_ where shift_con_pat :: EquationInfo -> EquationInfo shift_con_pat (EqnInfo n ctx (ConPatOut _ (PrefixCon arg_pats) _ _ _ : pats) match_result) - = EqnInfo n ctx (arg_pats ++ pats) match_result + = EqnInfo n ctx (map unLoc arg_pats ++ pats) match_result other_pats = [p | EqnInfo _ _ (p:_) _ <- other_eqns] diff --git a/ghc/compiler/deSugar/MatchLit.lhs b/ghc/compiler/deSugar/MatchLit.lhs index e260e0cd58..d3f04f46af 100644 --- a/ghc/compiler/deSugar/MatchLit.lhs +++ b/ghc/compiler/deSugar/MatchLit.lhs @@ -14,8 +14,7 @@ import {-# SOURCE #-} DsExpr ( dsExpr ) import DsMonad import DsUtils -import HsSyn ( HsLit(..), Pat(..), HsExpr(..) ) -import TcHsSyn ( TypecheckedPat ) +import HsSyn import Id ( Id ) import CoreSyn import TyCon ( tyConDataCons ) @@ -24,6 +23,7 @@ import PrelNames ( ratioTyConKey ) import Unique ( hasKey ) import Literal ( mkMachInt, Literal(..) ) import Maybes ( catMaybes ) +import SrcLoc ( noLoc, Located(..), unLoc ) import Panic ( panic, assertPanic ) import Ratio ( numerator, denominator ) import Outputable @@ -135,7 +135,7 @@ matchLiterals all_vars@(var:vars) (shifted_eqns_for_this_lit, eqns_not_for_this_lit) = partitionEqnsByLit pat eqns_info in - dsExpr (HsApp eq_chk (HsVar var)) `thenDs` \ pred_expr -> + dsExpr (HsApp (noLoc eq_chk) (nlHsVar var)) `thenDs` \ pred_expr -> match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result -> let match_result1 = mkGuardedMatchResult pred_expr inner_match_result @@ -167,12 +167,12 @@ matchLiterals all_vars@(var:vars) eqns_info@(EqnInfo n ctx (pat@(NPlusKPatOut ma in match vars shifted_eqns_for_this_lit `thenDs` \ inner_match_result -> - dsExpr (HsApp ge (HsVar var)) `thenDs` \ ge_expr -> - dsExpr (HsApp sub (HsVar var)) `thenDs` \ nminusk_expr -> + dsExpr (HsApp (noLoc ge) (nlHsVar var)) `thenDs` \ ge_expr -> + dsExpr (HsApp (noLoc sub) (nlHsVar var)) `thenDs` \ nminusk_expr -> let match_result1 = mkGuardedMatchResult ge_expr $ - mkCoLetsMatchResult [NonRec master_n nminusk_expr] $ + mkCoLetsMatchResult [NonRec (unLoc master_n) nminusk_expr] $ inner_match_result in if (null eqns_not_for_this_lit) @@ -188,7 +188,7 @@ that are ``same''/different as one we are looking at. We need to know whether we're looking at a @LitPat@/@NPat@, and what literal we're after. \begin{code} -partitionEqnsByLit :: TypecheckedPat +partitionEqnsByLit :: Pat Id -> [EquationInfo] -> ([EquationInfo], -- These ones are for this lit, AND -- they've been "shifted" by stripping @@ -201,7 +201,7 @@ partitionEqnsByLit master_pat eqns = ( \ (xs,ys) -> (catMaybes xs, catMaybes ys)) (unzip (map (partition_eqn master_pat) eqns)) where - partition_eqn :: TypecheckedPat -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) + partition_eqn :: Pat Id -> EquationInfo -> (Maybe EquationInfo, Maybe EquationInfo) partition_eqn (LitPat k1) (EqnInfo n ctx (LitPat k2 : remaining_pats) match_result) | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) @@ -211,8 +211,8 @@ partitionEqnsByLit master_pat eqns | k1 == k2 = (Just (EqnInfo n ctx remaining_pats match_result), Nothing) -- NB the pattern is stripped off the EquationInfo - partition_eqn (NPlusKPatOut master_n k1 _ _) - (EqnInfo n ctx (NPlusKPatOut n' k2 _ _ : remaining_pats) match_result) + partition_eqn (NPlusKPatOut (L _ master_n) k1 _ _) + (EqnInfo n ctx (NPlusKPatOut (L _ n') k2 _ _ : remaining_pats) match_result) | k1 == k2 = (Just (EqnInfo n ctx remaining_pats new_match_result), Nothing) -- NB the pattern is stripped off the EquationInfo where diff --git a/ghc/compiler/ghci/ByteCodeAsm.lhs b/ghc/compiler/ghci/ByteCodeAsm.lhs index 928d5e3fdd..53340e78cd 100644 --- a/ghc/compiler/ghci/ByteCodeAsm.lhs +++ b/ghc/compiler/ghci/ByteCodeAsm.lhs @@ -43,6 +43,7 @@ import Data.Array.Base ( UArray(..) ) import Data.Array.ST ( castSTUArray ) import Foreign ( Word16, free ) import Data.Int ( Int64 ) +import Data.Char ( ord ) import GHC.Base ( ByteArray# ) import GHC.IOBase ( IO(..) ) @@ -349,7 +350,7 @@ mkBits findLabel st proto_insns literal st (MachInt j) = int st (fromIntegral j) literal st (MachFloat r) = float st (fromRational r) literal st (MachDouble r) = double st (fromRational r) - literal st (MachChar c) = int st c + literal st (MachChar c) = int st (ord c) literal st (MachInt64 ii) = int64 st (fromIntegral ii) literal st (MachWord64 ii) = int64 st (fromIntegral ii) literal st other = pprPanic "ByteCodeLink.literal" (ppr other) diff --git a/ghc/compiler/ghci/ByteCodeGen.lhs b/ghc/compiler/ghci/ByteCodeGen.lhs index 1b8657aaed..d7a477bfdc 100644 --- a/ghc/compiler/ghci/ByteCodeGen.lhs +++ b/ghc/compiler/ghci/ByteCodeGen.lhs @@ -61,7 +61,7 @@ import Control.Exception ( throwDyn ) import GHC.Exts ( Int(..), ByteArray# ) import Control.Monad ( when ) -import Data.Char ( ord ) +import Data.Char ( ord, chr ) -- ----------------------------------------------------------------------------- -- Generating byte code for a complete module @@ -714,7 +714,7 @@ doCase d s p (_,scrut) = case l of MachInt i -> DiscrI (fromInteger i) MachFloat r -> DiscrF (fromRational r) MachDouble r -> DiscrD (fromRational r) - MachChar i -> DiscrI i + MachChar i -> DiscrI (ord i) _ -> pprPanic "schemeE(AnnCase).my_discr" (ppr l) maybe_ncons @@ -950,7 +950,7 @@ generateCCall d0 s p ccall_spec@(CCallSpec target cconv safety) fn args_r_to_l mkDummyLiteral :: PrimRep -> Literal mkDummyLiteral pr = case pr of - CharRep -> MachChar 0 + CharRep -> MachChar (chr 0) IntRep -> MachInt 0 WordRep -> MachWord 0 DoubleRep -> MachDouble 0 diff --git a/ghc/compiler/ghci/InteractiveUI.hs b/ghc/compiler/ghci/InteractiveUI.hs index 49a5b1cbac..a1ec76433b 100644 --- a/ghc/compiler/ghci/InteractiveUI.hs +++ b/ghc/compiler/ghci/InteractiveUI.hs @@ -1,6 +1,6 @@ {-# OPTIONS -#include "Linker.h" #-} ----------------------------------------------------------------------------- --- $Id: InteractiveUI.hs,v 1.161 2003/10/09 11:58:53 simonpj Exp $ +-- $Id: InteractiveUI.hs,v 1.162 2003/12/10 14:15:21 simonmar Exp $ -- -- GHC Interactive User Interface -- @@ -18,20 +18,12 @@ module InteractiveUI ( import CompManager import HscTypes ( TyThing(..), HomeModInfo(hm_linkable), HomePackageTable, isObjectLinkable, GhciMode(..) ) -import HsSyn ( TyClDecl(..), ConDecl(..), Sig(..) ) import IfaceSyn ( IfaceDecl( ifName ) ) import DriverFlags import DriverState import DriverUtil ( remove_spaces ) import Linker ( showLinkerState, linkPackages ) import Util -import IdInfo ( GlobalIdDetails(..) ) -import Id ( isImplicitId, idName, globalIdDetails ) -import Class ( className ) -import TyCon ( tyConName, tyConClass_maybe, isPrimTyCon, DataConDetails(..) ) -import DataCon ( dataConName ) -import FieldLabel ( fieldLabelTyCon ) -import SrcLoc ( isGoodSrcLoc ) import Module ( showModMsg, lookupModuleEnv ) import Name ( Name, isHomePackageName, nameSrcLoc, nameOccName, NamedThing(..) ) diff --git a/ghc/compiler/hsSyn/Convert.lhs b/ghc/compiler/hsSyn/Convert.lhs index 110cda9080..b26b168a83 100644 --- a/ghc/compiler/hsSyn/Convert.lhs +++ b/ghc/compiler/hsSyn/Convert.lhs @@ -14,23 +14,13 @@ import Language.Haskell.TH.THSyntax as TH import Language.Haskell.TH.THLib as TH -- Pretty printing import HsSyn as Hs - ( HsExpr(..), HsLit(..), ArithSeqInfo(..), - HsStmtContext(..), TyClDecl(..), HsBang(..), - Match(..), GRHSs(..), GRHS(..), HsPred(..), - HsDecl(..), TyClDecl(..), InstDecl(..), ConDecl(..), - Stmt(..), HsBinds(..), MonoBinds(..), Sig(..), - Pat(..), HsConDetails(..), HsOverLit, BangType(..), - placeHolderType, HsType(..), HsExplicitForAll(..), - HsTyVarBndr(..), HsContext, - mkSimpleMatch, mkImplicitHsForAllTy, mkExplicitHsForAllTy - ) - import RdrName ( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, nameRdrName, getRdrName ) import Module ( ModuleName, mkModuleName ) import RdrHsSyn ( mkHsIntegral, mkHsFractional, mkClassDecl, mkTyData ) import Name ( mkInternalName ) import qualified OccName -import SrcLoc ( SrcLoc, generatedSrcLoc ) +import SrcLoc ( SrcLoc, generatedSrcLoc, noLoc, unLoc, Located(..), + noSrcSpan, SrcSpan, srcLocSpan, noSrcLoc ) import Type ( Type ) import TysWiredIn ( unitTyCon, tupleTyCon, trueDataCon, falseDataCon ) import BasicTypes( Boxity(..), RecFlag(Recursive), NewOrData(..) ) @@ -41,78 +31,83 @@ import HsDecls ( CImportSpec(..), ForeignImport(..), ForeignExport(..), import FastString( FastString, mkFastString, nilFS ) import Char ( ord, isAscii, isAlphaNum, isAlpha ) import List ( partition ) -import SrcLoc ( noSrcLoc ) import Unique ( Unique, mkUniqueGrimily ) import ErrUtils (Message) import GLAEXTS ( Int#, Int(..) ) +import Bag ( emptyBag, consBag ) import Outputable ------------------------------------------------------------------- -convertToHsDecls :: [TH.Dec] -> [Either (HsDecl RdrName) Message] -convertToHsDecls ds = map cvt_top ds +convertToHsDecls :: [TH.Dec] -> [Either (LHsDecl RdrName) Message] +convertToHsDecls ds = map cvt_ltop ds -mk_con con = case con of +mk_con con = L loc0 $ case con of NormalC c strtys - -> ConDecl (cName c) noExistentials noContext - (PrefixCon (map mk_arg strtys)) loc0 + -> ConDecl (noLoc (cName c)) noExistentials noContext + (PrefixCon (map mk_arg strtys)) RecC c varstrtys - -> ConDecl (cName c) noExistentials noContext - (RecCon (map mk_id_arg varstrtys)) loc0 + -> ConDecl (noLoc (cName c)) noExistentials noContext + (RecCon (map mk_id_arg varstrtys)) InfixC st1 c st2 - -> ConDecl (cName c) noExistentials noContext - (InfixCon (mk_arg st1) (mk_arg st2)) loc0 + -> ConDecl (noLoc (cName c)) noExistentials noContext + (InfixCon (mk_arg st1) (mk_arg st2)) where - mk_arg (IsStrict, ty) = BangType HsStrict (cvtType ty) - mk_arg (NotStrict, ty) = BangType HsNoBang (cvtType ty) + mk_arg (IsStrict, ty) = noLoc $ BangType HsStrict (cvtType ty) + mk_arg (NotStrict, ty) = noLoc $ BangType HsNoBang (cvtType ty) mk_id_arg (i, IsStrict, ty) - = (vName i, BangType HsStrict (cvtType ty)) + = (noLoc (vName i), noLoc $ BangType HsStrict (cvtType ty)) mk_id_arg (i, NotStrict, ty) - = (vName i, BangType HsNoBang (cvtType ty)) + = (noLoc (vName i), noLoc $ BangType HsNoBang (cvtType ty)) mk_derivs [] = Nothing -mk_derivs cs = Just [HsClassP (tconName c) [] | c <- cs] +mk_derivs cs = Just (noLoc [noLoc $ HsClassP (tconName c) [] | c <- cs]) + +cvt_ltop :: TH.Dec -> Either (LHsDecl RdrName) Message +cvt_ltop d = case cvt_top d of + Left d -> Left (L loc0 d) + Right m -> Right m cvt_top :: TH.Dec -> Either (HsDecl RdrName) Message -cvt_top d@(TH.ValD _ _ _) = Left $ Hs.ValD (cvtd d) -cvt_top d@(TH.FunD _ _) = Left $ Hs.ValD (cvtd d) +cvt_top d@(TH.ValD _ _ _) = Left $ Hs.ValD (unLoc (cvtd d)) +cvt_top d@(TH.FunD _ _) = Left $ Hs.ValD (unLoc (cvtd d)) cvt_top (TySynD tc tvs rhs) - = Left $ TyClD (TySynonym (tconName tc) (cvt_tvs tvs) (cvtType rhs) loc0) + = Left $ TyClD (TySynonym (noLoc (tconName tc)) (cvt_tvs tvs) (cvtType rhs)) cvt_top (DataD ctxt tc tvs constrs derivs) = Left $ TyClD (mkTyData DataType - (cvt_context ctxt, tconName tc, cvt_tvs tvs) + (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs) (map mk_con constrs) - (mk_derivs derivs) loc0) + (mk_derivs derivs)) cvt_top (NewtypeD ctxt tc tvs constr derivs) = Left $ TyClD (mkTyData NewType - (cvt_context ctxt, tconName tc, cvt_tvs tvs) + (cvt_context ctxt, noLoc (tconName tc), cvt_tvs tvs) [mk_con constr] - (mk_derivs derivs) loc0) + (mk_derivs derivs)) cvt_top (ClassD ctxt cl tvs decs) - = Left $ TyClD (mkClassDecl (cvt_context ctxt, tconName cl, cvt_tvs tvs) + = Left $ TyClD (mkClassDecl (cvt_context ctxt, noLoc (tconName cl), cvt_tvs tvs) noFunDeps sigs - binds loc0) + binds) where (binds,sigs) = cvtBindsAndSigs decs cvt_top (InstanceD tys ty decs) - = Left $ InstD (InstDecl inst_ty binds sigs loc0) + = Left $ InstD (InstDecl (noLoc inst_ty) binds sigs) where (binds, sigs) = cvtBindsAndSigs decs - inst_ty = mkImplicitHsForAllTy (cvt_context tys) (HsPredTy (cvt_pred ty)) + inst_ty = mkImplicitHsForAllTy (cvt_context tys) (noLoc (HsPredTy (cvt_pred ty))) -cvt_top (TH.SigD nm typ) = Left $ Hs.SigD (Sig (vName nm) (cvtType typ) loc0) +cvt_top (TH.SigD nm typ) = Left $ Hs.SigD (Sig (noLoc (vName nm)) (cvtType typ)) cvt_top (ForeignD (ImportF callconv safety from nm typ)) = case parsed of Just (c_header, cis) -> let i = CImport callconv' safety' c_header nilFS cis - in Left $ ForD (ForeignImport (vName nm) (cvtType typ) i False loc0) + in Left $ ForD (ForeignImport (noLoc (vName nm)) (cvtType typ) i False) Nothing -> Right $ text (show from) <+> ptext SLIT("is not a valid ccall impent") where callconv' = case callconv of @@ -126,7 +121,7 @@ cvt_top (ForeignD (ImportF callconv safety from nm typ)) cvt_top (ForeignD (ExportF callconv as nm typ)) = let e = CExport (CExportStatic (mkFastString as) callconv') - in Left $ ForD (ForeignExport (vName nm) (cvtType typ) e False loc0) + in Left $ ForD (ForeignExport (noLoc (vName nm)) (cvtType typ) e False) where callconv' = case callconv of CCall -> CCallConv StdCall -> StdCallConv @@ -171,13 +166,15 @@ lex_ccall_impent xs = case span is_valid xs of where is_valid :: Char -> Bool is_valid c = isAscii c && (isAlphaNum c || c `elem` "._") -noContext = [] +noContext = noLoc [] noExistentials = [] noFunDeps = [] ------------------------------------------------------------------- -convertToHsExpr :: TH.Exp -> HsExpr RdrName -convertToHsExpr = cvt +convertToHsExpr :: TH.Exp -> LHsExpr RdrName +convertToHsExpr = cvtl + +cvtl e = noLoc (cvt e) cvt (VarE s) = HsVar (vName s) cvt (ConE s) = HsVar (cName s) @@ -185,29 +182,29 @@ cvt (LitE l) | overloadedLit l = HsOverLit (cvtOverLit l) | otherwise = HsLit (cvtLit l) -cvt (AppE x y) = HsApp (cvt x) (cvt y) -cvt (LamE ps e) = HsLam (mkSimpleMatch (map cvtp ps) (cvt e) void loc0) +cvt (AppE x y) = HsApp (cvtl x) (cvtl y) +cvt (LamE ps e) = HsLam (mkSimpleMatch (map cvtlp ps) (cvtl e) void) cvt (TupE [e]) = cvt e -cvt (TupE es) = ExplicitTuple(map cvt es) Boxed -cvt (CondE x y z) = HsIf (cvt x) (cvt y) (cvt z) loc0 -cvt (LetE ds e) = HsLet (cvtdecs ds) (cvt e) -cvt (CaseE e ms) = HsCase (cvt e) (map cvtm ms) loc0 -cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void loc0 -cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void loc0 +cvt (TupE es) = ExplicitTuple(map cvtl es) Boxed +cvt (CondE x y z) = HsIf (cvtl x) (cvtl y) (cvtl z) +cvt (LetE ds e) = HsLet (cvtdecs ds) (cvtl e) +cvt (CaseE e ms) = HsCase (cvtl e) (map cvtm ms) +cvt (DoE ss) = HsDo DoExpr (cvtstmts ss) [] void +cvt (CompE ss) = HsDo ListComp (cvtstmts ss) [] void cvt (ArithSeqE dd) = ArithSeqIn (cvtdd dd) -cvt (ListE xs) = ExplicitList void (map cvt xs) +cvt (ListE xs) = ExplicitList void (map cvtl xs) cvt (InfixE (Just x) s (Just y)) - = HsPar (OpApp (cvt x) (cvt s) undefined (cvt y)) -cvt (InfixE Nothing s (Just y)) = SectionR (cvt s) (cvt y) -cvt (InfixE (Just x) s Nothing ) = SectionL (cvt x) (cvt s) + = HsPar (noLoc $ OpApp (cvtl x) (cvtl s) undefined (cvtl y)) +cvt (InfixE Nothing s (Just y)) = SectionR (cvtl s) (cvtl y) +cvt (InfixE (Just x) s Nothing ) = SectionL (cvtl x) (cvtl s) cvt (InfixE Nothing s Nothing ) = cvt s -- Can I indicate this is an infix thing? -cvt (SigE e t) = ExprWithTySig (cvt e) (cvtType t) -cvt (RecConE c flds) = RecordCon (cName c) (map (\(x,y) -> (vName x, cvt y)) flds) -cvt (RecUpdE e flds) = RecordUpd (cvt e) (map (\(x,y) -> (vName x, cvt y)) flds) +cvt (SigE e t) = ExprWithTySig (cvtl e) (cvtType t) +cvt (RecConE c flds) = RecordCon (noLoc (cName c)) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds) +cvt (RecUpdE e flds) = RecordUpd (cvtl e) (map (\(x,y) -> (noLoc (vName x), cvtl y)) flds) -cvtdecs :: [TH.Dec] -> HsBinds RdrName -cvtdecs [] = EmptyBinds -cvtdecs ds = MonoBind binds sigs Recursive +cvtdecs :: [TH.Dec] -> [HsBindGroup RdrName] +cvtdecs [] = [] +cvtdecs ds = [HsBindGroup binds sigs Recursive] where (binds, sigs) = cvtBindsAndSigs ds @@ -216,58 +213,58 @@ cvtBindsAndSigs ds where (sigs, non_sigs) = partition sigP ds -cvtSig (TH.SigD nm typ) = Hs.Sig (vName nm) (cvtType typ) loc0 +cvtSig (TH.SigD nm typ) = noLoc (Hs.Sig (noLoc (vName nm)) (cvtType typ)) -cvtds :: [TH.Dec] -> MonoBinds RdrName -cvtds [] = EmptyMonoBinds -cvtds (d:ds) = AndMonoBinds (cvtd d) (cvtds ds) +cvtds :: [TH.Dec] -> LHsBinds RdrName +cvtds [] = emptyBag +cvtds (d:ds) = cvtd d `consBag` cvtds ds -cvtd :: TH.Dec -> MonoBinds RdrName +cvtd :: TH.Dec -> LHsBind RdrName -- Used only for declarations in a 'let/where' clause, -- not for top level decls -cvtd (TH.ValD (TH.VarP s) body ds) = FunMonoBind (vName s) False - [cvtclause (Clause [] body ds)] loc0 -cvtd (FunD nm cls) = FunMonoBind (vName nm) False (map cvtclause cls) loc0 -cvtd (TH.ValD p body ds) = PatMonoBind (cvtp p) (GRHSs (cvtguard body) - (cvtdecs ds) - void) loc0 +cvtd (TH.ValD (TH.VarP s) body ds) + = noLoc $ FunBind (noLoc (vName s)) False [cvtclause (Clause [] body ds)] +cvtd (FunD nm cls) + = noLoc $ FunBind (noLoc (vName nm)) False (map cvtclause cls) +cvtd (TH.ValD p body ds) + = noLoc $ PatBind (cvtlp p) (GRHSs (cvtguard body) (cvtdecs ds) void) cvtd d = cvtPanic "Illegal kind of declaration in where clause" (text (show (TH.pprDec d))) -cvtclause :: TH.Clause -> Hs.Match RdrName +cvtclause :: TH.Clause -> Hs.LMatch RdrName cvtclause (Clause ps body wheres) - = Hs.Match (map cvtp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void) + = noLoc $ Hs.Match (map cvtlp ps) Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void) cvtdd :: Range -> ArithSeqInfo RdrName -cvtdd (FromR x) = (From (cvt x)) -cvtdd (FromThenR x y) = (FromThen (cvt x) (cvt y)) -cvtdd (FromToR x y) = (FromTo (cvt x) (cvt y)) -cvtdd (FromThenToR x y z) = (FromThenTo (cvt x) (cvt y) (cvt z)) +cvtdd (FromR x) = (From (cvtl x)) +cvtdd (FromThenR x y) = (FromThen (cvtl x) (cvtl y)) +cvtdd (FromToR x y) = (FromTo (cvtl x) (cvtl y)) +cvtdd (FromThenToR x y z) = (FromThenTo (cvtl x) (cvtl y) (cvtl z)) -cvtstmts :: [TH.Stmt] -> [Hs.Stmt RdrName] +cvtstmts :: [TH.Stmt] -> [Hs.LStmt RdrName] cvtstmts [] = [] -- this is probably an error as every [stmt] should end with ResultStmt -cvtstmts [NoBindS e] = [ResultStmt (cvt e) loc0] -- when its the last element use ResultStmt -cvtstmts (NoBindS e : ss) = ExprStmt (cvt e) void loc0 : cvtstmts ss -cvtstmts (TH.BindS p e : ss) = BindStmt (cvtp p) (cvt e) loc0 : cvtstmts ss -cvtstmts (TH.LetS ds : ss) = LetStmt (cvtdecs ds) : cvtstmts ss -cvtstmts (TH.ParS dss : ss) = ParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss +cvtstmts [NoBindS e] = [nlResultStmt (cvtl e)] -- when its the last element use ResultStmt +cvtstmts (NoBindS e : ss) = nlExprStmt (cvtl e) : cvtstmts ss +cvtstmts (TH.BindS p e : ss) = nlBindStmt (cvtlp p) (cvtl e) : cvtstmts ss +cvtstmts (TH.LetS ds : ss) = nlLetStmt (cvtdecs ds) : cvtstmts ss +cvtstmts (TH.ParS dss : ss) = nlParStmt [(cvtstmts ds, undefined) | ds <- dss] : cvtstmts ss -cvtm :: TH.Match -> Hs.Match RdrName +cvtm :: TH.Match -> Hs.LMatch RdrName cvtm (TH.Match p body wheres) - = Hs.Match [cvtp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void) - -cvtguard :: TH.Body -> [GRHS RdrName] + = noLoc (Hs.Match [cvtlp p] Nothing (GRHSs (cvtguard body) (cvtdecs wheres) void)) + +cvtguard :: TH.Body -> [LGRHS RdrName] cvtguard (GuardedB pairs) = map cvtpair pairs -cvtguard (NormalB e) = [GRHS [ ResultStmt (cvt e) loc0 ] loc0] +cvtguard (NormalB e) = [noLoc (GRHS [ nlResultStmt (cvtl e) ])] -cvtpair :: (TH.Exp,TH.Exp) -> GRHS RdrName -cvtpair (x,y) = GRHS [Hs.BindStmt truePat (cvt x) loc0, - ResultStmt (cvt y) loc0] loc0 +cvtpair :: (TH.Exp,TH.Exp) -> LGRHS RdrName +cvtpair (x,y) = noLoc (GRHS [nlBindStmt truePat (cvtl x), + nlResultStmt (cvtl y)]) cvtOverLit :: Lit -> HsOverLit cvtOverLit (IntegerL i) = mkHsIntegral i @@ -279,9 +276,12 @@ cvtLit :: Lit -> HsLit cvtLit (IntPrimL i) = HsIntPrim i cvtLit (FloatPrimL f) = HsFloatPrim f cvtLit (DoublePrimL f) = HsDoublePrim f -cvtLit (CharL c) = HsChar (ord c) +cvtLit (CharL c) = HsChar c cvtLit (StringL s) = HsString (mkFastString s) +cvtlp :: TH.Pat -> Hs.LPat RdrName +cvtlp pat = noLoc (cvtp pat) + cvtp :: TH.Pat -> Hs.Pat RdrName cvtp (TH.LitP l) | overloadedLit l = NPatIn (cvtOverLit l) Nothing -- Not right for negative @@ -290,45 +290,45 @@ cvtp (TH.LitP l) | otherwise = Hs.LitPat (cvtLit l) cvtp (TH.VarP s) = Hs.VarPat(vName s) cvtp (TupP [p]) = cvtp p -cvtp (TupP ps) = TuplePat (map cvtp ps) Boxed -cvtp (ConP s ps) = ConPatIn (cName s) (PrefixCon (map cvtp ps)) -cvtp (TildeP p) = LazyPat (cvtp p) -cvtp (TH.AsP s p) = AsPat (vName s) (cvtp p) +cvtp (TupP ps) = TuplePat (map cvtlp ps) Boxed +cvtp (ConP s ps) = ConPatIn (noLoc (cName s)) (PrefixCon (map cvtlp ps)) +cvtp (TildeP p) = LazyPat (cvtlp p) +cvtp (TH.AsP s p) = AsPat (noLoc (vName s)) (cvtlp p) cvtp TH.WildP = WildPat void -cvtp (RecP c fs) = ConPatIn (cName c) $ Hs.RecCon (map (\(s,p) -> (vName s,cvtp p)) fs) -cvtp (ListP ps) = ListPat (map cvtp ps) void +cvtp (RecP c fs) = ConPatIn (noLoc (cName c)) $ Hs.RecCon (map (\(s,p) -> (noLoc (vName s),cvtlp p)) fs) +cvtp (ListP ps) = ListPat (map cvtlp ps) void ----------------------------------------------------------- -- Types and type variables -cvt_tvs :: [TH.Name] -> [HsTyVarBndr RdrName] -cvt_tvs tvs = map (UserTyVar . tName) tvs +cvt_tvs :: [TH.Name] -> [LHsTyVarBndr RdrName] +cvt_tvs tvs = map (noLoc . UserTyVar . tName) tvs -cvt_context :: Cxt -> HsContext RdrName -cvt_context tys = map cvt_pred tys +cvt_context :: Cxt -> LHsContext RdrName +cvt_context tys = noLoc (map cvt_pred tys) -cvt_pred :: TH.Type -> HsPred RdrName +cvt_pred :: TH.Type -> LHsPred RdrName cvt_pred ty = case split_ty_app ty of - (ConT tc, tys) -> HsClassP (tconName tc) (map cvtType tys) - (VarT tv, tys) -> HsClassP (tName tv) (map cvtType tys) + (ConT tc, tys) -> noLoc (HsClassP (tconName tc) (map cvtType tys)) + (VarT tv, tys) -> noLoc (HsClassP (tName tv) (map cvtType tys)) other -> cvtPanic "Malformed predicate" (text (show (TH.pprType ty))) -cvtType :: TH.Type -> HsType RdrName +cvtType :: TH.Type -> LHsType RdrName cvtType ty = trans (root ty []) where root (AppT a b) zs = root a (cvtType b : zs) root t zs = (t,zs) trans (TupleT n,args) - | length args == n = HsTupleTy Boxed args - | n == 0 = foldl HsAppTy (HsTyVar (getRdrName unitTyCon)) args - | otherwise = foldl HsAppTy (HsTyVar (getRdrName (tupleTyCon Boxed n))) args - trans (ArrowT, [x,y]) = HsFunTy x y - trans (ListT, [x]) = HsListTy x + | length args == n = noLoc (HsTupleTy Boxed args) + | n == 0 = foldl nlHsAppTy (nlHsTyVar (getRdrName unitTyCon)) args + | otherwise = foldl nlHsAppTy (nlHsTyVar (getRdrName (tupleTyCon Boxed n))) args + trans (ArrowT, [x,y]) = nlHsFunTy x y + trans (ListT, [x]) = noLoc (HsListTy x) - trans (VarT nm, args) = foldl HsAppTy (HsTyVar (tName nm)) args - trans (ConT tc, args) = foldl HsAppTy (HsTyVar (tconName tc)) args + trans (VarT nm, args) = foldl nlHsAppTy (nlHsTyVar (tName nm)) args + trans (ConT tc, args) = foldl nlHsAppTy (nlHsTyVar (tconName tc)) args - trans (ForallT tvs cxt ty, []) = mkExplicitHsForAllTy + trans (ForallT tvs cxt ty, []) = noLoc $ mkExplicitHsForAllTy (cvt_tvs tvs) (cvt_context cxt) (cvtType ty) split_ty_app :: TH.Type -> (TH.Type, [TH.Type]) @@ -351,8 +351,8 @@ cvtPanic herald thing ----------------------------------------------------------- -- some useful things -truePat = ConPatIn (getRdrName trueDataCon) (PrefixCon []) -falsePat = ConPatIn (getRdrName falseDataCon) (PrefixCon []) +truePat = nlConPat (getRdrName trueDataCon) [] +falsePat = nlConPat (getRdrName falseDataCon) [] overloadedLit :: Lit -> Bool -- True for literals that Haskell treats as overloaded @@ -363,8 +363,8 @@ overloadedLit l = False void :: Type.Type void = placeHolderType -loc0 :: SrcLoc -loc0 = generatedSrcLoc +loc0 :: SrcSpan +loc0 = srcLocSpan generatedSrcLoc -------------------------------------------------------------------- -- Turning Name back into RdrName diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index 34ebac6526..494ac606b5 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -3,89 +3,54 @@ % \section[HsBinds]{Abstract syntax: top-level bindings and signatures} -Datatype for: @HsBinds@, @Bind@, @Sig@, @MonoBinds@. +Datatype for: @BindGroup@, @Bind@, @Sig@, @Bind@. \begin{code} module HsBinds where #include "HsVersions.h" -import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, - Match, pprFunBind, - GRHSs, pprPatBind ) +import {-# SOURCE #-} HsExpr ( HsExpr, pprExpr, LHsExpr, + LMatch, pprFunBind, + GRHSs, pprPatBind ) -- friends: -import HsPat ( Pat ) -import HsTypes ( HsType ) +import HsPat ( LPat ) +import HsTypes ( LHsType ) --others: import Name ( Name ) import NameSet ( NameSet, elemNameSet, nameSetToList ) -import BasicTypes ( RecFlag(..), Activation(..), Fixity, IPName ) +import BasicTypes ( IPName, RecFlag(..), Activation(..), Fixity ) import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), unLoc ) import Var ( TyVar ) +import Bag ( Bag, bagToList ) \end{code} %************************************************************************ %* * -\subsection{Bindings: @HsBinds@} +\subsection{Bindings: @BindGroup@} %* * %************************************************************************ -The following syntax may produce new syntax which is not part of the input, -and which is instead a translation of the input to the typechecker. -Syntax translations are marked TRANSLATION in comments. New empty -productions are useful in development but may not appear in the final -grammar. - -Collections of bindings, created by dependency analysis and translation: +Global bindings (where clauses) \begin{code} -data HsBinds id -- binders and bindees - = EmptyBinds - | ThenBinds (HsBinds id) (HsBinds id) - - | MonoBind -- A mutually recursive group - (MonoBinds id) - [Sig id] -- Empty on typechecker output, Type Signatures +data HsBindGroup id + = HsBindGroup -- A mutually recursive group + (LHsBinds id) + [LSig id] -- Empty on typechecker output, Type Signatures RecFlag - | IPBinds -- Implcit parameters - -- Not allowed at top level - [(IPName id, HsExpr id)] -\end{code} - -\begin{code} -nullBinds :: HsBinds id -> Bool - -nullBinds EmptyBinds = True -nullBinds (ThenBinds b1 b2) = nullBinds b1 && nullBinds b2 -nullBinds (MonoBind b _ _) = nullMonoBinds b -nullBinds (IPBinds b) = null b - -mkMonoBind :: RecFlag -> MonoBinds id -> HsBinds id -mkMonoBind _ EmptyMonoBinds = EmptyBinds -mkMonoBind is_rec mbinds = MonoBind mbinds [] is_rec -\end{code} - -\begin{code} -instance (OutputableBndr id) => Outputable (HsBinds id) where - ppr binds = ppr_binds binds + | HsIPBinds + [LIPBind id] -- Not allowed at top level -ppr_binds EmptyBinds = empty -ppr_binds (ThenBinds binds1 binds2) - = ppr_binds binds1 $$ ppr_binds binds2 - -ppr_binds (IPBinds binds) - = sep (punctuate semi (map pp_item binds)) - where - pp_item (id,rhs) = pprBndr LetBind id <+> equals <+> pprExpr rhs - -ppr_binds (MonoBind bind sigs is_rec) +instance OutputableBndr id => Outputable (HsBindGroup id) where + ppr (HsBindGroup binds sigs is_rec) = vcat [ppr_isrec, vcat (map ppr sigs), - ppr bind + vcat (map ppr (bagToList binds)) ] where ppr_isrec = getPprStyle $ \ sty -> @@ -93,49 +58,58 @@ ppr_binds (MonoBind bind sigs is_rec) case is_rec of Recursive -> ptext SLIT("{- rec -}") NonRecursive -> ptext SLIT("{- nonrec -}") -\end{code} -%************************************************************************ -%* * -\subsection{Bindings: @MonoBinds@} -%* * -%************************************************************************ + ppr (HsIPBinds ipbinds) + = vcat (map ppr ipbinds) -Global bindings (where clauses) +mkHsBindGroup :: RecFlag -> Bag (LHsBind id) -> HsBindGroup id +mkHsBindGroup is_rec mbinds = HsBindGroup mbinds [] is_rec -\begin{code} -data MonoBinds id - = EmptyMonoBinds - - | AndMonoBinds (MonoBinds id) - (MonoBinds id) - - | FunMonoBind id -- Used for both functions f x = e - -- and variables f = \x -> e - -- Reason: the Match stuff lets us have an optional - -- result type sig f :: a->a = ...mentions a... - -- - -- This also means that instance decls can only have - -- FunMonoBinds, so if you change this, you'll need to - -- change e.g. rnMethodBinds - Bool -- True => infix declaration - [Match id] - SrcLoc - - | PatMonoBind (Pat id) -- The pattern is never a simple variable; - -- That case is done by FunMonoBind - (GRHSs id) - SrcLoc - - | VarMonoBind id -- TRANSLATION - (HsExpr id) +-- ----------------------------------------------------------------------------- +-- Implicit parameter bindings + +type LIPBind id = Located (IPBind id) + +-- | Implicit parameter bindings. +data IPBind id + = IPBind + (IPName id) + (LHsExpr id) + +instance (OutputableBndr id) => Outputable (IPBind id) where + ppr (IPBind id rhs) = pprBndr LetBind id <+> equals <+> pprExpr (unLoc rhs) + +-- ----------------------------------------------------------------------------- + +type LHsBinds id = Bag (LHsBind id) +type LHsBind id = Located (HsBind id) + +data HsBind id + = FunBind (Located id) + -- Used for both functions f x = e + -- and variables f = \x -> e + -- Reason: the Match stuff lets us have an optional + -- result type sig f :: a->a = ...mentions a... + -- + -- This also means that instance decls can only have + -- FunBinds, so if you change this, you'll need to + -- change e.g. rnMethodBinds + Bool -- True => infix declaration + [LMatch id] + + | PatBind (LPat id) -- The pattern is never a simple variable; + -- That case is done by FunBind + (GRHSs id) + + | VarBind id (Located (HsExpr id)) -- Dictionary binding and suchlike; + -- located only for consistency | AbsBinds -- Binds abstraction; TRANSLATION [TyVar] -- Type variables [id] -- Dicts [([TyVar], id, id)] -- (type variables, polymorphic, momonmorphic) triples NameSet -- Set of *polymorphic* variables that have an INLINE pragma - (MonoBinds id) -- The "business end" + (LHsBinds id) -- The "business end" -- Creates bindings for *new* (polymorphic, overloaded) locals -- in terms of *old* (monomorphic, non-overloaded) ones. @@ -170,50 +144,16 @@ So the desugarer tries to do a better job: in (fm,gm) \begin{code} --- We keep the invariant that a MonoBinds is only empty --- if it is exactly EmptyMonoBinds - -nullMonoBinds :: MonoBinds id -> Bool -nullMonoBinds EmptyMonoBinds = True -nullMonoBinds other_monobind = False - -andMonoBinds :: MonoBinds id -> MonoBinds id -> MonoBinds id -andMonoBinds EmptyMonoBinds mb = mb -andMonoBinds mb EmptyMonoBinds = mb -andMonoBinds mb1 mb2 = AndMonoBinds mb1 mb2 - -andMonoBindList :: [MonoBinds id] -> MonoBinds id -andMonoBindList binds - = loop1 binds - where - loop1 [] = EmptyMonoBinds - loop1 (EmptyMonoBinds : binds) = loop1 binds - loop1 (b:bs) = loop2 b bs - - -- acc is non-empty - loop2 acc [] = acc - loop2 acc (EmptyMonoBinds : bs) = loop2 acc bs - loop2 acc (b:bs) = loop2 (acc `AndMonoBinds` b) bs -\end{code} - - -\begin{code} -instance OutputableBndr id => Outputable (MonoBinds id) where +instance OutputableBndr id => Outputable (HsBind id) where ppr mbind = ppr_monobind mbind +ppr_monobind :: OutputableBndr id => HsBind id -> SDoc -ppr_monobind :: OutputableBndr id => MonoBinds id -> SDoc -ppr_monobind EmptyMonoBinds = empty -ppr_monobind (AndMonoBinds binds1 binds2) - = ppr_monobind binds1 $$ ppr_monobind binds2 - -ppr_monobind (PatMonoBind pat grhss locn) = pprPatBind pat grhss -ppr_monobind (FunMonoBind fun inf matches locn) = pprFunBind fun matches +ppr_monobind (PatBind pat grhss) = pprPatBind pat grhss +ppr_monobind (VarBind var rhs) = ppr var <+> equals <+> pprExpr (unLoc rhs) +ppr_monobind (FunBind fun inf matches) = pprFunBind (unLoc fun) matches -- ToDo: print infix if appropriate -ppr_monobind (VarMonoBind name expr) - = sep [pprBndr LetBind name <+> equals, nest 4 (pprExpr expr)] - ppr_monobind (AbsBinds tyvars dictvars exports inlines val_binds) = sep [ptext SLIT("AbsBinds"), brackets (interpp'SP tyvars), @@ -239,62 +179,58 @@ signatures. Then all the machinery to move them into place, etc., serves for both. \begin{code} +type LSig name = Located (Sig name) + data Sig name - = Sig name -- a bog-std type signature - (HsType name) - SrcLoc + = Sig (Located name) -- a bog-std type signature + (LHsType name) - | SpecSig name -- specialise a function or datatype ... - (HsType name) -- ... to these types - SrcLoc + | SpecSig (Located name) -- specialise a function or datatype ... + (LHsType name) -- ... to these types | InlineSig Bool -- True <=> INLINE f, False <=> NOINLINE f - name -- Function name + (Located name) -- Function name Activation -- When inlining is *active* - SrcLoc - | SpecInstSig (HsType name) -- (Class tys); should be a specialisation of the + | SpecInstSig (LHsType name) -- (Class tys); should be a specialisation of the -- current instance decl - SrcLoc | FixSig (FixitySig name) -- Fixity declaration -data FixitySig name = FixitySig name Fixity SrcLoc +type LFixitySig name = Located (FixitySig name) +data FixitySig name = FixitySig (Located name) Fixity \end{code} \begin{code} -okBindSig :: NameSet -> Sig Name -> Bool -okBindSig ns sig = sigForThisGroup ns sig +okBindSig :: NameSet -> LSig Name -> Bool +okBindSig ns sig = sigForThisGroup ns sig -okClsDclSig :: Sig Name -> Bool -okClsDclSig (SpecInstSig _ _) = False -okClsDclSig sig = True -- All others OK +okClsDclSig :: LSig Name -> Bool +okClsDclSig (L _ (SpecInstSig _)) = False +okClsDclSig sig = True -- All others OK -okInstDclSig :: NameSet -> Sig Name -> Bool -okInstDclSig ns (Sig _ _ _) = False -okInstDclSig ns (FixSig _) = False -okInstDclSig ns (SpecInstSig _ _) = True -okInstDclSig ns sig = sigForThisGroup ns sig +okInstDclSig :: NameSet -> LSig Name -> Bool +okInstDclSig ns lsig@(L _ sig) = ok ns sig + where + ok ns (Sig _ _) = False + ok ns (FixSig _) = False + ok ns (SpecInstSig _) = True + ok ns sig = sigForThisGroup ns lsig -sigForThisGroup :: NameSet -> Sig Name -> Bool -sigForThisGroup ns sig +sigForThisGroup :: NameSet -> LSig Name -> Bool +sigForThisGroup ns sig = case sigName sig of Nothing -> False Just n -> n `elemNameSet` ns -sigName :: Sig name -> Maybe name -sigName (Sig n _ _) = Just n -sigName (SpecSig n _ _) = Just n -sigName (InlineSig _ n _ _) = Just n -sigName (FixSig (FixitySig n _ _)) = Just n -sigName other = Nothing - -sigLoc :: Sig name -> SrcLoc -sigLoc (Sig _ _ loc) = loc -sigLoc (SpecSig _ _ loc) = loc -sigLoc (InlineSig _ _ _ loc) = loc -sigLoc (FixSig (FixitySig n _ loc)) = loc -sigLoc (SpecInstSig _ loc) = loc +sigName :: LSig name -> Maybe name +sigName (L _ sig) = f sig + where + f (Sig n _) = Just (unLoc n) + f (SpecSig n _) = Just (unLoc n) + f (InlineSig _ n _) = Just (unLoc n) + f (FixSig (FixitySig n _)) = Just (unLoc n) + f other = Nothing isFixitySig :: Sig name -> Bool isFixitySig (FixSig _) = True @@ -302,26 +238,26 @@ isFixitySig _ = False isPragSig :: Sig name -> Bool -- Identifies pragmas -isPragSig (SpecSig _ _ _) = True -isPragSig (InlineSig _ _ _ _) = True -isPragSig (SpecInstSig _ _) = True -isPragSig other = False - -hsSigDoc (Sig _ _ loc) = (ptext SLIT("type signature"),loc) -hsSigDoc (SpecSig _ _ loc) = (ptext SLIT("SPECIALISE pragma"),loc) -hsSigDoc (InlineSig True _ _ loc) = (ptext SLIT("INLINE pragma"),loc) -hsSigDoc (InlineSig False _ _ loc) = (ptext SLIT("NOINLINE pragma"),loc) -hsSigDoc (SpecInstSig _ loc) = (ptext SLIT("SPECIALISE instance pragma"),loc) -hsSigDoc (FixSig (FixitySig _ _ loc)) = (ptext SLIT("fixity declaration"), loc) +isPragSig (SpecSig _ _) = True +isPragSig (InlineSig _ _ _) = True +isPragSig (SpecInstSig _) = True +isPragSig other = False + +hsSigDoc (Sig _ _) = ptext SLIT("type signature") +hsSigDoc (SpecSig _ _) = ptext SLIT("SPECIALISE pragma") +hsSigDoc (InlineSig True _ _) = ptext SLIT("INLINE pragma") +hsSigDoc (InlineSig False _ _) = ptext SLIT("NOINLINE pragma") +hsSigDoc (SpecInstSig _) = ptext SLIT("SPECIALISE instance pragma") +hsSigDoc (FixSig (FixitySig _ _)) = ptext SLIT("fixity declaration") \end{code} Signature equality is used when checking for duplicate signatures \begin{code} eqHsSig :: Sig Name -> Sig Name -> Bool -eqHsSig (FixSig (FixitySig n1 _ _)) (FixSig (FixitySig n2 _ _)) = n1 == n2 -eqHsSig (Sig n1 _ _) (Sig n2 _ _) = n1 == n2 -eqHsSig (InlineSig b1 n1 _ _) (InlineSig b2 n2 _ _) = b1 == b2 && n1 == n2 +eqHsSig (FixSig (FixitySig n1 _)) (FixSig (FixitySig n2 _)) = unLoc n1 == unLoc n2 +eqHsSig (Sig n1 _) (Sig n2 _) = unLoc n1 == unLoc n2 +eqHsSig (InlineSig b1 n1 _) (InlineSig b2 n2 _) = b1 == b2 && unLoc n1 == unLoc n2 -- For specialisations, we don't have equality over -- HsType, so it's not convenient to spot duplicate -- specialisations here. Check for this later, when we're in Type land @@ -333,25 +269,25 @@ instance (Outputable name) => Outputable (Sig name) where ppr sig = ppr_sig sig ppr_sig :: Outputable name => Sig name -> SDoc -ppr_sig (Sig var ty _) +ppr_sig (Sig var ty) = sep [ppr var <+> dcolon, nest 4 (ppr ty)] -ppr_sig (SpecSig var ty _) +ppr_sig (SpecSig var ty) = sep [ hsep [text "{-# SPECIALIZE", ppr var, dcolon], nest 4 (ppr ty <+> text "#-}") ] -ppr_sig (InlineSig True var phase _) +ppr_sig (InlineSig True var phase) = hsep [text "{-# INLINE", ppr phase, ppr var, text "#-}"] -ppr_sig (InlineSig False var phase _) +ppr_sig (InlineSig False var phase) = hsep [text "{-# NOINLINE", ppr phase, ppr var, text "#-}"] -ppr_sig (SpecInstSig ty _) +ppr_sig (SpecInstSig ty) = hsep [text "{-# SPECIALIZE instance", ppr ty, text "#-}"] ppr_sig (FixSig fix_sig) = ppr fix_sig instance Outputable name => Outputable (FixitySig name) where - ppr (FixitySig name fixity loc) = sep [ppr fixity, ppr name] + ppr (FixitySig name fixity) = sep [ppr fixity, ppr name] \end{code} diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 2643fdbc1c..43efaf5be0 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -8,14 +8,17 @@ Definitions for: @TyDecl@ and @oCnDecl@, @ClassDecl@, \begin{code} module HsDecls ( - HsDecl(..), TyClDecl(..), InstDecl(..), RuleDecl(..), RuleBndr(..), - DefaultDecl(..), HsGroup(..), SpliceDecl(..), - ForeignDecl(..), ForeignImport(..), ForeignExport(..), + HsDecl(..), LHsDecl, TyClDecl(..), LTyClDecl, + InstDecl(..), LInstDecl, + RuleDecl(..), LRuleDecl, RuleBndr(..), + DefaultDecl(..), LDefaultDecl, HsGroup(..), SpliceDecl(..), + ForeignDecl(..), LForeignDecl, ForeignImport(..), ForeignExport(..), CImportSpec(..), FoType(..), - ConDecl(..), - BangType(..), HsBang(..), getBangType, getBangStrictness, unbangedType, - DeprecDecl(..), - tyClDeclName, tyClDeclNames, tyClDeclTyVars, + ConDecl(..), LConDecl, + LBangType, BangType(..), HsBang(..), + getBangType, getBangStrictness, unbangedType, + DeprecDecl(..), LDeprecDecl, + tcdName, tyClDeclNames, tyClDeclTyVars, isClassDecl, isSynDecl, isDataDecl, countTyClDecls, conDetailsTys, @@ -28,7 +31,8 @@ module HsDecls ( import {-# SOURCE #-} HsExpr( HsExpr, pprExpr ) -- Because Expr imports Decls via HsBracket -import HsBinds ( HsBinds, MonoBinds, Sig(..), FixitySig ) +import HsBinds ( HsBindGroup, HsBind, LHsBinds, + Sig(..), LSig, LFixitySig ) import HsPat ( HsConDetails(..), hsConArgs ) import HsImpExp ( pprHsVar ) import HsTypes @@ -44,7 +48,7 @@ import Class ( FunDep ) import CStrings ( CLabelString ) import Outputable import Util ( count ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), unLoc ) import FastString \end{code} @@ -56,10 +60,12 @@ import FastString %************************************************************************ \begin{code} +type LHsDecl id = Located (HsDecl id) + data HsDecl id = TyClD (TyClDecl id) | InstD (InstDecl id) - | ValD (MonoBinds id) + | ValD (HsBind id) | SigD (Sig id) | DefD (DefaultDecl id) | ForD (ForeignDecl id) @@ -84,23 +90,23 @@ data HsDecl id -- fed to the renamer. data HsGroup id = HsGroup { - hs_valds :: HsBinds id, - -- Before the renamer, this is a single big MonoBinds, + hs_valds :: [HsBindGroup id], + -- Before the renamer, this is a single big HsBindGroup, -- with all the bindings, and all the signatures. - -- The renamer does dependency analysis, using ThenBinds - -- to give the structure + -- The renamer does dependency analysis, splitting it up + -- into several HsBindGroups. - hs_tyclds :: [TyClDecl id], - hs_instds :: [InstDecl id], + hs_tyclds :: [LTyClDecl id], + hs_instds :: [LInstDecl id], - hs_fixds :: [FixitySig id], + hs_fixds :: [LFixitySig id], -- Snaffled out of both top-level fixity signatures, -- and those in class declarations - hs_defds :: [DefaultDecl id], - hs_fords :: [ForeignDecl id], - hs_depds :: [DeprecDecl id], - hs_ruleds :: [RuleDecl id] + hs_defds :: [LDefaultDecl id], + hs_fords :: [LForeignDecl id], + hs_depds :: [LDeprecDecl id], + hs_ruleds :: [LRuleDecl id] } \end{code} @@ -134,10 +140,10 @@ instance OutputableBndr name => Outputable (HsGroup name) where ppr_ds [] = empty ppr_ds ds = text "" $$ vcat (map ppr ds) -data SpliceDecl id = SpliceDecl (HsExpr id) SrcLoc -- Top level splice +data SpliceDecl id = SpliceDecl (Located (HsExpr id)) -- Top level splice instance OutputableBndr name => Outputable (SpliceDecl name) where - ppr (SpliceDecl e _) = ptext SLIT("$") <> parens (pprExpr e) + ppr (SpliceDecl e) = ptext SLIT("$") <> parens (pprExpr (unLoc e)) \end{code} @@ -151,8 +157,8 @@ instance OutputableBndr name => Outputable (SpliceDecl name) where THE NAMING STORY -------------------------------- -Here is the story about the implicit names that go with type, class, and instance -decls. It's a bit tricky, so pay attention! +Here is the story about the implicit names that go with type, class, +and instance decls. It's a bit tricky, so pay attention! "Implicit" (or "system") binders ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ @@ -165,7 +171,8 @@ decls. It's a bit tricky, so pay attention! the worker for that constructor a selector for each superclass -All have occurrence names that are derived uniquely from their parent declaration. +All have occurrence names that are derived uniquely from their parent +declaration. None of these get separate definitions in an interface file; they are fully defined by the data or class decl. But they may *occur* in @@ -285,35 +292,36 @@ Interface file code: -- for a module. That's why (despite the misnomer) IfaceSig and ForeignType -- are both in TyClDecl +type LTyClDecl name = Located (TyClDecl name) + data TyClDecl name - = ForeignType { tcdName :: name, - tcdExtName :: Maybe FastString, - tcdFoType :: FoType, - tcdLoc :: SrcLoc } + = ForeignType { + tcdLName :: Located name, + tcdExtName :: Maybe FastString, + tcdFoType :: FoType + } | TyData { tcdND :: NewOrData, - tcdCtxt :: HsContext name, -- Context - tcdName :: name, -- Type constructor - tcdTyVars :: [HsTyVarBndr name], -- Type variables - tcdCons :: [ConDecl name], -- Data constructors - tcdDerivs :: Maybe (HsContext name), -- Derivings; Nothing => not specified - -- Just [] => derive exactly what is asked - tcdLoc :: SrcLoc + tcdCtxt :: LHsContext name, -- Context + tcdLName :: Located name, -- Type constructor + tcdTyVars :: [LHsTyVarBndr name], -- Type variables + tcdCons :: [LConDecl name], -- Data constructors + tcdDerivs :: Maybe (LHsContext name) + -- Derivings; Nothing => not specified + -- Just [] => derive exactly what is asked } - | TySynonym { tcdName :: name, -- type constructor - tcdTyVars :: [HsTyVarBndr name], -- type variables - tcdSynRhs :: HsType name, -- synonym expansion - tcdLoc :: SrcLoc + | TySynonym { tcdLName :: Located name, -- type constructor + tcdTyVars :: [LHsTyVarBndr name], -- type variables + tcdSynRhs :: LHsType name -- synonym expansion } - | ClassDecl { tcdCtxt :: HsContext name, -- Context... - tcdName :: name, -- Name of the class - tcdTyVars :: [HsTyVarBndr name], -- The class type variables - tcdFDs :: [FunDep name], -- Functional dependencies - tcdSigs :: [Sig name], -- Methods' signatures - tcdMeths :: MonoBinds name, -- Default methods - tcdLoc :: SrcLoc + | ClassDecl { tcdCtxt :: LHsContext name, -- Context... + tcdLName :: Located name, -- Name of the class + tcdTyVars :: [LHsTyVarBndr name], -- Class type variables + tcdFDs :: [Located (FunDep name)], -- Functional deps + tcdSigs :: [LSig name], -- Methods' signatures + tcdMeths :: LHsBinds name -- Default methods } \end{code} @@ -335,25 +343,23 @@ isClassDecl other = False Dealing with names \begin{code} --------------------------------- -tyClDeclName :: TyClDecl name -> name -tyClDeclName tycl_decl = tcdName tycl_decl +tcdName :: TyClDecl name -> name +tcdName decl = unLoc (tcdLName decl) --------------------------------- -tyClDeclNames :: Eq name => TyClDecl name -> [(name, SrcLoc)] +tyClDeclNames :: Eq name => TyClDecl name -> [Located name] -- Returns all the *binding* names of the decl, along with their SrcLocs -- The first one is guaranteed to be the name of the decl -- For record fields, the first one counts as the SrcLoc -- We use the equality to filter out duplicate field names -tyClDeclNames (TySynonym {tcdName = name, tcdLoc = loc}) = [(name,loc)] -tyClDeclNames (ForeignType {tcdName = name, tcdLoc = loc}) = [(name,loc)] +tyClDeclNames (TySynonym {tcdLName = name}) = [name] +tyClDeclNames (ForeignType {tcdLName = name}) = [name] -tyClDeclNames (ClassDecl {tcdName = cls_name, tcdSigs = sigs, tcdLoc = loc}) - = (cls_name,loc) : [(n,loc) | Sig n _ loc <- sigs] +tyClDeclNames (ClassDecl {tcdLName = cls_name, tcdSigs = sigs}) + = cls_name : [n | L _ (Sig n _) <- sigs] -tyClDeclNames (TyData {tcdName = tc_name, tcdCons = cons, tcdLoc = loc}) - = (tc_name,loc) : conDeclsNames cons +tyClDeclNames (TyData {tcdLName = tc_name, tcdCons = cons}) + = tc_name : conDeclsNames (map unLoc cons) tyClDeclTyVars (TySynonym {tcdTyVars = tvs}) = tvs tyClDeclTyVars (TyData {tcdTyVars = tvs}) = tvs @@ -381,21 +387,21 @@ countTyClDecls decls instance OutputableBndr name => Outputable (TyClDecl name) where - ppr (ForeignType {tcdName = tycon}) - = hsep [ptext SLIT("foreign import type dotnet"), ppr tycon] + ppr (ForeignType {tcdLName = ltycon}) + = hsep [ptext SLIT("foreign import type dotnet"), ppr ltycon] - ppr (TySynonym {tcdName = tycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty}) - = hang (ptext SLIT("type") <+> pp_decl_head [] tycon tyvars <+> equals) + ppr (TySynonym {tcdLName = ltycon, tcdTyVars = tyvars, tcdSynRhs = mono_ty}) + = hang (ptext SLIT("type") <+> pp_decl_head [] ltycon tyvars <+> equals) 4 (ppr mono_ty) - ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, + ppr (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = ltycon, tcdTyVars = tyvars, tcdCons = condecls, tcdDerivs = derivings}) - = pp_tydecl (ppr new_or_data <+> pp_decl_head context tycon tyvars) + = pp_tydecl (ppr new_or_data <+> pp_decl_head (unLoc context) ltycon tyvars) (pp_condecls condecls) derivings - ppr (ClassDecl {tcdCtxt = context, tcdName = clas, tcdTyVars = tyvars, tcdFDs = fds, + ppr (ClassDecl {tcdCtxt = context, tcdLName = lclas, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = methods}) | null sigs -- No "where" part = top_matter @@ -404,11 +410,16 @@ instance OutputableBndr name = sep [hsep [top_matter, ptext SLIT("where {")], nest 4 (sep [sep (map ppr_sig sigs), ppr methods, char '}'])] where - top_matter = ptext SLIT("class") <+> pp_decl_head context clas tyvars <+> pprFundeps fds + top_matter = ptext SLIT("class") <+> pp_decl_head (unLoc context) lclas tyvars <+> pprFundeps (map unLoc fds) ppr_sig sig = ppr sig <> semi -pp_decl_head :: OutputableBndr name => HsContext name -> name -> [HsTyVarBndr name] -> SDoc -pp_decl_head context thing tyvars = hsep [pprHsContext context, ppr thing, interppSP tyvars] +pp_decl_head :: OutputableBndr name + => HsContext name + -> Located name + -> [LHsTyVarBndr name] + -> SDoc +pp_decl_head context thing tyvars + = hsep [pprHsContext context, ppr thing, interppSP tyvars] pp_condecls cs = equals <+> sep (punctuate (ptext SLIT(" |")) (map ppr cs)) @@ -417,7 +428,8 @@ pp_tydecl pp_head pp_decl_rhs derivings pp_decl_rhs, case derivings of Nothing -> empty - Just ds -> hsep [ptext SLIT("deriving"), ppr_hs_context ds] + Just ds -> hsep [ptext SLIT("deriving"), + ppr_hs_context (unLoc ds)] ]) \end{code} @@ -429,39 +441,42 @@ pp_tydecl pp_head pp_decl_rhs derivings %************************************************************************ \begin{code} +type LConDecl name = Located (ConDecl name) + data ConDecl name - = ConDecl name -- Constructor name; this is used for the + = ConDecl (Located name) -- Constructor name; this is used for the -- DataCon itself, and for the user-callable wrapper Id - [HsTyVarBndr name] -- Existentially quantified type variables - (HsContext name) -- ...and context + [LHsTyVarBndr name] -- Existentially quantified type variables + (LHsContext name) -- ...and context -- If both are empty then there are no existentials - (HsConDetails name (BangType name)) - SrcLoc + (HsConDetails name (LBangType name)) \end{code} \begin{code} -conDeclsNames :: Eq name => [ConDecl name] -> [(name,SrcLoc)] +conDeclsNames :: Eq name => [ConDecl name] -> [Located name] -- See tyClDeclNames for what this does -- The function is boringly complicated because of the records -- And since we only have equality, we have to be a little careful conDeclsNames cons = snd (foldl do_one ([], []) cons) where - do_one (flds_seen, acc) (ConDecl name _ _ (RecCon flds) loc) - = (new_flds ++ flds_seen, (name,loc) : [(f,loc) | f <- new_flds] ++ acc) + do_one (flds_seen, acc) (ConDecl lname _ _ (RecCon flds)) + = (map unLoc new_flds ++ flds_seen, lname : [f | f <- new_flds] ++ acc) where - new_flds = [ f | (f,_) <- flds, not (f `elem` flds_seen) ] + new_flds = [ f | (f,_) <- flds, not (unLoc f `elem` flds_seen) ] - do_one (flds_seen, acc) (ConDecl name _ _ _ loc) - = (flds_seen, (name,loc):acc) + do_one (flds_seen, acc) (ConDecl lname _ _ _) + = (flds_seen, lname:acc) conDetailsTys details = map getBangType (hsConArgs details) \end{code} \begin{code} -data BangType name = BangType HsBang (HsType name) +type LBangType name = Located (BangType name) + +data BangType name = BangType HsBang (LHsType name) data HsBang = HsNoBang | HsStrict -- ! @@ -470,12 +485,13 @@ data HsBang = HsNoBang getBangType (BangType _ ty) = ty getBangStrictness (BangType s _) = s -unbangedType ty = BangType HsNoBang ty +unbangedType :: LHsType id -> LBangType id +unbangedType ty@(L loc _) = L loc (BangType HsNoBang ty) \end{code} \begin{code} instance (OutputableBndr name) => Outputable (ConDecl name) where - ppr (ConDecl con tvs cxt con_details loc) + ppr (ConDecl con tvs cxt con_details) = sep [pprHsForAll Explicit tvs cxt, ppr_con_details con con_details] ppr_con_details con (InfixCon ty1 ty2) @@ -495,7 +511,7 @@ ppr_con_details con (RecCon fields) instance OutputableBndr name => Outputable (BangType name) where ppr (BangType is_strict ty) - = bang <> pprParendHsType ty + = bang <> pprParendHsType (unLoc ty) where bang = case is_strict of HsNoBang -> empty @@ -511,17 +527,18 @@ instance OutputableBndr name => Outputable (BangType name) where %************************************************************************ \begin{code} +type LInstDecl name = Located (InstDecl name) + data InstDecl name - = InstDecl (HsType name) -- Context => Class Instance-type + = InstDecl (LHsType name) -- Context => Class Instance-type -- Using a polytype means that the renamer conveniently -- figures out the quantified type variables for us. - (MonoBinds name) - [Sig name] -- User-supplied pragmatic info - SrcLoc + (LHsBinds name) + [LSig name] -- User-supplied pragmatic info instance (OutputableBndr name) => Outputable (InstDecl name) where - ppr (InstDecl inst_ty binds uprags src_loc) + ppr (InstDecl inst_ty binds uprags) = vcat [hsep [ptext SLIT("instance"), ppr inst_ty, ptext SLIT("where")], nest 4 (ppr uprags), nest 4 (ppr binds) ] @@ -538,14 +555,15 @@ for the parser to check that; we pass them all through in the abstract syntax, and that restriction must be checked in the front end. \begin{code} +type LDefaultDecl name = Located (DefaultDecl name) + data DefaultDecl name - = DefaultDecl [HsType name] - SrcLoc + = DefaultDecl [LHsType name] instance (OutputableBndr name) => Outputable (DefaultDecl name) where - ppr (DefaultDecl tys src_loc) + ppr (DefaultDecl tys) = ptext SLIT("default") <+> parens (interpp'SP tys) \end{code} @@ -563,9 +581,11 @@ instance (OutputableBndr name) -- * the Boolean value indicates whether the pre-standard deprecated syntax -- has been used -- +type LForeignDecl name = Located (ForeignDecl name) + data ForeignDecl name - = ForeignImport name (HsType name) ForeignImport Bool SrcLoc -- defines name - | ForeignExport name (HsType name) ForeignExport Bool SrcLoc -- uses name + = ForeignImport (Located name) (LHsType name) ForeignImport Bool -- defines name + | ForeignExport (Located name) (LHsType name) ForeignExport Bool -- uses name -- specification of an imported external entity in dependence on the calling -- convention @@ -617,10 +637,10 @@ data FoType = DNType -- In due course we'll add subtype stuff -- instance OutputableBndr name => Outputable (ForeignDecl name) where - ppr (ForeignImport n ty fimport _ _) = + ppr (ForeignImport n ty fimport _) = ptext SLIT("foreign import") <+> ppr fimport <+> ppr n <+> dcolon <+> ppr ty - ppr (ForeignExport n ty fexport _ _) = + ppr (ForeignExport n ty fexport _) = ptext SLIT("foreign export") <+> ppr fexport <+> ppr n <+> dcolon <+> ppr ty @@ -662,27 +682,28 @@ instance Outputable FoType where %************************************************************************ \begin{code} +type LRuleDecl name = Located (RuleDecl name) + data RuleDecl name = HsRule -- Source rule RuleName -- Rule name Activation [RuleBndr name] -- Forall'd vars; after typechecking this includes tyvars - (HsExpr name) -- LHS - (HsExpr name) -- RHS - SrcLoc + (Located (HsExpr name)) -- LHS + (Located (HsExpr name)) -- RHS data RuleBndr name - = RuleBndr name - | RuleBndrSig name (HsType name) + = RuleBndr (Located name) + | RuleBndrSig (Located name) (LHsType name) -collectRuleBndrSigTys :: [RuleBndr name] -> [HsType name] +collectRuleBndrSigTys :: [RuleBndr name] -> [LHsType name] collectRuleBndrSigTys bndrs = [ty | RuleBndrSig _ ty <- bndrs] instance OutputableBndr name => Outputable (RuleDecl name) where - ppr (HsRule name act ns lhs rhs loc) + ppr (HsRule name act ns lhs rhs) = sep [text "{-# RULES" <+> doubleQuotes (ftext name) <+> ppr act, - nest 4 (pp_forall <+> pprExpr lhs), - nest 4 (equals <+> pprExpr rhs <+> text "#-}") ] + nest 4 (pp_forall <+> pprExpr (unLoc lhs)), + nest 4 (equals <+> pprExpr (unLoc rhs) <+> text "#-}") ] where pp_forall | null ns = empty | otherwise = text "forall" <+> fsep (map ppr ns) <> dot @@ -702,9 +723,11 @@ instance OutputableBndr name => Outputable (RuleBndr name) where We use exported entities for things to deprecate. \begin{code} -data DeprecDecl name = Deprecation name DeprecTxt SrcLoc +type LDeprecDecl name = Located (DeprecDecl name) + +data DeprecDecl name = Deprecation name DeprecTxt instance OutputableBndr name => Outputable (DeprecDecl name) where - ppr (Deprecation thing txt _) + ppr (Deprecation thing txt) = hsep [text "{-# DEPRECATED", ppr thing, doubleQuotes (ppr txt), text "#-}"] \end{code} diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 index cc7018d177..05e2eb5394 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-5 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-5 @@ -1,12 +1,14 @@ __interface HsExpr 1 0 where -__export HsExpr HsExpr pprExpr Match GRHSs pprPatBind pprFunBind ; +__export HsExpr HsExpr pprExpr Match GRHSs LHsExpr LMatch pprPatBind pprFunBind ; 1 data HsExpr i ; -1 pprExpr :: __forall [i] {Outputable.OutputableBndr i} => HsExpr.HsExpr i -> Outputable.SDoc ; - 1 data Match a ; 1 data GRHSs a ; -1 pprPatBind :: __forall [i] {Outputable.OutputableBndr i} => HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc ; -1 pprFunBind :: __forall [i] {Outputable.OutputableBndr i} => i -> [HsExpr.Match i] -> Outputable.SDoc ; +1 type LHsExpr a = SrcLoc.Located (HsExpr a) ; +1 type LMatch a = SrcLoc.Located (Match a) ; + +1 pprExpr :: __forall [i] {Outputable.OutputableBndr i} => HsExpr.HsExpr i -> Outputable.SDoc ; +1 pprPatBind :: __forall [i] {Outputable.OutputableBndr i} => HsPat.LPat i -> HsExpr.GRHSs i -> Outputable.SDoc ; +1 pprFunBind :: __forall [i] {Outputable.OutputableBndr i} => i -> [HsExpr.LMatch i] -> Outputable.SDoc ; diff --git a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 index 73bbfdefb8..1987cc474f 100644 --- a/ghc/compiler/hsSyn/HsExpr.hi-boot-6 +++ b/ghc/compiler/hsSyn/HsExpr.hi-boot-6 @@ -4,11 +4,14 @@ data HsExpr i data Match a data GRHSs a +type LHsExpr a = SrcLoc.Located (HsExpr a) +type LMatch a = SrcLoc.Located (Match a) + pprExpr :: (Outputable.OutputableBndr i) => HsExpr.HsExpr i -> Outputable.SDoc pprPatBind :: (Outputable.OutputableBndr i) => - HsPat.Pat i -> HsExpr.GRHSs i -> Outputable.SDoc + HsPat.LPat i -> HsExpr.GRHSs i -> Outputable.SDoc pprFunBind :: (Outputable.OutputableBndr i) => - i -> [HsExpr.Match i] -> Outputable.SDoc + i -> [HsExpr.LMatch i] -> Outputable.SDoc diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index e484ad738a..f4915a23b2 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -10,11 +10,11 @@ module HsExpr where -- friends: import HsDecls ( HsGroup ) -import HsBinds ( HsBinds(..), nullBinds ) -import HsPat ( Pat(..), HsConDetails(..) ) +import HsPat ( LPat ) import HsLit ( HsLit(..), HsOverLit ) -import HsTypes ( HsType, PostTcType, SyntaxName, placeHolderType ) +import HsTypes ( LHsType, PostTcType, SyntaxName ) import HsImpExp ( isOperator, pprHsVar ) +import HsBinds ( HsBindGroup ) -- others: import Type ( Type, pprParendType ) @@ -22,7 +22,7 @@ import Var ( TyVar, Id ) import Name ( Name ) import DataCon ( DataCon ) import BasicTypes ( IPName, Boxity, tupleParens, Fixity(..) ) -import SrcLoc ( SrcLoc, generatedSrcLoc ) +import SrcLoc ( Located(..), unLoc ) import Outputable import FastString \end{code} @@ -30,55 +30,22 @@ import FastString %************************************************************************ %* * - Some useful helpers for constructing expressions -%* * -%************************************************************************ - -\begin{code} -mkHsApps f xs = foldl HsApp (HsVar f) xs -mkHsVarApps f xs = foldl HsApp (HsVar f) (map HsVar xs) - -mkHsIntLit n = HsLit (HsInt n) -mkHsString s = HsString (mkFastString s) - -mkConPat con vars = ConPatIn con (PrefixCon (map VarPat vars)) -mkNullaryConPat con = ConPatIn con (PrefixCon []) - -mkSimpleHsAlt :: Pat id -> HsExpr id -> Match id --- A simple lambda with a single pattern, no binds, no guards; pre-typechecking -mkSimpleHsAlt pat expr - = mkSimpleMatch [pat] expr placeHolderType generatedSrcLoc - -mkSimpleMatch :: [Pat id] -> HsExpr id -> Type -> SrcLoc -> Match id -mkSimpleMatch pats rhs rhs_ty locn - = Match pats Nothing (GRHSs (unguardedRHS rhs locn) EmptyBinds rhs_ty) - -unguardedRHS :: HsExpr id -> SrcLoc -> [GRHS id] -unguardedRHS rhs loc = [GRHS [ResultStmt rhs loc] loc] - -glueBindsOnGRHSs :: HsBinds id -> GRHSs id -> GRHSs id -glueBindsOnGRHSs EmptyBinds grhss = grhss -glueBindsOnGRHSs binds1 (GRHSs grhss binds2 ty) - = GRHSs grhss (binds1 `ThenBinds` binds2) ty -\end{code} - - -%************************************************************************ -%* * \subsection{Expressions proper} %* * %************************************************************************ \begin{code} +type LHsExpr id = Located (HsExpr id) + data HsExpr id = HsVar id -- variable | HsIPVar (IPName id) -- implicit parameter | HsOverLit HsOverLit -- Overloaded literals; eliminated by type checker | HsLit HsLit -- Simple (non-overloaded) literals - | HsLam (Match id) -- lambda - | HsApp (HsExpr id) -- application - (HsExpr id) + | HsLam (LMatch id) -- lambda + | HsApp (LHsExpr id) -- application + (LHsExpr id) -- Operator applications: -- NB Bracketed ops such as (+) come out as Vars. @@ -86,54 +53,51 @@ data HsExpr id -- NB We need an expr for the operator in an OpApp/Section since -- the typechecker may need to apply the operator to a few types. - | OpApp (HsExpr id) -- left operand - (HsExpr id) -- operator + | OpApp (LHsExpr id) -- left operand + (LHsExpr id) -- operator Fixity -- Renamer adds fixity; bottom until then - (HsExpr id) -- right operand + (LHsExpr id) -- right operand -- We preserve prefix negation and parenthesis for the precedence parser. -- They are eventually removed by the type checker. - | NegApp (HsExpr id) -- negated expr + | NegApp (LHsExpr id) -- negated expr SyntaxName -- Name of 'negate' (see RnEnv.lookupSyntaxName) - | HsPar (HsExpr id) -- parenthesised expr + | HsPar (LHsExpr id) -- parenthesised expr - | SectionL (HsExpr id) -- operand - (HsExpr id) -- operator - | SectionR (HsExpr id) -- operator - (HsExpr id) -- operand + | SectionL (LHsExpr id) -- operand + (LHsExpr id) -- operator + | SectionR (LHsExpr id) -- operator + (LHsExpr id) -- operand - | HsCase (HsExpr id) - [Match id] - SrcLoc + | HsCase (LHsExpr id) + [LMatch id] - | HsIf (HsExpr id) -- predicate - (HsExpr id) -- then part - (HsExpr id) -- else part - SrcLoc + | HsIf (LHsExpr id) -- predicate + (LHsExpr id) -- then part + (LHsExpr id) -- else part - | HsLet (HsBinds id) -- let(rec) - (HsExpr id) + | HsLet [HsBindGroup id] -- let(rec) + (LHsExpr id) | HsDo (HsStmtContext Name) -- The parameterisation is unimportant -- because in this context we never use -- the PatGuard or ParStmt variant - [Stmt id] -- "do":one or more stmts + [LStmt id] -- "do":one or more stmts (ReboundNames id) -- Ids for [return,fail,>>=,>>] PostTcType -- Type of the whole expression - SrcLoc | ExplicitList -- syntactic list PostTcType -- Gives type of components of list - [HsExpr id] + [LHsExpr id] | ExplicitPArr -- syntactic parallel array: [:e1, ..., en:] PostTcType -- type of elements of the parallel array - [HsExpr id] + [LHsExpr id] | ExplicitTuple -- tuple - [HsExpr id] + [LHsExpr id] -- NB: Unit is ExplicitTuple [] -- for tuples, we can get the types -- direct from the components @@ -141,86 +105,82 @@ data HsExpr id -- Record construction - | RecordCon id -- The constructor + | RecordCon (Located id) -- The constructor (HsRecordBinds id) | RecordConOut DataCon - (HsExpr id) -- Data con Id applied to type args + (LHsExpr id) -- Data con Id applied to type args (HsRecordBinds id) -- Record update - | RecordUpd (HsExpr id) + | RecordUpd (LHsExpr id) (HsRecordBinds id) - | RecordUpdOut (HsExpr id) -- TRANSLATION + | RecordUpdOut (LHsExpr id) -- TRANSLATION Type -- Type of *input* record Type -- Type of *result* record (may differ from -- type of input record) (HsRecordBinds id) | ExprWithTySig -- signature binding - (HsExpr id) - (HsType id) + (LHsExpr id) + (LHsType id) | ArithSeqIn -- arithmetic sequence (ArithSeqInfo id) | ArithSeqOut - (HsExpr id) -- (typechecked, of course) + (LHsExpr id) -- (typechecked, of course) (ArithSeqInfo id) | PArrSeqIn -- arith. sequence for parallel array (ArithSeqInfo id) -- [:e1..e2:] or [:e1, e2..e3:] | PArrSeqOut - (HsExpr id) -- (typechecked, of course) + (LHsExpr id) -- (typechecked, of course) (ArithSeqInfo id) | HsSCC FastString -- "set cost centre" (_scc_) annotation - (HsExpr id) -- expr whose cost is to be measured + (LHsExpr id) -- expr whose cost is to be measured | HsCoreAnn FastString -- hdaume: core annotation - (HsExpr id) + (LHsExpr id) ----------------------------------------------------------- -- MetaHaskell Extensions - | HsBracket (HsBracket id) SrcLoc + | HsBracket (HsBracket id) | HsBracketOut (HsBracket Name) -- Output of the type checker is the *original* [PendingSplice] -- renamed expression, plus *typechecked* splices -- to be pasted back in by the desugarer - | HsSplice id (HsExpr id) SrcLoc -- $z or $(f 4) + | HsSplice id (LHsExpr id) -- $z or $(f 4) -- The id is just a unique name to -- identify this splice point ----------------------------------------------------------- -- Arrow notation extension - | HsProc (Pat id) -- arrow abstraction, proc - (HsCmdTop id) -- body of the abstraction + | HsProc (LPat id) -- arrow abstraction, proc + (LHsCmdTop id) -- body of the abstraction -- always has an empty stack - SrcLoc --------------------------------------- -- The following are commands, not expressions proper | HsArrApp -- Arrow tail, or arrow application (f -< arg) - (HsExpr id) -- arrow expression, f - (HsExpr id) -- input expression, arg + (LHsExpr id) -- arrow expression, f + (LHsExpr id) -- input expression, arg PostTcType -- type of the arrow expressions f, -- of the form a t t', where arg :: t HsArrAppType -- higher-order (-<<) or first-order (-<) Bool -- True => right-to-left (f -< arg) -- False => left-to-right (arg >- f) - SrcLoc | HsArrForm -- Command formation, (| e cmd1 .. cmdn |) - (HsExpr id) -- the operator + (LHsExpr id) -- the operator -- after type-checking, a type abstraction to be -- applied to the type of the local environment tuple (Maybe Fixity) -- fixity (filled in by the renamer), for forms that -- were converted from OpApp's by the renamer - [HsCmdTop id] -- argument commands - SrcLoc - + [LHsCmdTop id] -- argument commands \end{code} @@ -230,12 +190,12 @@ The renamer translates them into the Right Thing. \begin{code} | EWildPat -- wildcard - | EAsPat id -- as pattern - (HsExpr id) + | EAsPat (Located id) -- as pattern + (LHsExpr id) - | ELazyPat (HsExpr id) -- ~ pattern + | ELazyPat (LHsExpr id) -- ~ pattern - | HsType (HsType id) -- Explicit type argument; e.g f {| Int |} x y + | HsType (LHsType id) -- Explicit type argument; e.g f {| Int |} x y \end{code} Everything from here on appears only in typechecker output. @@ -243,20 +203,20 @@ Everything from here on appears only in typechecker output. \begin{code} | TyLam -- TRANSLATION [TyVar] - (HsExpr id) + (LHsExpr id) | TyApp -- TRANSLATION - (HsExpr id) -- generated by Spec + (LHsExpr id) -- generated by Spec [Type] -- DictLam and DictApp are "inverses" | DictLam [id] - (HsExpr id) + (LHsExpr id) | DictApp - (HsExpr id) + (LHsExpr id) [id] -type PendingSplice = (Name, HsExpr Id) -- Typechecked splices, waiting to be +type PendingSplice = (Name, LHsExpr Id) -- Typechecked splices, waiting to be -- pasted back in by the desugarer \end{code} @@ -264,7 +224,7 @@ Table of bindings of names used in rebindable syntax. This gets filled in by the renamer. \begin{code} -type ReboundNames id = [(Name, HsExpr id)] +type ReboundNames id = [(Name, LHsExpr id)] -- * Before the renamer, this list is empty -- -- * After the renamer, it takes the form [(std_name, HsVar actual_name)] @@ -292,24 +252,29 @@ instance OutputableBndr id => Outputable (HsExpr id) where pprExpr :: OutputableBndr id => HsExpr id -> SDoc pprExpr e = pprDeeper (ppr_expr e) -pprBinds b = pprDeeper (ppr b) + +pprBinds :: OutputableBndr id => [HsBindGroup id] -> SDoc +pprBinds b = pprDeeper (vcat (map ppr b)) + +ppr_lexpr :: OutputableBndr id => LHsExpr id -> SDoc +ppr_lexpr e = ppr_expr (unLoc e) ppr_expr (HsVar v) = pprHsVar v ppr_expr (HsIPVar v) = ppr v ppr_expr (HsLit lit) = ppr lit ppr_expr (HsOverLit lit) = ppr lit -ppr_expr (HsLam match) = pprMatch LambdaExpr match +ppr_expr (HsLam match) = pprMatch LambdaExpr (unLoc match) -ppr_expr expr@(HsApp e1 e2) - = let (fun, args) = collect_args expr [] in - (ppr_expr fun) <+> (sep (map pprParendExpr args)) +ppr_expr (HsApp e1 e2) + = let (fun, args) = collect_args e1 [e2] in + (ppr_lexpr fun) <+> (sep (map pprParendExpr args)) where - collect_args (HsApp fun arg) args = collect_args fun (arg:args) - collect_args fun args = (fun, args) + collect_args (L _ (HsApp fun arg)) args = collect_args fun (arg:args) + collect_args fun args = (fun, args) ppr_expr (OpApp e1 op fixity e2) - = case op of + = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where @@ -317,17 +282,17 @@ ppr_expr (OpApp e1 op fixity e2) pp_e2 = pprParendExpr e2 pp_prefixly - = hang (ppr_expr op) 4 (sep [pp_e1, pp_e2]) + = hang (ppr op) 4 (sep [pp_e1, pp_e2]) pp_infixly v = sep [pp_e1, hsep [pprInfix v, pp_e2]] ppr_expr (NegApp e _) = char '-' <+> pprParendExpr e -ppr_expr (HsPar e) = parens (ppr_expr e) +ppr_expr (HsPar e) = parens (ppr_lexpr e) ppr_expr (SectionL expr op) - = case op of + = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where @@ -338,7 +303,7 @@ ppr_expr (SectionL expr op) pp_infixly v = parens (sep [pp_expr, ppr v]) ppr_expr (SectionR op expr) - = case op of + = case unLoc op of HsVar v -> pp_infixly v _ -> pp_prefixly where @@ -349,35 +314,35 @@ ppr_expr (SectionR op expr) pp_infixly v = parens (sep [ppr v, pp_expr]) -ppr_expr (HsCase expr matches _) - = sep [ sep [ptext SLIT("case"), nest 4 (pprExpr expr), ptext SLIT("of")], +ppr_expr (HsCase expr matches) + = sep [ sep [ptext SLIT("case"), nest 4 (ppr expr), ptext SLIT("of")], nest 2 (pprMatches CaseAlt matches) ] -ppr_expr (HsIf e1 e2 e3 _) - = sep [hsep [ptext SLIT("if"), nest 2 (pprExpr e1), ptext SLIT("then")], - nest 4 (pprExpr e2), +ppr_expr (HsIf e1 e2 e3) + = sep [hsep [ptext SLIT("if"), nest 2 (ppr e1), ptext SLIT("then")], + nest 4 (ppr e2), ptext SLIT("else"), - nest 4 (pprExpr e3)] + nest 4 (ppr e3)] -- special case: let ... in let ... -ppr_expr (HsLet binds expr@(HsLet _ _)) +ppr_expr (HsLet binds expr@(L _ (HsLet _ _))) = sep [hang (ptext SLIT("let")) 2 (hsep [pprBinds binds, ptext SLIT("in")]), - ppr_expr expr] + ppr_lexpr expr] ppr_expr (HsLet binds expr) = sep [hang (ptext SLIT("let")) 2 (pprBinds binds), hang (ptext SLIT("in")) 2 (ppr expr)] -ppr_expr (HsDo do_or_list_comp stmts _ _ _) = pprDo do_or_list_comp stmts +ppr_expr (HsDo do_or_list_comp stmts _ _) = pprDo do_or_list_comp stmts ppr_expr (ExplicitList _ exprs) - = brackets (fsep (punctuate comma (map ppr_expr exprs))) + = brackets (fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitPArr _ exprs) - = pa_brackets (fsep (punctuate comma (map ppr_expr exprs))) + = pa_brackets (fsep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (ExplicitTuple exprs boxity) - = tupleParens boxity (sep (punctuate comma (map ppr_expr exprs))) + = tupleParens boxity (sep (punctuate comma (map ppr_lexpr exprs))) ppr_expr (RecordCon con_id rbinds) = pp_rbinds (ppr con_id) rbinds @@ -390,7 +355,7 @@ ppr_expr (RecordUpdOut aexp _ _ rbinds) = pp_rbinds (pprParendExpr aexp) rbinds ppr_expr (ExprWithTySig expr sig) - = hang (nest 2 (ppr_expr expr) <+> dcolon) + = hang (nest 2 (ppr_lexpr expr) <+> dcolon) 4 (ppr sig) ppr_expr (ArithSeqIn info) @@ -414,55 +379,57 @@ ppr_expr (TyLam tyvars expr) = hang (hsep [ptext SLIT("/\\"), hsep (map (pprBndr LambdaBind) tyvars), ptext SLIT("->")]) - 4 (ppr_expr expr) + 4 (ppr_lexpr expr) ppr_expr (TyApp expr [ty]) - = hang (ppr_expr expr) 4 (pprParendType ty) + = hang (ppr_lexpr expr) 4 (pprParendType ty) ppr_expr (TyApp expr tys) - = hang (ppr_expr expr) + = hang (ppr_lexpr expr) 4 (brackets (interpp'SP tys)) ppr_expr (DictLam dictvars expr) = hang (hsep [ptext SLIT("\\{-dict-}"), hsep (map (pprBndr LambdaBind) dictvars), ptext SLIT("->")]) - 4 (ppr_expr expr) + 4 (ppr_lexpr expr) ppr_expr (DictApp expr [dname]) - = hang (ppr_expr expr) 4 (ppr dname) + = hang (ppr_lexpr expr) 4 (ppr dname) ppr_expr (DictApp expr dnames) - = hang (ppr_expr expr) + = hang (ppr_lexpr expr) 4 (brackets (interpp'SP dnames)) ppr_expr (HsType id) = ppr id -ppr_expr (HsSplice n e _) = char '$' <> brackets (ppr n) <> pprParendExpr e -ppr_expr (HsBracket b _) = pprHsBracket b +ppr_expr (HsSplice n e) = char '$' <> brackets (ppr n) <> pprParendExpr e +ppr_expr (HsBracket b) = ppr b ppr_expr (HsBracketOut e ps) = ppr e $$ ptext SLIT("where") <+> ppr ps -ppr_expr (HsProc pat (HsCmdTop cmd _ _ _) _) - = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), pprExpr cmd] +ppr_expr (HsProc pat (L _ (HsCmdTop cmd _ _ _))) + = hsep [ptext SLIT("proc"), ppr pat, ptext SLIT("->"), ppr cmd] -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True _) - = hsep [ppr_expr arrow, ptext SLIT("-<"), ppr_expr arg] -ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False _) - = hsep [ppr_expr arg, ptext SLIT(">-"), ppr_expr arrow] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True _) - = hsep [ppr_expr arrow, ptext SLIT("-<<"), ppr_expr arg] -ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False _) - = hsep [ppr_expr arg, ptext SLIT(">>-"), ppr_expr arrow] +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp True) + = hsep [ppr_lexpr arrow, ptext SLIT("-<"), ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsFirstOrderApp False) + = hsep [ppr_lexpr arg, ptext SLIT(">-"), ppr_lexpr arrow] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp True) + = hsep [ppr_lexpr arrow, ptext SLIT("-<<"), ppr_lexpr arg] +ppr_expr (HsArrApp arrow arg _ HsHigherOrderApp False) + = hsep [ppr_lexpr arg, ptext SLIT(">>-"), ppr_lexpr arrow] -ppr_expr (HsArrForm (HsVar v) (Just _) [arg1, arg2] _) - = sep [pprCmdArg arg1, hsep [pprInfix v, pprCmdArg arg2]] -ppr_expr (HsArrForm op _ args _) - = hang (ptext SLIT("(|") <> ppr_expr op) - 4 (sep (map pprCmdArg args) <> ptext SLIT("|)")) +ppr_expr (HsArrForm (L _ (HsVar v)) (Just _) [arg1, arg2]) + = sep [pprCmdArg (unLoc arg1), hsep [pprInfix v, pprCmdArg (unLoc arg2)]] +ppr_expr (HsArrForm op _ args) + = hang (ptext SLIT("(|") <> ppr_lexpr op) + 4 (sep (map (pprCmdArg.unLoc) args) <> ptext SLIT("|)")) pprCmdArg :: OutputableBndr id => HsCmdTop id -> SDoc -pprCmdArg (HsCmdTop cmd@(HsArrForm _ Nothing [] _) _ _ _) = ppr_expr cmd -pprCmdArg (HsCmdTop cmd _ _ _) = parens (ppr_expr cmd) +pprCmdArg (HsCmdTop cmd@(L _ (HsArrForm _ Nothing [])) _ _ _) + = ppr_lexpr cmd +pprCmdArg (HsCmdTop cmd _ _ _) + = parens (ppr_lexpr cmd) -- Put a var in backquotes if it's not an operator already pprInfix :: Outputable name => name -> SDoc @@ -479,15 +446,14 @@ pa_brackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") Parenthesize unless very simple: \begin{code} -pprParendExpr :: OutputableBndr id => HsExpr id -> SDoc - +pprParendExpr :: OutputableBndr id => LHsExpr id -> SDoc pprParendExpr expr = let - pp_as_was = ppr_expr expr + pp_as_was = ppr_lexpr expr -- Using ppr_expr here avoids the call to 'deeper' -- Not sure if that's always right. in - case expr of + case unLoc expr of HsLit l -> ppr l HsOverLit l -> ppr l @@ -512,6 +478,8 @@ We re-use HsExpr to represent these. \begin{code} type HsCmd id = HsExpr id +type LHsCmd id = LHsExpr id + data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp \end{code} @@ -559,8 +527,10 @@ This may occur inside a proc (where the stack is empty) or as an argument of a command-forming operator. \begin{code} +type LHsCmdTop id = Located (HsCmdTop id) + data HsCmdTop id - = HsCmdTop (HsCmd id) + = HsCmdTop (LHsCmd id) [PostTcType] -- types of inputs on the command's stack PostTcType -- return type of the command (ReboundNames id) @@ -575,18 +545,17 @@ data HsCmdTop id %************************************************************************ \begin{code} -type HsRecordBinds id = [(id, HsExpr id)] +type HsRecordBinds id = [(Located id, LHsExpr id)] recBindFields :: HsRecordBinds id -> [id] -recBindFields rbinds = [field | (field,_) <- rbinds] +recBindFields rbinds = [unLoc field | (field,_) <- rbinds] pp_rbinds :: OutputableBndr id => SDoc -> HsRecordBinds id -> SDoc - pp_rbinds thing rbinds = hang thing 4 (braces (sep (punctuate comma (map (pp_rbind) rbinds)))) where - pp_rbind (v, e) = hsep [pprBndr LetBind v, char '=', ppr e] + pp_rbind (v, e) = hsep [pprBndr LetBind (unLoc v), char '=', ppr e] \end{code} @@ -612,47 +581,41 @@ a function defined by pattern matching must have the same number of patterns in each equation. \begin{code} +type LMatch id = Located (Match id) + data Match id = Match - [Pat id] -- The patterns - (Maybe (HsType id)) -- A type signature for the result of the match + [LPat id] -- The patterns + (Maybe (LHsType id)) -- A type signature for the result of the match -- Nothing after typechecking (GRHSs id) -- GRHSs are used both for pattern bindings and for Matches data GRHSs id - = GRHSs [GRHS id] -- Guarded RHSs - (HsBinds id) -- The where clause + = GRHSs [LGRHS id] -- Guarded RHSs + [HsBindGroup id] -- The where clause PostTcType -- Type of RHS (after type checking) -data GRHS id - = GRHS [Stmt id] -- The RHS is the final ResultStmt - SrcLoc -\end{code} - -@getMatchLoc@ takes a @Match@ and returns the -source-location gotten from the GRHS inside. -THis is something of a nuisance, but no more. +type LGRHS id = Located (GRHS id) -\begin{code} -getMatchLoc :: Match id -> SrcLoc -getMatchLoc (Match _ _ (GRHSs (GRHS _ loc : _) _ _)) = loc +data GRHS id + = GRHS [LStmt id] -- The RHS is the final ResultStmt \end{code} We know the list must have at least one @Match@ in it. \begin{code} -pprMatches :: (OutputableBndr id) => HsMatchContext id -> [Match id] -> SDoc -pprMatches ctxt matches = vcat (map (pprMatch ctxt) matches) +pprMatches :: (OutputableBndr id) => HsMatchContext id -> [LMatch id] -> SDoc +pprMatches ctxt matches = vcat (map (pprMatch ctxt) (map unLoc matches)) -- Exported to HsBinds, which can't see the defn of HsMatchContext -pprFunBind :: (OutputableBndr id) => id -> [Match id] -> SDoc +pprFunBind :: (OutputableBndr id) => id -> [LMatch id] -> SDoc pprFunBind fun matches = pprMatches (FunRhs fun) matches -- Exported to HsBinds, which can't see the defn of HsMatchContext pprPatBind :: (OutputableBndr id) - => Pat id -> GRHSs id -> SDoc + => LPat id -> GRHSs id -> SDoc pprPatBind pat grhss = sep [ppr pat, nest 4 (pprGRHSs PatBindRhs grhss)] @@ -674,28 +637,26 @@ pprMatch ctxt (Match pats maybe_ty grhss) pprGRHSs :: OutputableBndr id => HsMatchContext id -> GRHSs id -> SDoc pprGRHSs ctxt (GRHSs grhss binds ty) - = vcat (map (pprGRHS ctxt) grhss) + = vcat (map (pprGRHS ctxt . unLoc) grhss) $$ - (if nullBinds binds then empty - else text "where" $$ nest 4 (pprDeeper (ppr binds))) - + (if null binds then empty + else text "where" $$ nest 4 (pprBinds binds)) pprGRHS :: OutputableBndr id => HsMatchContext id -> GRHS id -> SDoc -pprGRHS ctxt (GRHS [ResultStmt expr _] locn) +pprGRHS ctxt (GRHS [L _ (ResultStmt expr)]) = pp_rhs ctxt expr -pprGRHS ctxt (GRHS guarded locn) +pprGRHS ctxt (GRHS guarded) = sep [char '|' <+> interpp'SP guards, pp_rhs ctxt expr] where - ResultStmt expr _ = last guarded -- Last stmt should be a ResultStmt for guards - guards = init guarded + ResultStmt expr = unLoc (last guarded) + -- Last stmt should be a ResultStmt for guards + guards = init guarded pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) \end{code} - - %************************************************************************ %* * \subsection{Do stmts and list comprehensions} @@ -703,19 +664,21 @@ pp_rhs ctxt rhs = matchSeparator ctxt <+> pprDeeper (ppr rhs) %************************************************************************ \begin{code} +type LStmt id = Located (Stmt id) + data Stmt id - = BindStmt (Pat id) (HsExpr id) SrcLoc - | LetStmt (HsBinds id) - | ResultStmt (HsExpr id) SrcLoc -- See notes that follow - | ExprStmt (HsExpr id) PostTcType SrcLoc -- See notes that follow + = BindStmt (LPat id) (LHsExpr id) + | LetStmt [HsBindGroup id] + | ResultStmt (LHsExpr id) -- See notes that follow + | ExprStmt (LHsExpr id) PostTcType -- See notes that follow -- The type is the *element type* of the expression -- ParStmts only occur in a list comprehension - | ParStmt [([Stmt id], [id])] -- After remaing, the ids are the binders + | ParStmt [([LStmt id], [id])] -- After remaing, the ids are the binders -- bound by the stmts and used subsequently -- Recursive statement - | RecStmt [Stmt id] + | RecStmt [LStmt id] --- The next two fields are only valid after renaming [id] -- The ids are a subset of the variables bound by the stmts -- that are used in stmts that follow the RecStmt @@ -725,7 +688,7 @@ data Stmt id -- From a type-checking point of view, these ones have to be monomorphic --- This field is only valid after typechecking - [HsExpr id] -- These expressions correspond + [LHsExpr id] -- These expressions correspond -- 1-to-1 with the "recursive" [id], and are the expresions that -- should be returned by the recursion. They may not quite be the -- Ids themselves, because the Id may be *polymorphic*, but @@ -770,35 +733,30 @@ depends on the context. Consider the following contexts: Array comprehensions are handled like list comprehensions -=chak \begin{code} -consLetStmt :: HsBinds id -> [Stmt id] -> [Stmt id] -consLetStmt EmptyBinds stmts = stmts -consLetStmt binds stmts = LetStmt binds : stmts -\end{code} - -\begin{code} instance OutputableBndr id => Outputable (Stmt id) where ppr stmt = pprStmt stmt -pprStmt (BindStmt pat expr _) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] +pprStmt (BindStmt pat expr) = hsep [ppr pat, ptext SLIT("<-"), ppr expr] pprStmt (LetStmt binds) = hsep [ptext SLIT("let"), pprBinds binds] -pprStmt (ExprStmt expr _ _) = ppr expr -pprStmt (ResultStmt expr _) = ppr expr +pprStmt (ExprStmt expr _) = ppr expr +pprStmt (ResultStmt expr) = ppr expr pprStmt (ParStmt stmtss) = hsep (map (\stmts -> ptext SLIT("| ") <> ppr stmts) stmtss) pprStmt (RecStmt segment _ _ _) = ptext SLIT("rec") <+> braces (vcat (map ppr segment)) -pprDo :: OutputableBndr id => HsStmtContext any -> [Stmt id] -> SDoc +pprDo :: OutputableBndr id => HsStmtContext any -> [LStmt id] -> SDoc pprDo DoExpr stmts = hang (ptext SLIT("do")) 2 (vcat (map ppr stmts)) pprDo MDoExpr stmts = hang (ptext SLIT("mdo")) 3 (vcat (map ppr stmts)) pprDo ListComp stmts = pprComp brackets stmts pprDo PArrComp stmts = pprComp pa_brackets stmts -pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [Stmt id] -> SDoc -pprComp brack stmts = brack $ - hang (pprExpr expr <+> char '|') - 4 (interpp'SP quals) - where - ResultStmt expr _ = last stmts -- Last stmt should - quals = init stmts -- be an ResultStmt +pprComp :: OutputableBndr id => (SDoc -> SDoc) -> [LStmt id] -> SDoc +pprComp brack stmts + = brack $ + hang (ppr expr <+> char '|') + 4 (interpp'SP quals) + where + ResultStmt expr = unLoc (last stmts) -- Last stmt should + quals = init stmts -- be an ResultStmt \end{code} %************************************************************************ @@ -808,10 +766,10 @@ pprComp brack stmts = brack $ %************************************************************************ \begin{code} -data HsBracket id = ExpBr (HsExpr id) -- [| expr |] - | PatBr (Pat id) -- [p| pat |] +data HsBracket id = ExpBr (LHsExpr id) -- [| expr |] + | PatBr (LPat id) -- [p| pat |] | DecBr (HsGroup id) -- [d| decls |] - | TypBr (HsType id) -- [t| type |] + | TypBr (LHsType id) -- [t| type |] | VarBr id -- 'x, ''T instance OutputableBndr id => Outputable (HsBracket id) where @@ -840,14 +798,14 @@ thBrackets pp_kind pp_body = char '[' <> pp_kind <> char '|' <+> \begin{code} data ArithSeqInfo id - = From (HsExpr id) - | FromThen (HsExpr id) - (HsExpr id) - | FromTo (HsExpr id) - (HsExpr id) - | FromThenTo (HsExpr id) - (HsExpr id) - (HsExpr id) + = From (LHsExpr id) + | FromThen (LHsExpr id) + (LHsExpr id) + | FromTo (LHsExpr id) + (LHsExpr id) + | FromThenTo (LHsExpr id) + (LHsExpr id) + (LHsExpr id) \end{code} \begin{code} diff --git a/ghc/compiler/hsSyn/HsImpExp.lhs b/ghc/compiler/hsSyn/HsImpExp.lhs index 901396724b..f63d86aec2 100644 --- a/ghc/compiler/hsSyn/HsImpExp.lhs +++ b/ghc/compiler/hsSyn/HsImpExp.lhs @@ -11,7 +11,7 @@ module HsImpExp where import Module ( ModuleName ) import Outputable import FastString -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..) ) import Char ( isAlpha ) \end{code} @@ -23,18 +23,19 @@ import Char ( isAlpha ) One per \tr{import} declaration in a module. \begin{code} +type LImportDecl name = Located (ImportDecl name) + data ImportDecl name - = ImportDecl ModuleName -- module name + = ImportDecl (Located ModuleName) -- module name Bool -- True <=> {-# SOURCE #-} import Bool -- True => qualified (Maybe ModuleName) -- as Module - (Maybe (Bool, [IE name])) -- (True => hiding, names) - SrcLoc + (Maybe (Bool, [LIE name])) -- (True => hiding, names) \end{code} \begin{code} instance (Outputable name) => Outputable (ImportDecl name) where - ppr (ImportDecl mod from qual as spec _) + ppr (ImportDecl mod from qual as spec) = hang (hsep [ptext SLIT("import"), ppr_imp from, pp_qual qual, ppr mod, pp_as as]) 4 (pp_spec spec) @@ -54,7 +55,7 @@ instance (Outputable name) => Outputable (ImportDecl name) where pp_spec (Just (True, spec)) = ptext SLIT("hiding") <+> parens (interpp'SP spec) -ideclName (ImportDecl mod_nm _ _ _ _ _) = mod_nm +ideclName (ImportDecl mod_nm _ _ _ _) = mod_nm \end{code} %************************************************************************ @@ -64,6 +65,8 @@ ideclName (ImportDecl mod_nm _ _ _ _ _) = mod_nm %************************************************************************ \begin{code} +type LIE name = Located (IE name) + data IE name = IEVar name | IEThingAbs name -- Class/Type (can't tell) diff --git a/ghc/compiler/hsSyn/HsLit.lhs b/ghc/compiler/hsSyn/HsLit.lhs index a41d323a47..98406478c9 100644 --- a/ghc/compiler/hsSyn/HsLit.lhs +++ b/ghc/compiler/hsSyn/HsLit.lhs @@ -25,8 +25,8 @@ import Ratio ( Rational ) \begin{code} data HsLit - = HsChar Int -- Character - | HsCharPrim Int -- Unboxed character + = HsChar Char -- Character + | HsCharPrim Char -- Unboxed character | HsString FastString -- String | HsStringPrim FastString -- Packed string | HsInt Integer -- Genuinely an Int; arises from TcGenDeriv, diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 6027377e36..c136ac360f 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -5,7 +5,7 @@ \begin{code} module HsPat ( - Pat(..), InPat, OutPat, + Pat(..), InPat, OutPat, LPat, HsConDetails(..), hsConArgs, @@ -15,6 +15,7 @@ module HsPat ( patsAreAllCons, isConPat, isSigPat, patsAreAllLits, isLitPat, collectPatBinders, collectPatsBinders, + collectLocatedPatBinders, collectLocatedPatsBinders, collectSigTysFromPat, collectSigTysFromPats ) where @@ -25,7 +26,7 @@ import {-# SOURCE #-} HsExpr ( HsExpr ) -- friends: import HsLit ( HsLit(HsCharPrim), HsOverLit ) -import HsTypes ( HsType, SyntaxName, PostTcType ) +import HsTypes ( LHsType, SyntaxName, PostTcType ) import BasicTypes ( Boxity, tupleParens ) -- others: import TysWiredIn ( nilDataCon, charDataCon, charTy ) @@ -33,37 +34,40 @@ import Var ( TyVar ) import DataCon ( DataCon ) import Outputable import Type ( Type ) +import SrcLoc ( Located(..), unLoc, noLoc ) \end{code} \begin{code} -type InPat id = Pat id -- No 'Out' constructors -type OutPat id = Pat id -- No 'In' constructors +type InPat id = LPat id -- No 'Out' constructors +type OutPat id = LPat id -- No 'In' constructors + +type LPat id = Located (Pat id) data Pat id = ------------ Simple patterns --------------- WildPat PostTcType -- Wild card | VarPat id -- Variable - | LazyPat (Pat id) -- Lazy pattern - | AsPat id (Pat id) -- As pattern - | ParPat (Pat id) -- Parenthesised pattern + | LazyPat (LPat id) -- Lazy pattern + | AsPat (Located id) (LPat id) -- As pattern + | ParPat (LPat id) -- Parenthesised pattern ------------ Lists, tuples, arrays --------------- - | ListPat [Pat id] -- Syntactic list + | ListPat [LPat id] -- Syntactic list PostTcType -- The type of the elements - | TuplePat [Pat id] -- Tuple + | TuplePat [LPat id] -- Tuple Boxity -- UnitPat is TuplePat [] - | PArrPat [Pat id] -- Syntactic parallel array + | PArrPat [LPat id] -- Syntactic parallel array PostTcType -- The type of the elements ------------ Constructor patterns --------------- - | ConPatIn id - (HsConDetails id (Pat id)) + | ConPatIn (Located id) + (HsConDetails id (LPat id)) | ConPatOut DataCon - (HsConDetails id (Pat id)) + (HsConDetails id (LPat id)) Type -- The type of the pattern [TyVar] -- Existentially bound type variables [id] -- Ditto dictionaries @@ -86,27 +90,27 @@ data Pat id Type -- Type of pattern, t (HsExpr id) -- Of type t -> Bool; detects match - | NPlusKPatIn id -- n+k pattern + | NPlusKPatIn (Located id) -- n+k pattern HsOverLit -- It'll always be an HsIntegral SyntaxName -- Name of '-' (see RnEnv.lookupSyntaxName) - | NPlusKPatOut id + | NPlusKPatOut (Located id) Integer (HsExpr id) -- Of type t -> Bool; detects match (HsExpr id) -- Of type t -> t; subtracts k ------------ Generics --------------- - | TypePat (HsType id) -- Type pattern for generic definitions + | TypePat (LHsType id) -- Type pattern for generic definitions -- e.g f{| a+b |} = ... -- These show up only in class declarations, -- and should be a top-level pattern ------------ Pattern type signatures --------------- - | SigPatIn (Pat id) -- Pattern with a type signature - (HsType id) + | SigPatIn (LPat id) -- Pattern with a type signature + (LHsType id) - | SigPatOut (Pat id) -- Pattern p + | SigPatOut (LPat id) -- Pattern p Type -- Type, t, of the whole pattern (HsExpr id) -- Coercion function, -- of type t -> typeof(p) @@ -122,7 +126,7 @@ HsConDetails is use both for patterns and for data type declarations \begin{code} data HsConDetails id arg = PrefixCon [arg] -- C p1 p2 p3 - | RecCon [(id, arg)] -- C { x = p1, y = p2 } + | RecCon [(Located id, arg)] -- C { x = p1, y = p2 } | InfixCon arg arg -- p1 `C` p2 hsConArgs :: HsConDetails id arg -> [arg] @@ -155,7 +159,7 @@ pprPat (VarPat var) -- Print with type info if -dppr-debug is on pprPat (WildPat _) = char '_' pprPat (LazyPat pat) = char '~' <> ppr pat pprPat (AsPat name pat) = parens (hcat [ppr name, char '@', ppr pat]) -pprPat (ParPat pat) = parens (pprPat pat) +pprPat (ParPat pat) = parens (ppr pat) pprPat (ListPat pats _) = brackets (interpp'SP pats) pprPat (PArrPat pats _) = pabrackets (interpp'SP pats) @@ -208,13 +212,13 @@ pabrackets p = ptext SLIT("[:") <> p <> ptext SLIT(":]") \begin{code} mkPrefixConPat :: DataCon -> [OutPat id] -> Type -> OutPat id -- Make a vanilla Prefix constructor pattern -mkPrefixConPat dc pats ty = ConPatOut dc (PrefixCon pats) ty [] [] +mkPrefixConPat dc pats ty = noLoc $ ConPatOut dc (PrefixCon pats) ty [] [] mkNilPat :: Type -> OutPat id mkNilPat ty = mkPrefixConPat nilDataCon [] ty -mkCharLitPat :: Int -> OutPat id -mkCharLitPat c = mkPrefixConPat charDataCon [LitPat (HsCharPrim c)] charTy +mkCharLitPat :: Char -> OutPat id +mkCharLitPat c = mkPrefixConPat charDataCon [noLoc $ LitPat (HsCharPrim c)] charTy \end{code} @@ -254,7 +258,7 @@ isWildPat other = False patsAreAllCons :: [Pat id] -> Bool patsAreAllCons pat_list = all isConPat pat_list -isConPat (AsPat _ pat) = isConPat pat +isConPat (AsPat _ pat) = isConPat (unLoc pat) isConPat (ConPatIn _ _) = True isConPat (ConPatOut _ _ _ _ _) = True isConPat (ListPat _ _) = True @@ -270,7 +274,7 @@ isSigPat other = False patsAreAllLits :: [Pat id] -> Bool patsAreAllLits pat_list = all isLitPat pat_list -isLitPat (AsPat _ pat) = isLitPat pat +isLitPat (AsPat _ pat) = isLitPat (unLoc pat) isLitPat (LitPat _) = True isLitPat (NPatIn _ _) = True isLitPat (NPatOut _ _ _) = True @@ -293,24 +297,33 @@ It collects the bounds *value* variables in renamed patterns; type variables are *not* collected. \begin{code} -collectPatBinders :: Pat a -> [a] -collectPatBinders pat = collect pat [] +collectPatBinders :: LPat a -> [a] +collectPatBinders pat = map unLoc (collectLocatedPatBinders pat) + +collectLocatedPatBinders :: LPat a -> [Located a] +collectLocatedPatBinders pat = collectl pat [] + +collectPatsBinders :: [LPat a] -> [a] +collectPatsBinders pats = map unLoc (collectLocatedPatsBinders pats) -collectPatsBinders :: [Pat a] -> [a] -collectPatsBinders pats = foldr collect [] pats +collectLocatedPatsBinders :: [LPat a] -> [Located a] +collectLocatedPatsBinders pats = foldr collectl [] pats + +collectl (L l (VarPat var)) bndrs = L l var : bndrs +collectl pat bndrs = collect (unLoc pat) bndrs collect (WildPat _) bndrs = bndrs -collect (VarPat var) bndrs = var : bndrs -collect (LazyPat pat) bndrs = collect pat bndrs -collect (AsPat a pat) bndrs = a : collect pat bndrs -collect (ParPat pat) bndrs = collect pat bndrs +collect (LazyPat pat) bndrs = collectl pat bndrs +collect (AsPat a pat) bndrs = a : collectl pat bndrs +collect (ParPat pat) bndrs = collectl pat bndrs -collect (ListPat pats _) bndrs = foldr collect bndrs pats -collect (PArrPat pats _) bndrs = foldr collect bndrs pats -collect (TuplePat pats _) bndrs = foldr collect bndrs pats +collect (ListPat pats _) bndrs = foldr collectl bndrs pats +collect (PArrPat pats _) bndrs = foldr collectl bndrs pats +collect (TuplePat pats _) bndrs = foldr collectl bndrs pats -collect (ConPatIn c ps) bndrs = foldr collect bndrs (hsConArgs ps) -collect (ConPatOut c ps _ _ ds) bndrs = ds ++ foldr collect bndrs (hsConArgs ps) +collect (ConPatIn c ps) bndrs = foldr collectl bndrs (hsConArgs ps) +collect (ConPatOut c ps _ _ ds) bndrs = map noLoc ds + ++ foldr collectl bndrs (hsConArgs ps) collect (LitPat _) bndrs = bndrs collect (NPatIn _ _) bndrs = bndrs @@ -319,29 +332,31 @@ collect (NPatOut _ _ _) bndrs = bndrs collect (NPlusKPatIn n _ _) bndrs = n : bndrs collect (NPlusKPatOut n _ _ _) bndrs = n : bndrs -collect (SigPatIn pat _) bndrs = collect pat bndrs -collect (SigPatOut pat _ _) bndrs = collect pat bndrs +collect (SigPatIn pat _) bndrs = collectl pat bndrs +collect (SigPatOut pat _ _) bndrs = collectl pat bndrs collect (TypePat ty) bndrs = bndrs -collect (DictPat ids1 ids2) bndrs = ids1 ++ ids2 ++ bndrs +collect (DictPat ids1 ids2) bndrs = map noLoc ids1 ++ map noLoc ids2 + ++ bndrs \end{code} \begin{code} -collectSigTysFromPats :: [InPat name] -> [HsType name] -collectSigTysFromPats pats = foldr collect_pat [] pats +collectSigTysFromPats :: [InPat name] -> [LHsType name] +collectSigTysFromPats pats = foldr collect_lpat [] pats + +collectSigTysFromPat :: InPat name -> [LHsType name] +collectSigTysFromPat pat = collect_lpat pat [] -collectSigTysFromPat :: InPat name -> [HsType name] -collectSigTysFromPat pat = collect_pat pat [] +collect_lpat pat acc = collect_pat (unLoc pat) acc -collect_pat (SigPatIn pat ty) acc = collect_pat pat (ty:acc) +collect_pat (SigPatIn pat ty) acc = collect_lpat pat (ty:acc) collect_pat (TypePat ty) acc = ty:acc -collect_pat (LazyPat pat) acc = collect_pat pat acc -collect_pat (AsPat a pat) acc = collect_pat pat acc -collect_pat (ParPat pat) acc = collect_pat pat acc -collect_pat (ListPat pats _) acc = foldr collect_pat acc pats -collect_pat (PArrPat pats _) acc = foldr collect_pat acc pats -collect_pat (TuplePat pats _) acc = foldr collect_pat acc pats -collect_pat (ConPatIn c ps) acc = foldr collect_pat acc (hsConArgs ps) +collect_pat (LazyPat pat) acc = collect_lpat pat acc +collect_pat (AsPat a pat) acc = collect_lpat pat acc +collect_pat (ParPat pat) acc = collect_lpat pat acc +collect_pat (ListPat pats _) acc = foldr collect_lpat acc pats +collect_pat (PArrPat pats _) acc = foldr collect_lpat acc pats +collect_pat (TuplePat pats _) acc = foldr collect_lpat acc pats +collect_pat (ConPatIn c ps) acc = foldr collect_lpat acc (hsConArgs ps) collect_pat other acc = acc -- Literals, vars, wildcard \end{code} - diff --git a/ghc/compiler/hsSyn/HsSyn.lhs b/ghc/compiler/hsSyn/HsSyn.lhs index c996f22772..7255d1b7f6 100644 --- a/ghc/compiler/hsSyn/HsSyn.lhs +++ b/ghc/compiler/hsSyn/HsSyn.lhs @@ -16,13 +16,14 @@ module HsSyn ( module HsLit, module HsPat, module HsTypes, + module HsUtils, Fixity, NewOrData, HsModule(..), HsExtCore(..), - collectStmtsBinders, collectStmtBinders, - collectHsBinders, collectLocatedHsBinders, - collectMonoBinders, collectLocatedMonoBinders, - collectSigTysFromHsBinds, collectSigTysFromMonoBinds + collectStmtsBinders, collectStmtBinders, collectLStmtBinders, + collectGroupBinders, collectHsBindLocatedBinders, + collectHsBindBinders, + collectSigTysFromHsBind, collectSigTysFromHsBinds ) where #include "HsVersions.h" @@ -37,30 +38,31 @@ import HsPat import HsTypes import HscTypes ( DeprecTxt ) import BasicTypes ( Fixity, NewOrData ) +import HsUtils -- others: import IfaceSyn ( IfaceBinding ) import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), unLoc, noLoc ) import Module ( Module ) +import Bag ( Bag, foldrBag ) \end{code} All we actually declare here is the top-level structure for a module. \begin{code} data HsModule name = HsModule - (Maybe Module) -- Nothing => "module X where" is omitted + (Maybe (Located Module))-- Nothing => "module X where" is omitted -- (in which case the next field is Nothing too) - (Maybe [IE name]) -- Export list; Nothing => export list omitted, so export everything + (Maybe [LIE name]) -- Export list; Nothing => export list omitted, so export everything -- Just [] => export *nothing* -- Just [...] => as you would expect... - [ImportDecl name] -- We snaffle interesting stuff out of the + [LImportDecl name] -- We snaffle interesting stuff out of the -- imported interfaces early on, adding that -- info to TyDecls/etc; so this list is -- often empty, downstream. - [HsDecl name] -- Type, class, value, and interface signature decls + [LHsDecl name] -- Type, class, value, and interface signature decls (Maybe DeprecTxt) -- reason/explanation for deprecation of this module - SrcLoc data HsExtCore name -- Read from Foo.hcr = HsExtCore @@ -74,17 +76,17 @@ data HsExtCore name -- Read from Foo.hcr instance (OutputableBndr name) => Outputable (HsModule name) where - ppr (HsModule Nothing _ imports decls _ src_loc) + ppr (HsModule Nothing _ imports decls _) = pp_nonnull imports $$ pp_nonnull decls - ppr (HsModule (Just name) exports imports decls deprec src_loc) + ppr (HsModule (Just name) exports imports decls deprec) = vcat [ case exports of Nothing -> pp_header (ptext SLIT("where")) Just es -> vcat [ - pp_header lparen, - nest 8 (fsep (punctuate comma (map ppr es))), - nest 4 (ptext SLIT(") where")) + pp_header lparen, + nest 8 (fsep (punctuate comma (map ppr es))), + nest 4 (ptext SLIT(") where")) ], pp_nonnull imports, pp_nonnull decls @@ -121,41 +123,30 @@ where it should return @[x, y, f, a, b]@ (remember, order important). \begin{code} -collectLocatedHsBinders :: HsBinds name -> [(name,SrcLoc)] --- Used at top level only; so no need for an IPBinds case -collectLocatedHsBinders EmptyBinds = [] -collectLocatedHsBinders (MonoBind b _ _) - = collectLocatedMonoBinders b -collectLocatedHsBinders (ThenBinds b1 b2) - = collectLocatedHsBinders b1 ++ collectLocatedHsBinders b2 - -collectHsBinders :: HsBinds name -> [name] -collectHsBinders EmptyBinds = [] -collectHsBinders (IPBinds _) = [] -- Implicit parameters don't create - -- ordinary bindings -collectHsBinders (MonoBind b _ _) = collectMonoBinders b -collectHsBinders (ThenBinds b1 b2) = collectHsBinders b1 ++ collectHsBinders b2 - -collectLocatedMonoBinders :: MonoBinds name -> [(name,SrcLoc)] -collectLocatedMonoBinders binds - = go binds [] - where - go EmptyMonoBinds acc = acc - go (PatMonoBind pat _ loc) acc = map (\v->(v,loc)) (collectPatBinders pat) ++ acc - go (FunMonoBind f _ _ loc) acc = (f,loc) : acc - go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) - -collectMonoBinders :: MonoBinds name -> [name] -collectMonoBinders binds - = go binds [] - where - go EmptyMonoBinds acc = acc - go (PatMonoBind pat _ loc) acc = collectPatBinders pat ++ acc - go (FunMonoBind f _ _ loc) acc = f : acc - go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) - go (VarMonoBind v _) acc = v : acc - go (AbsBinds _ _ dbinds _ binds) acc - = [dp | (_,dp,_) <- dbinds] ++ go binds acc +collectGroupBinders :: [HsBindGroup name] -> [Located name] +collectGroupBinders groups = foldr collect_group [] groups + where + collect_group (HsBindGroup bag sigs is_rec) acc + = foldrBag (collectAcc . unLoc) acc bag + collect_group (HsIPBinds _) acc = acc + + +collectAcc :: HsBind name -> [Located name] -> [Located name] +collectAcc (PatBind pat _) acc = collectLocatedPatBinders pat ++ acc +collectAcc (FunBind f _ _) acc = f : acc +collectAcc (VarBind f _) acc = noLoc f : acc +collectAcc (AbsBinds _ _ dbinds _ binds) acc + = [noLoc dp | (_,dp,_) <- dbinds] ++ acc + -- ++ foldr collectAcc acc binds + -- I don't think we want the binders from the nested binds + -- The only time we collect binders from a typechecked + -- binding (hence see AbsBinds) is in zonking in TcHsSyn + +collectHsBindBinders :: Bag (LHsBind name) -> [name] +collectHsBindBinders binds = map unLoc (collectHsBindLocatedBinders binds) + +collectHsBindLocatedBinders :: Bag (LHsBind name) -> [Located name] +collectHsBindLocatedBinders binds = foldrBag (collectAcc . unLoc) [] binds \end{code} @@ -168,42 +159,36 @@ collectMonoBinders binds Get all the pattern type signatures out of a bunch of bindings \begin{code} -collectSigTysFromHsBinds :: HsBinds name -> [HsType name] -collectSigTysFromHsBinds EmptyBinds = [] -collectSigTysFromHsBinds (IPBinds _) = [] -collectSigTysFromHsBinds (MonoBind b _ _) = collectSigTysFromMonoBinds b -collectSigTysFromHsBinds (ThenBinds b1 b2) = collectSigTysFromHsBinds b1 ++ - collectSigTysFromHsBinds b2 - - -collectSigTysFromMonoBinds :: MonoBinds name -> [HsType name] -collectSigTysFromMonoBinds bind - = go bind [] +collectSigTysFromHsBinds :: [LHsBind name] -> [LHsType name] +collectSigTysFromHsBinds binds = concat (map collectSigTysFromHsBind binds) + +collectSigTysFromHsBind :: LHsBind name -> [LHsType name] +collectSigTysFromHsBind bind + = go (unLoc bind) where - go EmptyMonoBinds acc = acc - go (PatMonoBind pat _ loc) acc = collectSigTysFromPat pat ++ acc - go (FunMonoBind f _ ms loc) acc = go_matches ms acc - go (AndMonoBinds bs1 bs2) acc = go bs1 (go bs2 acc) + go (PatBind pat _) = collectSigTysFromPat pat + go (FunBind f _ ms) = go_matches (map unLoc ms) -- A binding like x :: a = f y -- is parsed as FunMonoBind, but for this purpose we -- want to treat it as a pattern binding - go_matches [] acc = acc - go_matches (Match [] (Just sig) _ : matches) acc = sig : go_matches matches acc - go_matches (match : matches) acc = go_matches matches acc + go_matches [] = [] + go_matches (Match [] (Just sig) _ : matches) = sig : go_matches matches + go_matches (match : matches) = go_matches matches \end{code} \begin{code} -collectStmtsBinders :: [Stmt id] -> [id] -collectStmtsBinders = concatMap collectStmtBinders +collectStmtsBinders :: [LStmt id] -> [Located id] +collectStmtsBinders = concatMap collectLStmtBinders -collectStmtBinders :: Stmt id -> [id] +collectLStmtBinders = collectStmtBinders . unLoc + +collectStmtBinders :: Stmt id -> [Located id] -- Id Binders for a Stmt... [but what about pattern-sig type vars]? -collectStmtBinders (BindStmt pat _ _) = collectPatBinders pat -collectStmtBinders (LetStmt binds) = collectHsBinders binds -collectStmtBinders (ExprStmt _ _ _) = [] -collectStmtBinders (ResultStmt _ _) = [] +collectStmtBinders (BindStmt pat _) = collectLocatedPatBinders pat +collectStmtBinders (LetStmt binds) = collectGroupBinders binds +collectStmtBinders (ExprStmt _ _) = [] +collectStmtBinders (ResultStmt _) = [] collectStmtBinders (RecStmt ss _ _ _) = collectStmtsBinders ss collectStmtBinders other = panic "collectStmtBinders" \end{code} - diff --git a/ghc/compiler/hsSyn/HsTypes.lhs b/ghc/compiler/hsSyn/HsTypes.lhs index 85a5682106..da941ef706 100644 --- a/ghc/compiler/hsSyn/HsTypes.lhs +++ b/ghc/compiler/hsSyn/HsTypes.lhs @@ -5,22 +5,25 @@ \begin{code} module HsTypes ( - HsType(..), HsTyVarBndr(..), HsExplicitForAll(..), - , HsContext, HsPred(..) - - , mkExplicitHsForAllTy, mkImplicitHsForAllTy, - , mkHsDictTy, mkHsIParamTy - , hsTyVarName, hsTyVarNames, replaceTyVarName - , splitHsInstDeclTy + HsType(..), LHsType, + HsTyVarBndr(..), LHsTyVarBndr, + HsExplicitForAll(..), + HsContext, LHsContext, + HsPred(..), LHsPred, + + mkExplicitHsForAllTy, mkImplicitHsForAllTy, + hsTyVarName, hsTyVarNames, replaceTyVarName, + hsLTyVarName, hsLTyVarNames, hsLTyVarLocName, hsLTyVarLocNames, + splitHsInstDeclTy, -- Type place holder - , PostTcType, placeHolderType, + PostTcType, placeHolderType, -- Name place holder - , SyntaxName, placeHolderName, + SyntaxName, placeHolderName, -- Printing - , pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr + pprParendHsType, pprHsForAll, pprHsContext, ppr_hs_context, pprHsTyVarBndr ) where #include "HsVersions.h" @@ -31,7 +34,7 @@ import Name ( Name, mkInternalName ) import OccName ( mkVarOcc ) import BasicTypes ( IPName, Boxity, tupleParens ) import PrelNames ( unboundKey ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, Located(..), unLoc, noSrcSpan ) import CmdLineOpts ( opt_PprStyle_Debug ) import Outputable \end{code} @@ -75,38 +78,44 @@ placeHolderName = mkInternalName unboundKey This is the syntax for types as seen in type signatures. \begin{code} -type HsContext name = [HsPred name] +type LHsContext name = Located (HsContext name) + +type HsContext name = [LHsPred name] + +type LHsPred name = Located (HsPred name) + +data HsPred name = HsClassP name [LHsType name] + | HsIParam (IPName name) (LHsType name) -data HsPred name = HsClassP name [HsType name] - | HsIParam (IPName name) (HsType name) +type LHsType name = Located (HsType name) data HsType name = HsForAllTy HsExplicitForAll -- Renamer leaves this flag unchanged, to record the way -- the user wrote it originally, so that the printer can -- print it as the user wrote it - [HsTyVarBndr name] -- With ImplicitForAll, this is the empty list + [LHsTyVarBndr name] -- With ImplicitForAll, this is the empty list -- until the renamer fills in the variables - (HsContext name) - (HsType name) + (LHsContext name) + (LHsType name) | HsTyVar name -- Type variable or type constructor - | HsAppTy (HsType name) - (HsType name) + | HsAppTy (LHsType name) + (LHsType name) - | HsFunTy (HsType name) -- function type - (HsType name) + | HsFunTy (LHsType name) -- function type + (LHsType name) - | HsListTy (HsType name) -- Element type + | HsListTy (LHsType name) -- Element type - | HsPArrTy (HsType name) -- Elem. type of parallel array: [:t:] + | HsPArrTy (LHsType name) -- Elem. type of parallel array: [:t:] | HsTupleTy Boxity - [HsType name] -- Element types (length gives arity) + [LHsType name] -- Element types (length gives arity) - | HsOpTy (HsType name) name (HsType name) + | HsOpTy (LHsType name) (Located name) (LHsType name) - | HsParTy (HsType name) + | HsParTy (LHsType name) -- Parenthesis preserved for the precedence re-arrangement in RnTypes -- It's important that a * (b + c) doesn't get rearranged to (a*b) + c! -- @@ -116,10 +125,12 @@ data HsType name | HsNumTy Integer -- Generics only - -- these next two are only used in interfaces - | HsPredTy (HsPred name) + | HsPredTy (LHsPred name) -- Only used in the type of an instance + -- declaration, eg. Eq [a] -> Eq a + -- ^^^^ + -- HsPredTy - | HsKindSig (HsType name) -- (ty :: kind) + | HsKindSig (LHsType name) -- (ty :: kind) Kind -- A type with a kind signature data HsExplicitForAll = Explicit | Implicit @@ -137,22 +148,21 @@ data HsExplicitForAll = Explicit | Implicit mkImplicitHsForAllTy ctxt ty = mkHsForAllTy Implicit [] ctxt ty mkExplicitHsForAllTy tvs ctxt ty = mkHsForAllTy Explicit tvs ctxt ty -mkHsForAllTy :: HsExplicitForAll -> [HsTyVarBndr name] -> HsContext name -> HsType name -> HsType name +mkHsForAllTy :: HsExplicitForAll -> [LHsTyVarBndr name] -> LHsContext name -> LHsType name -> HsType name -- Smart constructor for HsForAllTy -mkHsForAllTy exp tvs [] ty = mk_forall_ty exp tvs ty +mkHsForAllTy exp tvs (L _ []) ty = mk_forall_ty exp tvs ty mkHsForAllTy exp tvs ctxt ty = HsForAllTy exp tvs ctxt ty -- mk_forall_ty makes a pure for-all type (no context) -mk_forall_ty Explicit [] ty = ty -- Explicit for-all with no tyvars -mk_forall_ty exp tvs (HsParTy ty) = mk_forall_ty exp tvs ty -mk_forall_ty exp1 tvs1 (HsForAllTy exp2 tvs2 ctxt ty) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty -mk_forall_ty exp tvs ty = HsForAllTy exp tvs [] ty +mk_forall_ty Explicit [] ty = unLoc ty -- Explicit for-all with no tyvars +mk_forall_ty exp tvs (L _ (HsParTy ty)) = mk_forall_ty exp tvs ty +mk_forall_ty exp1 tvs1 (L _ (HsForAllTy exp2 tvs2 ctxt ty)) = mkHsForAllTy (exp1 `plus` exp2) (tvs1 ++ tvs2) ctxt ty +mk_forall_ty exp tvs ty = HsForAllTy exp tvs (L noSrcSpan []) ty Implicit `plus` Implicit = Implicit exp1 `plus` exp2 = Explicit -mkHsDictTy cls tys = HsPredTy (HsClassP cls tys) -mkHsIParamTy v ty = HsPredTy (HsIParam v ty) +type LHsTyVarBndr name = Located (HsTyVarBndr name) data HsTyVarBndr name = UserTyVar name @@ -161,11 +171,25 @@ data HsTyVarBndr name -- for-alls in it, (mostly to do with dictionaries). These -- must be explicitly Kinded. +hsTyVarName :: HsTyVarBndr name -> name hsTyVarName (UserTyVar n) = n hsTyVarName (KindedTyVar n _) = n +hsLTyVarName :: LHsTyVarBndr name -> name +hsLTyVarName = hsTyVarName . unLoc + +hsTyVarNames :: [HsTyVarBndr name] -> [name] hsTyVarNames tvs = map hsTyVarName tvs +hsLTyVarNames :: [LHsTyVarBndr name] -> [name] +hsLTyVarNames = map hsLTyVarName + +hsLTyVarLocName :: LHsTyVarBndr name -> Located name +hsLTyVarLocName = fmap hsTyVarName + +hsLTyVarLocNames :: [LHsTyVarBndr name] -> [Located name] +hsLTyVarLocNames = map hsLTyVarLocName + replaceTyVarName :: HsTyVarBndr name1 -> name2 -> HsTyVarBndr name2 replaceTyVarName (UserTyVar n) n' = UserTyVar n' replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k @@ -176,7 +200,7 @@ replaceTyVarName (KindedTyVar n k) n' = KindedTyVar n' k splitHsInstDeclTy :: Outputable name => HsType name - -> ([HsTyVarBndr name], HsContext name, name, [HsType name]) + -> ([LHsTyVarBndr name], HsContext name, name, [LHsType name]) -- Split up an instance decl type, returning the pieces -- In interface files, the instance declaration head is created @@ -195,19 +219,19 @@ splitHsInstDeclTy inst_ty = case inst_ty of HsForAllTy _ tvs cxt1 tau -- The type vars should have been -- computed by now, even if they were implicit - -> (tvs, cxt1++cxt2, cls, tys) + -> (tvs, unLoc cxt1 ++ cxt2, cls, tys) where - (cxt2, cls, tys) = split_tau tau + (cxt2, cls, tys) = split_tau (unLoc tau) other -> ([], cxt2, cls, tys) where (cxt2, cls, tys) = split_tau inst_ty where - split_tau (HsFunTy (HsPredTy p) ty) = (p:ps, cls, tys) + split_tau (HsFunTy (L _ (HsPredTy p)) ty) = (p:ps, cls, tys) where - (ps, cls, tys) = split_tau ty - split_tau (HsPredTy (HsClassP cls tys)) = ([], cls,tys) + (ps, cls, tys) = split_tau (unLoc ty) + split_tau (HsPredTy (L _ (HsClassP cls tys))) = ([], cls, tys) split_tau other = pprPanic "splitHsInstDeclTy" (ppr inst_ty) \end{code} @@ -230,7 +254,7 @@ instance (Outputable name) => Outputable (HsTyVarBndr name) where ppr (KindedTyVar name kind) = pprHsTyVarBndr name kind instance Outputable name => Outputable (HsPred name) where - ppr (HsClassP clas tys) = ppr clas <+> hsep (map pprParendHsType tys) + ppr (HsClassP clas tys) = ppr clas <+> hsep (map (pprParendHsType.unLoc) tys) ppr (HsIParam n ty) = hsep [ppr n, dcolon, ppr ty] pprHsTyVarBndr :: Outputable name => name -> Kind -> SDoc @@ -238,8 +262,8 @@ pprHsTyVarBndr name kind | kind `eqKind` liftedTypeKind = ppr name | otherwise = hsep [ppr name, dcolon, pprParendKind kind] pprHsForAll exp tvs cxt - | show_forall = forall_part <+> pprHsContext cxt - | otherwise = pprHsContext cxt + | show_forall = forall_part <+> pprHsContext (unLoc cxt) + | otherwise = pprHsContext (unLoc cxt) where show_forall = opt_PprStyle_Debug || (not (null tvs) && is_explicit) @@ -280,40 +304,42 @@ pprParendHsType ty = ppr_mono_ty pREC_CON ty -- (a) Remove outermost HsParTy parens -- (b) Drop top-level for-all type variables in user style -- since they are implicit in Haskell -prepare sty (HsParTy ty) = prepare sty ty +prepare sty (HsParTy ty) = prepare sty (unLoc ty) prepare sty ty = ty +ppr_mono_lty ctxt_prec ty = ppr_mono_ty ctxt_prec (unLoc ty) + ppr_mono_ty ctxt_prec (HsForAllTy exp tvs ctxt ty) = maybeParen ctxt_prec pREC_FUN $ - sep [pprHsForAll exp tvs ctxt, ppr_mono_ty pREC_TOP ty] + sep [pprHsForAll exp tvs ctxt, ppr_mono_lty pREC_TOP ty] ppr_mono_ty ctxt_prec (HsTyVar name) = ppr name ppr_mono_ty ctxt_prec (HsFunTy ty1 ty2) = ppr_fun_ty ctxt_prec ty1 ty2 ppr_mono_ty ctxt_prec (HsTupleTy con tys) = tupleParens con (interpp'SP tys) -ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_ty pREC_TOP ty <+> dcolon <+> pprKind kind) -ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_ty pREC_TOP ty) -ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_ty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsKindSig ty kind) = parens (ppr_mono_lty pREC_TOP ty <+> dcolon <+> pprKind kind) +ppr_mono_ty ctxt_prec (HsListTy ty) = brackets (ppr_mono_lty pREC_TOP ty) +ppr_mono_ty ctxt_prec (HsPArrTy ty) = pabrackets (ppr_mono_lty pREC_TOP ty) ppr_mono_ty ctxt_prec (HsPredTy pred) = braces (ppr pred) ppr_mono_ty ctxt_prec (HsNumTy n) = integer n -- generics only ppr_mono_ty ctxt_prec (HsAppTy fun_ty arg_ty) = maybeParen ctxt_prec pREC_CON $ - hsep [ppr_mono_ty pREC_FUN fun_ty, ppr_mono_ty pREC_CON arg_ty] + hsep [ppr_mono_lty pREC_FUN fun_ty, ppr_mono_lty pREC_CON arg_ty] ppr_mono_ty ctxt_prec (HsOpTy ty1 op ty2) = maybeParen ctxt_prec pREC_OP $ - ppr_mono_ty pREC_OP ty1 <+> ppr op <+> ppr_mono_ty pREC_OP ty2 + ppr_mono_lty pREC_OP ty1 <+> ppr op <+> ppr_mono_lty pREC_OP ty2 ppr_mono_ty ctxt_prec (HsParTy ty) - = parens (ppr_mono_ty pREC_TOP ty) + = parens (ppr_mono_lty pREC_TOP ty) -- Put the parens in where the user did -- But we still use the precedence stuff to add parens because -- toHsType doesn't put in any HsParTys, so we may still need them -------------------------- ppr_fun_ty ctxt_prec ty1 ty2 - = let p1 = ppr_mono_ty pREC_FUN ty1 - p2 = ppr_mono_ty pREC_TOP ty2 + = let p1 = ppr_mono_lty pREC_FUN ty1 + p2 = ppr_mono_lty pREC_TOP ty2 in maybeParen ctxt_prec pREC_FUN $ sep [p1, ptext SLIT("->") <+> p2] diff --git a/ghc/compiler/iface/LoadIface.lhs b/ghc/compiler/iface/LoadIface.lhs index be77d8f281..d05d3ae960 100644 --- a/ghc/compiler/iface/LoadIface.lhs +++ b/ghc/compiler/iface/LoadIface.lhs @@ -60,7 +60,7 @@ import SrcLoc ( mkSrcLoc, importedSrcLoc ) import Maybes ( isJust, mapCatMaybes ) import StringBuffer ( hGetStringBuffer ) import FastString ( mkFastString ) -import ErrUtils ( Message ) +import ErrUtils ( Message, mkLocMessage ) import Finder ( findModule, findPackageModule, hiBootExt, hiBootVerExt ) import Lexer @@ -556,7 +556,7 @@ read_iface dflags wanted_mod file_path is_hi_boot_file Left exn -> return (Left (text (showException exn))) ; Right buffer -> case unP parseIface (mkPState buffer loc dflags) of - PFailed loc1 loc2 err -> return (Left (showPFailed loc1 loc2 err)) + PFailed span err -> return (Left (mkLocMessage span err)) POk _ iface | wanted_mod == actual_mod -> return (Right iface) | otherwise -> return (Left err) diff --git a/ghc/compiler/iface/TcIface.lhs b/ghc/compiler/iface/TcIface.lhs index 071948bde4..8c45b69220 100644 --- a/ghc/compiler/iface/TcIface.lhs +++ b/ghc/compiler/iface/TcIface.lhs @@ -29,7 +29,7 @@ import HscTypes ( ExternalPackageState(..), PackageInstEnv, PackageRuleBase, HscEnv, TyThing(..), implicitTyThings, typeEnvIds, ModIface(..), ModDetails(..), InstPool, ModGuts, TypeEnv, mkTypeEnv, extendTypeEnvList, lookupTypeEnv, - DeclPool, RulePool, Pool(..), Gated, addRuleToPool ) + RulePool, Pool(..) ) import InstEnv ( extendInstEnv ) import CoreSyn import PprCore ( pprIdRules ) diff --git a/ghc/compiler/main/CmdLineOpts.lhs b/ghc/compiler/main/CmdLineOpts.lhs index 5faf8ac672..cedf8cc82d 100644 --- a/ghc/compiler/main/CmdLineOpts.lhs +++ b/ghc/compiler/main/CmdLineOpts.lhs @@ -82,6 +82,7 @@ module CmdLineOpts ( opt_UF_DearOp, -- misc opts + opt_ErrorSpans, opt_InPackage, opt_EmitCExternDecls, opt_EnsureSplittableC, @@ -801,6 +802,9 @@ opt_UF_DearOp = ( 4 :: Int) opt_Static = lookUp FSLIT("-static") opt_Unregisterised = lookUp FSLIT("-funregisterised") opt_EmitExternalCore = lookUp FSLIT("-fext-core") + +-- Include full span info in error messages, instead of just the start position. +opt_ErrorSpans = lookUp FSLIT("-ferror-spans") \end{code} %************************************************************************ @@ -842,7 +846,8 @@ isStaticHscFlag f = "fext-core", "frule-check", "frules-off", - "fcpr-off" + "fcpr-off", + "ferror-spans" ] || any (flip prefixMatch f) [ "fcontext-stack", diff --git a/ghc/compiler/main/ErrUtils.lhs b/ghc/compiler/main/ErrUtils.lhs index fa34674cbf..ecad68951a 100644 --- a/ghc/compiler/main/ErrUtils.lhs +++ b/ghc/compiler/main/ErrUtils.lhs @@ -5,15 +5,13 @@ \begin{code} module ErrUtils ( - ErrMsg, WarnMsg, Message, - Messages, errorsFound, emptyMessages, - - addShortErrLocLine, addShortWarnLocLine, - addErrLocHdrLine, + Message, mkLocMessage, printError, + ErrMsg, WarnMsg, + Messages, errorsFound, emptyMessages, + mkErrMsg, mkWarnMsg, printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings, - printError, ghcExit, doIfSet, doIfSet_dyn, dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or, mkDumpDoc, @@ -23,62 +21,55 @@ module ErrUtils ( #include "HsVersions.h" import Bag ( Bag, bagToList, isEmptyBag, emptyBag ) -import SrcLoc ( SrcLoc, noSrcLoc, isGoodSrcLoc ) +import SrcLoc ( SrcSpan ) import Util ( sortLt ) import Outputable import qualified Pretty -import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt ) +import SrcLoc ( srcSpanStart ) +import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt, + opt_ErrorSpans ) import List ( replicate ) import System ( ExitCode(..), exitWith ) -import IO ( hPutStr, hPutStrLn, stderr, stdout ) +import IO ( hPutStr, stderr, stdout ) \end{code} -\begin{code} -type MsgWithLoc = (SrcLoc, Pretty.Doc) - -- The SrcLoc is used for sorting errors into line-number order - -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic - -- whether to qualify an External Name) at the error occurrence +Basic error messages: just render a message with a source location. -type ErrMsg = MsgWithLoc -type WarnMsg = MsgWithLoc +\begin{code} type Message = SDoc -addShortErrLocLine :: SrcLoc -> PrintUnqualified -> Message -> ErrMsg -addShortWarnLocLine :: SrcLoc -> PrintUnqualified -> Message -> WarnMsg - -- Used heavily by renamer/typechecker - -- Be refined about qualification, return an ErrMsg +mkLocMessage :: SrcSpan -> Message -> Message +mkLocMessage locn msg + | opt_ErrorSpans = hang (ppr locn <> colon) 4 msg + | otherwise = hang (ppr (srcSpanStart locn) <> colon) 4 msg + -- always print the location, even if it is unhelpful. Error messages + -- are supposed to be in a standard format, and one without a location + -- would look strange. Better to say explicitly "<no location info>". -addErrLocHdrLine :: SrcLoc -> Message -> Message -> Message - -- Used by Lint and other system stuff - -- Always print qualified, return a Message +printError :: SrcSpan -> Message -> IO () +printError span msg = printErrs (mkLocMessage span msg $ defaultErrStyle) +\end{code} -addShortErrLocLine locn print_unqual msg - = (locn, doc (mkErrStyle print_unqual)) - where - doc = mkErrDoc locn msg +Collecting up messages for later ordering and printing. -addShortWarnLocLine locn print_unqual msg - = (locn, doc (mkErrStyle print_unqual)) - where - doc = mkWarnDoc locn msg +\begin{code} +data ErrMsg = ErrMsg SrcSpan Pretty.Doc + -- The SrcSpan is used for sorting errors into line-number order + -- NB Pretty.Doc not SDoc: we deal with the printing style (in ptic + -- whether to qualify an External Name) at the error occurrence -addErrLocHdrLine locn hdr msg - = mkErrDoc locn (hdr $$ msg) +type WarnMsg = ErrMsg -mkErrDoc locn msg - | isGoodSrcLoc locn = hang (ppr locn <> colon) 4 msg - | otherwise = msg - -mkWarnDoc locn msg = mkErrDoc locn msg -\end{code} +-- These two are used heavily by renamer/typechecker. +-- Be refined about qualification, return an ErrMsg +mkErrMsg :: SrcSpan -> PrintUnqualified -> Message -> ErrMsg +mkErrMsg locn print_unqual msg + = ErrMsg locn (mkLocMessage locn msg $ mkErrStyle print_unqual) -\begin{code} -printError :: String -> IO () -printError str = hPutStrLn stderr str -\end{code} +mkWarnMsg :: SrcSpan -> PrintUnqualified -> Message -> WarnMsg +mkWarnMsg = mkErrMsg -\begin{code} type Messages = (Bag WarnMsg, Bag ErrMsg) emptyMessages :: Messages @@ -103,12 +94,12 @@ printErrorsAndWarnings (warns, errs) pprBagOfErrors :: Bag ErrMsg -> Pretty.Doc pprBagOfErrors bag_of_errors - = Pretty.vcat [Pretty.text "" Pretty.$$ p | (_,p) <- sorted_errs ] + = Pretty.vcat [Pretty.text "" Pretty.$$ e | ErrMsg _ e <- sorted_errs ] where bag_ls = bagToList bag_of_errors sorted_errs = sortLt occ'ed_before bag_ls - occ'ed_before (a,_) (b,_) = LT == compare a b + occ'ed_before (ErrMsg l1 _) (ErrMsg l2 _) = LT == compare l1 l2 pprBagOfWarnings :: Bag WarnMsg -> Pretty.Doc pprBagOfWarnings bag_of_warns = pprBagOfErrors bag_of_warns diff --git a/ghc/compiler/main/HscMain.lhs b/ghc/compiler/main/HscMain.lhs index c1fa0c44f9..0c7bb28327 100644 --- a/ghc/compiler/main/HscMain.lhs +++ b/ghc/compiler/main/HscMain.lhs @@ -16,8 +16,7 @@ module HscMain ( #include "HsVersions.h" #ifdef GHCI -import HsSyn ( Stmt(..) ) -import TcHsSyn ( TypecheckedHsExpr ) +import HsSyn ( Stmt(..), LStmt, LHsExpr ) import IfaceSyn ( IfaceDecl ) import CodeOutput ( outputForeignStubs ) import ByteCodeGen ( byteCodeGen, coreExprToBCOs ) @@ -26,12 +25,12 @@ import TidyPgm ( tidyCoreExpr ) import CorePrep ( corePrepExpr ) import Flattening ( flattenExpr ) import TcRnDriver ( tcRnStmt, tcRnExpr, tcRnThing ) -import RdrHsSyn ( RdrNameStmt ) -import RdrName ( GlobalRdrEnv ) +import RdrName ( RdrName, GlobalRdrEnv ) import Type ( Type ) import PrelNames ( iNTERACTIVE ) import StringBuffer ( stringToStringBuffer ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, Located(..) ) +import Var ( Id ) import Name ( Name ) import CoreLint ( lintUnfolding ) import DsMeta ( templateHaskellNames ) @@ -40,7 +39,7 @@ import BasicTypes ( Fixity ) import StringBuffer ( hGetStringBuffer ) import Parser -import Lexer ( P(..), ParseResult(..), mkPState, showPFailed ) +import Lexer ( P(..), ParseResult(..), mkPState ) import SrcLoc ( mkSrcLoc ) import TcRnDriver ( tcRnModule, tcRnExtCore ) import TcIface ( typecheckIface ) @@ -62,7 +61,7 @@ import CodeOutput ( codeOutput ) import CmdLineOpts import DriverPhases ( isExtCoreFilename ) -import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass ) +import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printError ) import UniqSupply ( mkSplitUniqSupply ) import Outputable @@ -425,8 +424,8 @@ myParseModule dflags src_filename case unP parseModule (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); - return Nothing }; + PFailed span err -> do { printError span err ; + return Nothing }; POk _ rdr_module -> do { @@ -524,7 +523,7 @@ hscTcExpr -- Typecheck an expression (but don't run it) hscTcExpr hsc_env icontext expr = do { maybe_stmt <- hscParseStmt (hsc_dflags hsc_env) expr ; case maybe_stmt of { - Just (ExprStmt expr _ _) + Just (L _ (ExprStmt expr _)) -> tcRnExpr hsc_env icontext expr ; Just other -> do { hPutStrLn stderr ("not an expression: `" ++ expr ++ "'") ; return Nothing } ; @@ -532,7 +531,7 @@ hscTcExpr hsc_env icontext expr \end{code} \begin{code} -hscParseStmt :: DynFlags -> String -> IO (Maybe RdrNameStmt) +hscParseStmt :: DynFlags -> String -> IO (Maybe (LStmt RdrName)) hscParseStmt dflags str = do showPass dflags "Parser" _scc_ "Parser" do @@ -543,8 +542,8 @@ hscParseStmt dflags str case unP parseStmt (mkPState buf loc dflags) of { - PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); - return Nothing }; + PFailed span err -> do { printError span err; + return Nothing }; -- no stmt: the line consisted of just space or comments POk _ Nothing -> return Nothing; @@ -577,7 +576,7 @@ hscThing hsc_env ic str = do maybe_rdr_name <- myParseIdentifier (hsc_dflags hsc_env) str case maybe_rdr_name of { Nothing -> return []; - Just rdr_name -> do + Just (L _ rdr_name) -> do maybe_tc_result <- tcRnThing hsc_env ic rdr_name @@ -592,8 +591,8 @@ myParseIdentifier dflags str let loc = mkSrcLoc FSLIT("<interactive>") 1 0 case unP parseIdentifier (mkPState buf loc dflags) of - PFailed l1 l2 err -> do { hPutStrLn stderr (showSDoc (showPFailed l1 l2 err)); - return Nothing } + PFailed span err -> do { printError span err; + return Nothing } POk _ rdr_name -> return (Just rdr_name) #endif @@ -609,7 +608,7 @@ myParseIdentifier dflags str #ifdef GHCI compileExpr :: HscEnv -> Module -> GlobalRdrEnv -> TypeEnv - -> TypecheckedHsExpr + -> LHsExpr Id -> IO HValue compileExpr hsc_env this_mod rdr_env type_env tc_expr diff --git a/ghc/compiler/main/HscStats.lhs b/ghc/compiler/main/HscStats.lhs index e830170f58..cb3c70fa83 100644 --- a/ghc/compiler/main/HscStats.lhs +++ b/ghc/compiler/main/HscStats.lhs @@ -10,7 +10,9 @@ module HscStats ( ppSourceStats ) where import HsSyn import Outputable +import SrcLoc ( unLoc, Located(..) ) import Char ( isSpace ) +import Bag ( bagToList ) import Util ( count ) \end{code} @@ -21,7 +23,7 @@ import Util ( count ) %************************************************************************ \begin{code} -ppSourceStats short (HsModule _ exports imports decls _ src_loc) +ppSourceStats short (L _ (HsModule _ exports imports ldecls _)) = (if short then hcat else vcat) (map pp_val [("ExportAll ", export_all), -- 1 if no export list @@ -56,6 +58,8 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) ("SpecialisedBinds ", bind_specs) ]) where + decls = map unLoc ldecls + pp_val (str, 0) = empty pp_val (str, n) | not short = hcat [text str, int n] @@ -78,13 +82,13 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) real_exports = case exports of { Nothing -> []; Just es -> es } n_exports = length real_exports - export_ms = count (\ e -> case e of { IEModuleContents{} -> True;_ -> False}) + export_ms = count (\ e -> case unLoc e of { IEModuleContents{} -> True;_ -> False}) real_exports export_ds = n_exports - export_ms export_all = case exports of { Nothing -> 1; other -> 0 } (val_bind_ds, fn_bind_ds) - = foldr add2 (0,0) (map count_monobinds val_decls) + = foldr add2 (0,0) (map count_bind val_decls) (import_no, import_qual, import_as, import_all, import_partial, import_hiding) = foldr add6 (0,0,0,0,0,0) (map import_info imports) @@ -95,21 +99,19 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) (inst_method_ds, method_specs, method_inlines) = foldr add3 (0,0,0) (map inst_info inst_decls) - count_monobinds EmptyMonoBinds = (0,0) - count_monobinds (AndMonoBinds b1 b2) = count_monobinds b1 `add2` count_monobinds b2 - count_monobinds (PatMonoBind (VarPat n) r _) = (1,0) - count_monobinds (PatMonoBind p r _) = (0,1) - count_monobinds (FunMonoBind f _ m _) = (0,1) + count_bind (PatBind (L _ (VarPat n)) r) = (1,0) + count_bind (PatBind p r) = (0,1) + count_bind (FunBind f _ m) = (0,1) count_sigs sigs = foldr add4 (0,0,0,0) (map sig_info sigs) - sig_info (FixSig _) = (1,0,0,0) - sig_info (Sig _ _ _) = (0,1,0,0) - sig_info (SpecSig _ _ _) = (0,0,1,0) - sig_info (InlineSig _ _ _ _) = (0,0,0,1) - sig_info _ = (0,0,0,0) + sig_info (FixSig _) = (1,0,0,0) + sig_info (Sig _ _) = (0,1,0,0) + sig_info (SpecSig _ _) = (0,0,1,0) + sig_info (InlineSig _ _ _) = (0,0,0,1) + sig_info _ = (0,0,0,0) - import_info (ImportDecl _ _ qual as spec _) + import_info (L _ (ImportDecl _ _ qual as spec)) = add6 (1, qual_info qual, as_info as, 0,0,0) (spec_info spec) qual_info False = 0 qual_info True = 1 @@ -120,19 +122,20 @@ ppSourceStats short (HsModule _ exports imports decls _ src_loc) spec_info (Just (True, _)) = (0,0,0,0,0,1) data_info (TyData {tcdCons = cs, tcdDerivs = derivs}) - = (length cs, case derivs of {Nothing -> 0; Just ds -> length ds}) + = (length cs, case derivs of Nothing -> 0 + Just ds -> length (unLoc ds)) data_info other = (0,0) class_info decl@(ClassDecl {}) - = case count_sigs (tcdSigs decl) of + = case count_sigs (map unLoc (tcdSigs decl)) of (_,classops,_,_) -> - (classops, addpr (count_monobinds (tcdMeths decl))) + (classops, addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList (tcdMeths decl))))) class_info other = (0,0) - inst_info (InstDecl _ inst_meths inst_sigs _) - = case count_sigs inst_sigs of + inst_info (InstDecl _ inst_meths inst_sigs) + = case count_sigs (map unLoc inst_sigs) of (_,_,ss,is) -> - (addpr (count_monobinds inst_meths), ss, is) + (addpr (foldr add2 (0,0) (map (count_bind.unLoc) (bagToList inst_meths))), ss, is) addpr :: (Int,Int) -> Int add2 :: (Int,Int) -> (Int,Int) -> (Int, Int) diff --git a/ghc/compiler/main/HscTypes.lhs b/ghc/compiler/main/HscTypes.lhs index 113c386434..c57551bf26 100644 --- a/ghc/compiler/main/HscTypes.lhs +++ b/ghc/compiler/main/HscTypes.lhs @@ -93,7 +93,7 @@ import CoreSyn ( IdCoreRule ) import PrelNames ( isBuiltInSyntaxName ) import Maybes ( orElse ) import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcSpan ) import UniqSupply ( UniqSupply ) import Maybe ( fromJust ) import FastString ( FastString ) @@ -629,7 +629,7 @@ emptyIfaceFixCache n = defaultFixity type FixityEnv = NameEnv FixItem -- We keep the OccName in the range so that we can generate an interface from it -data FixItem = FixItem OccName Fixity SrcLoc +data FixItem = FixItem OccName Fixity SrcSpan instance Outputable FixItem where ppr (FixItem occ fix loc) = ppr fix <+> ppr occ <+> parens (ppr loc) diff --git a/ghc/compiler/main/ParsePkgConf.y b/ghc/compiler/main/ParsePkgConf.y index abbbcea1eb..beb6e540e7 100644 --- a/ghc/compiler/main/ParsePkgConf.y +++ b/ghc/compiler/main/ParsePkgConf.y @@ -8,6 +8,7 @@ import Lexer import CmdLineOpts import FastString import StringBuffer +import ErrUtils ( mkLocMessage ) import SrcLoc import Outputable import Panic ( GhcException(..) ) @@ -16,20 +17,20 @@ import EXCEPTION ( throwDyn ) } %token - '{' { T _ _ ITocurly } - '}' { T _ _ ITccurly } - '[' { T _ _ ITobrack } - ']' { T _ _ ITcbrack } - ',' { T _ _ ITcomma } - '=' { T _ _ ITequal } - VARID { T _ _ (ITvarid $$) } - CONID { T _ _ (ITconid $$) } - STRING { T _ _ (ITstring $$) } + '{' { L _ ITocurly } + '}' { L _ ITccurly } + '[' { L _ ITobrack } + ']' { L _ ITcbrack } + ',' { L _ ITcomma } + '=' { L _ ITequal } + VARID { L _ (ITvarid $$) } + CONID { L _ (ITconid $$) } + STRING { L _ (ITstring $$) } %monad { P } { >>= } { return } -%lexer { lexer } { T _ _ ITeof } +%lexer { lexer } { L _ ITeof } %name parse -%tokentype { Token } +%tokentype { Located Token } %% pkgconf :: { [ PackageConfig ] } @@ -98,8 +99,8 @@ loadPackageConfig conf_filename = do buf <- hGetStringBuffer conf_filename let loc = mkSrcLoc (mkFastString conf_filename) 1 0 case unP parse (mkPState buf loc defaultDynFlags) of - PFailed l1 l2 err -> - throwDyn (InstallationError (showSDoc (showPFailed l1 l2 err))) + PFailed span err -> + throwDyn (InstallationError (showSDoc (mkLocMessage span err))) POk _ pkg_details -> do return pkg_details diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 784b2c1181..4a53f1437f 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -38,6 +38,8 @@ import Name ( NamedThing(..) ) import CmdLineOpts ( opt_EnsureSplittableC ) import Outputable ( assertPanic ) +import Char ( ord ) + -- DEBUGGING ONLY --import TRACE ( trace ) --import Outputable ( showSDoc ) @@ -448,7 +450,7 @@ be tuned.) \begin{code} intTag :: Literal -> Integer - intTag (MachChar c) = toInteger c + intTag (MachChar c) = toInteger (ord c) intTag (MachInt i) = i intTag (MachWord w) = intTag (word2IntLit (MachWord w)) intTag _ = panic "intTag" diff --git a/ghc/compiler/nativeGen/StixPrim.lhs b/ghc/compiler/nativeGen/StixPrim.lhs index ed6d9da074..8df78124b2 100644 --- a/ghc/compiler/nativeGen/StixPrim.lhs +++ b/ghc/compiler/nativeGen/StixPrim.lhs @@ -29,6 +29,7 @@ import Outputable import Util ( notNull ) import FastString import FastTypes +import Char #include "NCG.h" \end{code} @@ -160,7 +161,7 @@ amodeToStix (CLbl lbl _) = StCLbl lbl amodeToStix (CCharLike (CLit (MachChar c))) = StIndex Word8Rep cHARLIKE_closure (StInt (toInteger off)) where - off = charLikeSize * (c - mIN_CHARLIKE) + off = charLikeSize * (ord c - mIN_CHARLIKE) amodeToStix (CCharLike x) = panic "amodeToStix.CCharLike" @@ -175,7 +176,7 @@ amodeToStix (CIntLike x) amodeToStix (CLit core) = case core of - MachChar c -> StInt (toInteger c) + MachChar c -> StInt (toInteger (ord c)) MachStr s -> StString s MachNullAddr -> StInt 0 MachInt i -> StInt i diff --git a/ghc/compiler/parser/Lexer.x b/ghc/compiler/parser/Lexer.x index bb32d631b3..05537a92b0 100644 --- a/ghc/compiler/parser/Lexer.x +++ b/ghc/compiler/parser/Lexer.x @@ -22,15 +22,14 @@ { module Lexer ( - Token(..), Token__(..), lexer, mkPState, showPFailed, - P(..), ParseResult(..), setSrcLocFor, getSrcLoc, - failLocMsgP, srcParseFail, + Token(..), lexer, mkPState, + P(..), ParseResult(..), getSrcLoc, + failMsgP, failLocMsgP, failSpanMsgP, srcParseFail, popContext, pushCurrentContext, ) where #include "HsVersions.h" -import ForeignCall ( Safety(..) ) import ErrUtils ( Message ) import Outputable import StringBuffer @@ -45,7 +44,7 @@ import Util ( maybePrefixMatch ) import DATA_BITS import Char import Ratio -import TRACE +--import TRACE } $whitechar = [\ \t\n\r\f\v\xa0] @@ -299,9 +298,7 @@ unsafeAt arr i = arr ! i -- ----------------------------------------------------------------------------- -- The token type -data Token = T SrcLoc{-start-} SrcLoc{-end-} Token__ - -data Token__ +data Token = ITas -- Haskell keywords | ITcase | ITclass @@ -442,7 +439,7 @@ data Token__ deriving Show -- debugging #endif -isSpecial :: Token__ -> Bool +isSpecial :: Token -> Bool -- If we see M.x, where x is a keyword, but -- is special, we treat is as just plain M.x, -- not as a keyword. @@ -544,39 +541,39 @@ reservedSymsFM = listToUFM $ -- ----------------------------------------------------------------------------- -- Lexer actions -type Action = SrcLoc -> SrcLoc -> StringBuffer -> Int -> P Token +type Action = SrcSpan -> StringBuffer -> Int -> P (Located Token) -special :: Token__ -> Action -special tok loc end _buf len = return (T loc end tok) +special :: Token -> Action +special tok span _buf len = return (L span tok) -token, layout_token :: Token__ -> Action -token t loc end buf len = return (T loc end t) -layout_token t loc end buf len = pushLexState layout >> return (T loc end t) +token, layout_token :: Token -> Action +token t span buf len = return (L span t) +layout_token t span buf len = pushLexState layout >> return (L span t) -idtoken :: (StringBuffer -> Int -> Token__) -> Action -idtoken f loc end buf len = return (T loc end $! (f buf len)) +idtoken :: (StringBuffer -> Int -> Token) -> Action +idtoken f span buf len = return (L span $! (f buf len)) -skip_one_varid :: (FastString -> Token__) -> Action -skip_one_varid f loc end buf len - = return (T loc end $! f (lexemeToFastString (stepOn buf) (len-1))) +skip_one_varid :: (FastString -> Token) -> Action +skip_one_varid f span buf len + = return (L span $! f (lexemeToFastString (stepOn buf) (len-1))) -strtoken :: (String -> Token__) -> Action -strtoken f loc end buf len = - return (T loc end $! (f $! lexemeToString buf len)) +strtoken :: (String -> Token) -> Action +strtoken f span buf len = + return (L span $! (f $! lexemeToString buf len)) -init_strtoken :: Int -> (String -> Token__) -> Action +init_strtoken :: Int -> (String -> Token) -> Action -- like strtoken, but drops the last N character(s) -init_strtoken drop f loc end buf len = - return (T loc end $! (f $! lexemeToString buf (len-drop))) +init_strtoken drop f span buf len = + return (L span $! (f $! lexemeToString buf (len-drop))) begin :: Int -> Action -begin code _loc _end _str _len = do pushLexState code; lexToken +begin code _span _str _len = do pushLexState code; lexToken pop :: Action -pop _loc _end _buf _len = do popLexState; lexToken +pop _span _buf _len = do popLexState; lexToken pop_and :: Action -> Action -pop_and act loc end buf len = do popLexState; act loc end buf len +pop_and act span buf len = do popLexState; act span buf len notFollowedBy char _ _ _ (_,buf) = atEnd buf || currentChar buf /= char @@ -590,7 +587,7 @@ ifExtension pred bits _ _ _ = pred bits using regular expressions. -} nested_comment :: Action -nested_comment loc _end _str _len = do +nested_comment span _str _len = do input <- getInput go 1 input where go 0 input = do setInput input; lexToken @@ -611,21 +608,22 @@ nested_comment loc _end _str _len = do Just (c,input) -> go n input c -> go n input - err input = do failLocMsgP loc (fst input) "unterminated `{-'" + err input = do failLocMsgP (srcSpanStart span) (fst input) + "unterminated `{-'" open_brace, close_brace :: Action -open_brace loc end _str _len = do +open_brace span _str _len = do ctx <- getContext setContext (NoLayout:ctx) - return (T loc end ITocurly) -close_brace loc end _str _len = do + return (L span ITocurly) +close_brace span _str _len = do popContext - return (T loc end ITccurly) + return (L span ITccurly) -- We have to be careful not to count M.<varid> as a qualified name -- when <varid> is a keyword. We hack around this by catching -- the offending tokens afterward, and re-lexing in a different state. -check_qvarid loc end buf len = do +check_qvarid span buf len = do case lookupUFM reservedWordsFM var of Just (keyword,exts) | not (isSpecial keyword) -> @@ -638,10 +636,10 @@ check_qvarid loc end buf len = do _other -> return token where (mod,var) = splitQualName buf len - token = T loc end (ITqvarid (mod,var)) + token = L span (ITqvarid (mod,var)) try_again = do - setInput (loc,buf) + setInput (srcSpanStart span,buf) pushLexState bad_qvarid lexToken @@ -670,17 +668,17 @@ splitQualName orig_buf len = split orig_buf 0 0 (lexemeToFastString orig_buf dot_off, lexemeToFastString (stepOnBy (dot_off+1) orig_buf) (len - dot_off -1)) -varid loc end buf len = +varid span buf len = case lookupUFM reservedWordsFM fs of Just (keyword,0) -> do maybe_layout keyword - return (T loc end keyword) + return (L span keyword) Just (keyword,exts) -> do b <- extension (\i -> exts .&. i /= 0) if b then do maybe_layout keyword - return (T loc end keyword) - else return (T loc end (ITvarid fs)) - _other -> return (T loc end (ITvarid fs)) + return (L span keyword) + else return (L span (ITvarid fs)) + _other -> return (L span (ITvarid fs)) where fs = lexemeToFastString buf len @@ -693,34 +691,34 @@ qconsym buf len = ITqconsym $! splitQualName buf len varsym = sym ITvarsym consym = sym ITconsym -sym con loc end buf len = +sym con span buf len = case lookupUFM reservedSymsFM fs of - Just (keyword,0) -> return (T loc end keyword) + Just (keyword,0) -> return (L span keyword) Just (keyword,exts) -> do b <- extension (\i -> exts .&. i /= 0) - if b then return (T loc end keyword) - else return (T loc end $! con fs) - _other -> return (T loc end $! con fs) + if b then return (L span keyword) + else return (L span $! con fs) + _other -> return (L span $! con fs) where fs = lexemeToFastString buf len -tok_decimal loc end buf len - = return (T loc end (ITinteger $! parseInteger buf len 10 oct_or_dec)) +tok_decimal span buf len + = return (L span (ITinteger $! parseInteger buf len 10 oct_or_dec)) -tok_octal loc end buf len - = return (T loc end (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 8 oct_or_dec)) +tok_octal span buf len + = return (L span (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 8 oct_or_dec)) -tok_hexadecimal loc end buf len - = return (T loc end (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 16 hex)) +tok_hexadecimal span buf len + = return (L span (ITinteger $! parseInteger (stepOnBy 2 buf) (len-2) 16 hex)) -prim_decimal loc end buf len - = return (T loc end (ITprimint $! parseInteger buf (len-1) 10 oct_or_dec)) +prim_decimal span buf len + = return (L span (ITprimint $! parseInteger buf (len-1) 10 oct_or_dec)) -prim_octal loc end buf len - = return (T loc end (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 8 oct_or_dec)) +prim_octal span buf len + = return (L span (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 8 oct_or_dec)) -prim_hexadecimal loc end buf len - = return (T loc end (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 16 hex)) +prim_hexadecimal span buf len + = return (L span (ITprimint $! parseInteger (stepOnBy 2 buf) (len-3) 16 hex)) tok_float str = ITrational $! readRational__ str prim_float str = ITprimfloat $! readRational__ str @@ -737,18 +735,18 @@ parseInteger buf len radix to_int -- we're at the first token on a line, insert layout tokens if necessary do_bol :: Action -do_bol loc end _str _len = do - pos <- getOffside end +do_bol span _str _len = do + pos <- getOffside (srcSpanEnd span) case pos of LT -> do --trace "layout: inserting '}'" $ do popContext -- do NOT pop the lex state, we might have a ';' to insert - return (T loc end ITvccurly) + return (L span ITvccurly) EQ -> do --trace "layout: inserting ';'" $ do popLexState - return (T loc end ITsemi) + return (L span ITsemi) GT -> do popLexState lexToken @@ -772,9 +770,9 @@ maybe_layout _ = return () -- by a 'do', then we allow the new context to be at the same indentation as -- the previous context. This is what the 'strict' argument is for. -- -new_layout_context strict loc end _buf _len = do +new_layout_context strict span _buf _len = do popLexState - let offset = srcLocCol loc + let offset = srcSpanStartCol span ctx <- getContext case ctx of Layout prev_off : _ | @@ -783,32 +781,32 @@ new_layout_context strict loc end _buf _len = do -- token is indented to the left of the previous context. -- we must generate a {} sequence now. pushLexState layout_left - return (T loc end ITvocurly) + return (L span ITvocurly) other -> do setContext (Layout offset : ctx) - return (T loc end ITvocurly) + return (L span ITvocurly) -do_layout_left loc end _buf _len = do +do_layout_left span _buf _len = do popLexState pushLexState bol -- we must be at the start of a line - return (T loc end ITvccurly) + return (L span ITvccurly) -- ----------------------------------------------------------------------------- -- LINE pragmas set_line :: Int -> Action -set_line code loc end buf len = do +set_line code span buf len = do let line = parseInteger buf len 10 oct_or_dec - setSrcLoc (mkSrcLoc (srcLocFile end) (fromIntegral line - 1) 0) + setSrcLoc (mkSrcLoc (srcSpanFile span) (fromIntegral line - 1) 0) -- subtract one: the line number refers to the *following* line popLexState pushLexState code lexToken set_file :: Int -> Action -set_file code loc end buf len = do +set_file code span buf len = do let file = lexemeToFastString (stepOn buf) (len-2) - setSrcLoc (mkSrcLoc file (srcLocLine end) (srcLocCol end)) + setSrcLoc (mkSrcLoc file (srcSpanEndLine span) (srcSpanEndCol span)) popLexState pushLexState code lexToken @@ -819,12 +817,12 @@ set_file code loc end buf len = do -- This stuff is horrible. I hates it. lex_string_tok :: Action -lex_string_tok loc end buf len = do +lex_string_tok span buf len = do tok <- lex_string "" end <- getSrcLoc - return (T loc end tok) + return (L (mkSrcSpan (srcSpanStart span) end) tok) -lex_string :: String -> P Token__ +lex_string :: String -> P Token lex_string s = do i <- getInput case alexGetChar i of @@ -860,14 +858,6 @@ lex_string s = do c <- lex_char lex_string (c:s) -lex_char :: P Char -lex_char = do - mc <- getCharOrFail - case mc of - '\\' -> lex_escape - c | is_any c -> return c - _other -> lit_error - lex_stringgap s = do c <- getCharOrFail case c of @@ -883,8 +873,9 @@ lex_char_tok :: Action -- but WIHTOUT CONSUMING the x or T part (the parser does that). -- So we have to do two characters of lookahead: when we see 'x we need to -- see if there's a trailing quote -lex_char_tok loc _end buf len = do -- We've seen ' +lex_char_tok span buf len = do -- We've seen ' i1 <- getInput -- Look ahead to first character + let loc = srcSpanStart span case alexGetChar i1 of Nothing -> lit_error @@ -892,7 +883,7 @@ lex_char_tok loc _end buf len = do -- We've seen ' th_exts <- extension thEnabled if th_exts then do setInput i2 - return (T loc end2 ITtyQuote) + return (L (mkSrcSpan loc end2) ITtyQuote) else lit_error Just ('\\', i2@(end2,_)) -> do -- We've seen 'backslash @@ -915,23 +906,31 @@ lex_char_tok loc _end buf len = do -- We've seen ' _other -> do -- We've seen 'x not followed by quote -- If TH is on, just parse the quote only th_exts <- extension thEnabled - if th_exts then return (T loc (fst i1) ITvarQuote) + if th_exts then return (L (mkSrcSpan loc (fst i1)) ITvarQuote) else lit_error -finish_char_tok :: SrcLoc -> Char -> P Token +finish_char_tok :: SrcLoc -> Char -> P (Located Token) finish_char_tok loc ch -- We've already seen the closing quote -- Just need to check for trailing # = do glaexts <- extension glaExtsEnabled + i@(end,_) <- getInput if glaexts then do - i@(end,_) <- getInput case alexGetChar i of Just ('#',i@(end,_)) -> do setInput i - return (T loc end (ITprimchar ch)) + return (L (mkSrcSpan loc end) (ITprimchar ch)) _other -> - return (T loc end (ITchar ch)) - else do end <- getSrcLoc - return (T loc end (ITchar ch)) + return (L (mkSrcSpan loc end) (ITchar ch)) + else do + return (L (mkSrcSpan loc end) (ITchar ch)) + +lex_char :: P Char +lex_char = do + mc <- getCharOrFail + case mc of + '\\' -> lex_escape + c | is_any c -> return c + _other -> lit_error lex_escape :: P Char lex_escape = do @@ -1115,17 +1114,15 @@ data LayoutContext data ParseResult a = POk PState a | PFailed - SrcLoc SrcLoc -- The start and end of the text span related to + SrcSpan -- The start and end of the text span related to -- the error. Might be used in environments which can -- show this span, e.g. by highlighting it. Message -- The error message -showPFailed loc1 loc2 err = hcat [ppr loc1, text ": ", err] - data PState = PState { buffer :: StringBuffer, - last_loc :: SrcLoc, -- pos of previous token - last_len :: !Int, -- len of previous token + last_loc :: SrcSpan, -- pos of previous token + last_len :: !Int, -- len of previous token loc :: SrcLoc, -- current loc (end of prev token + 1) extsBitmap :: !Int, -- bitmap that determines permitted extensions context :: [LayoutContext], @@ -1147,17 +1144,20 @@ returnP a = P $ \s -> POk s a thenP :: P a -> (a -> P b) -> P b (P m) `thenP` k = P $ \ s -> case m s of - POk s1 a -> (unP (k a)) s1 - PFailed l1 l2 err -> PFailed l1 l2 err + POk s1 a -> (unP (k a)) s1 + PFailed span err -> PFailed span err failP :: String -> P a -failP msg = P $ \s -> PFailed (last_loc s) (loc s) (text msg) +failP msg = P $ \s -> PFailed (last_loc s) (text msg) failMsgP :: String -> P a -failMsgP msg = P $ \s -> PFailed (last_loc s) (loc s) (text msg) +failMsgP msg = P $ \s -> PFailed (last_loc s) (text msg) failLocMsgP :: SrcLoc -> SrcLoc -> String -> P a -failLocMsgP loc1 loc2 str = P $ \s -> PFailed loc1 loc2 (text str) +failLocMsgP loc1 loc2 str = P $ \s -> PFailed (mkSrcSpan loc1 loc2) (text str) + +failSpanMsgP :: SrcSpan -> String -> P a +failSpanMsgP span msg = P $ \s -> PFailed span (text msg) extension :: (Int -> Bool) -> P Bool extension p = P $ \s -> POk s (p $! extsBitmap s) @@ -1168,18 +1168,10 @@ getExts = P $ \s -> POk s (extsBitmap s) setSrcLoc :: SrcLoc -> P () setSrcLoc new_loc = P $ \s -> POk s{loc=new_loc} () --- tmp, for supporting stuff in RdrHsSyn. The scope better not include --- any calls to the lexer, because it assumes things about the SrcLoc. -setSrcLocFor :: SrcLoc -> P a -> P a -setSrcLocFor new_loc scope = P $ \s@PState{ loc = old_loc } -> - case unP scope s{loc=new_loc} of - PFailed l1 l2 msg -> PFailed l1 l2 msg - POk _ r -> POk s r - getSrcLoc :: P SrcLoc getSrcLoc = P $ \s@(PState{ loc=loc }) -> POk s loc -setLastToken :: SrcLoc -> Int -> P () +setLastToken :: SrcSpan -> Int -> P () setLastToken loc len = P $ \s -> POk s{ last_loc=loc, last_len=len } () type AlexInput = (SrcLoc,StringBuffer) @@ -1236,7 +1228,7 @@ mkPState :: StringBuffer -> SrcLoc -> DynFlags -> PState mkPState buf loc flags = PState { buffer = buf, - last_loc = loc, + last_loc = mkSrcSpan loc loc, last_len = 0, loc = loc, extsBitmap = fromIntegral bitmap, @@ -1267,14 +1259,14 @@ popContext = P $ \ s@(PState{ buffer = buf, context = ctx, loc = loc, last_len = len, last_loc = last_loc }) -> case ctx of (_:tl) -> POk s{ context = tl } () - [] -> PFailed last_loc loc (srcParseErr buf len) + [] -> PFailed last_loc (srcParseErr buf len) -- Push a new layout context at the indentation of the last token read. -- This is only used at the outer level of a module when the 'module' -- keyword is missing. pushCurrentContext :: P () pushCurrentContext = P $ \ s@PState{ last_loc=loc, context=ctx } -> - POk s{ context = Layout (srcLocCol loc) : ctx} () + POk s{ context = Layout (srcSpanStartCol loc) : ctx} () getOffside :: SrcLoc -> P Ordering getOffside loc = P $ \s@PState{context=stk} -> @@ -1304,7 +1296,7 @@ srcParseErr buf len srcParseFail :: P a srcParseFail = P $ \PState{ buffer = buf, last_len = len, last_loc = last_loc, loc = loc } -> - PFailed last_loc loc (srcParseErr buf len) + PFailed last_loc (srcParseErr buf len) -- A lexical error is reported at a particular position in the source file, -- not over a token range. TODO: this is slightly wrong, because we record @@ -1313,32 +1305,35 @@ srcParseFail = P $ \PState{ buffer = buf, last_len = len, lexError :: String -> P a lexError str = do loc <- getSrcLoc - failLocMsgP loc loc str + i@(end,_) <- getInput + failLocMsgP loc end str -- ----------------------------------------------------------------------------- -- This is the top-level function: called from the parser each time a -- new token is to be read from the input. -lexer :: (Token -> P a) -> P a +lexer :: (Located Token -> P a) -> P a lexer cont = do - tok@(T _ _ tok__) <- lexToken + tok@(L _ tok__) <- lexToken --trace ("token: " ++ show tok__) $ do cont tok -lexToken :: P Token +lexToken :: P (Located Token) lexToken = do inp@(loc1,buf) <- getInput sc <- getLexState exts <- getExts case alexScanUser exts inp sc of - AlexEOF -> do setLastToken loc1 0 - return (T loc1 loc1 ITeof) + AlexEOF -> do let span = mkSrcSpan loc1 loc1 + setLastToken span 0 + return (L span ITeof) AlexError (loc2,_) -> do failLocMsgP loc1 loc2 "lexical error" AlexSkip inp2 _ -> do setInput inp2 lexToken AlexToken inp2@(end,buf2) len t -> do setInput inp2 - setLastToken loc1 len - t loc1 end buf len + let span = mkSrcSpan loc1 end + span `seq` setLastToken span len + t span buf len } diff --git a/ghc/compiler/parser/Parser.y b/ghc/compiler/parser/Parser.y deleted file mode 100644 index 965863abb9..0000000000 --- a/ghc/compiler/parser/Parser.y +++ /dev/null @@ -1,1423 +0,0 @@ -{- -*-haskell-*- ------------------------------------------------------------------------------ -$Id: Parser.y,v 1.131 2003/11/27 13:26:39 simonmar Exp $ - -Haskell grammar. - -Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 ------------------------------------------------------------------------------ --} - -{ -module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where - -#include "HsVersions.h" - -import HsSyn -import RdrHsSyn -import HscTypes ( ModIface, IsBootInterface, DeprecTxt ) -import Lexer -import RdrName -import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, - listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) -import Type ( funTyCon ) -import ForeignCall ( Safety(..), CExportSpec(..), - CCallConv(..), CCallTarget(..), defaultCCallConv - ) -import OccName ( UserFS, varName, dataName, tcClsName, tvName ) -import DataCon ( DataCon, dataConName ) -import SrcLoc ( SrcLoc, noSrcLoc ) -import Module -import CmdLineOpts ( opt_SccProfilingOn ) -import Type ( Kind, mkArrowKind, liftedTypeKind ) -import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), - NewOrData(..), Activation(..) ) -import Panic - -import GLAEXTS -import CStrings ( CLabelString ) -import FastString -import Maybes ( orElse ) -import Outputable -import Char ( ord ) - -} - -{- ------------------------------------------------------------------------------ -Conflicts: 29 shift/reduce, [SDM 19/9/2002] - -10 for abiguity in 'if x then y else z + 1' [State 136] - (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) - 10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM - -1 for ambiguity in 'if x then y else z with ?x=3' [State 136] - (shift parses as 'if x then y else (z with ?x=3)' - -1 for ambiguity in 'if x then y else z :: T' [State 136] - (shift parses as 'if x then y else (z :: T)', as per longest-parse rule) - -8 for ambiguity in 'e :: a `b` c'. Does this mean [States 160,246] - (e::a) `b` c, or - (e :: (a `b` c)) - -1 for ambiguity in 'let ?x ...' [State 268] - the parser can't tell whether the ?x is the lhs of a normal binding or - an implicit binding. Fortunately resolving as shift gives it the only - sensible meaning, namely the lhs of an implicit binding. - -1 for ambiguity in '{-# RULES "name" [ ... #-} [State 332] - we don't know whether the '[' starts the activation or not: it - might be the start of the declaration with the activation being - empty. --SDM 1/4/2002 - -1 for ambiguity in '{-# RULES "name" forall = ... #-}' [State 394] - since 'forall' is a valid variable name, we don't know whether - to treat a forall on the input as the beginning of a quantifier - or the beginning of the rule itself. Resolving to shift means - it's always treated as a quantifier, hence the above is disallowed. - This saves explicitly defining a grammar for the rule lhs that - doesn't include 'forall'. - -6 for conflicts between `fdecl' and `fdeclDEPRECATED', [States 384,385] - which are resolved correctly, and moreover, - should go away when `fdeclDEPRECATED' is removed. - ------------------------------------------------------------------------------ --} - -%token - '_' { T _ _ ITunderscore } -- Haskell keywords - 'as' { T _ _ ITas } - 'case' { T _ _ ITcase } - 'class' { T _ _ ITclass } - 'data' { T _ _ ITdata } - 'default' { T _ _ ITdefault } - 'deriving' { T _ _ ITderiving } - 'do' { T _ _ ITdo } - 'else' { T _ _ ITelse } - 'hiding' { T _ _ IThiding } - 'if' { T _ _ ITif } - 'import' { T _ _ ITimport } - 'in' { T _ _ ITin } - 'infix' { T _ _ ITinfix } - 'infixl' { T _ _ ITinfixl } - 'infixr' { T _ _ ITinfixr } - 'instance' { T _ _ ITinstance } - 'let' { T _ _ ITlet } - 'module' { T _ _ ITmodule } - 'newtype' { T _ _ ITnewtype } - 'of' { T _ _ ITof } - 'qualified' { T _ _ ITqualified } - 'then' { T _ _ ITthen } - 'type' { T _ _ ITtype } - 'where' { T _ _ ITwhere } - '_scc_' { T _ _ ITscc } -- ToDo: remove - - 'forall' { T _ _ ITforall } -- GHC extension keywords - 'foreign' { T _ _ ITforeign } - 'export' { T _ _ ITexport } - 'label' { T _ _ ITlabel } - 'dynamic' { T _ _ ITdynamic } - 'safe' { T _ _ ITsafe } - 'threadsafe' { T _ _ ITthreadsafe } - 'unsafe' { T _ _ ITunsafe } - 'mdo' { T _ _ ITmdo } - 'stdcall' { T _ _ ITstdcallconv } - 'ccall' { T _ _ ITccallconv } - 'dotnet' { T _ _ ITdotnet } - 'proc' { T _ _ ITproc } -- for arrow notation extension - 'rec' { T _ _ ITrec } -- for arrow notation extension - - '{-# SPECIALISE' { T _ _ ITspecialise_prag } - '{-# SOURCE' { T _ _ ITsource_prag } - '{-# INLINE' { T _ _ ITinline_prag } - '{-# NOINLINE' { T _ _ ITnoinline_prag } - '{-# RULES' { T _ _ ITrules_prag } - '{-# CORE' { T _ _ ITcore_prag } -- hdaume: annotated core - '{-# SCC' { T _ _ ITscc_prag } - '{-# DEPRECATED' { T _ _ ITdeprecated_prag } - '{-# UNPACK' { T _ _ ITunpack_prag } - '#-}' { T _ _ ITclose_prag } - - '..' { T _ _ ITdotdot } -- reserved symbols - ':' { T _ _ ITcolon } - '::' { T _ _ ITdcolon } - '=' { T _ _ ITequal } - '\\' { T _ _ ITlam } - '|' { T _ _ ITvbar } - '<-' { T _ _ ITlarrow } - '->' { T _ _ ITrarrow } - '@' { T _ _ ITat } - '~' { T _ _ ITtilde } - '=>' { T _ _ ITdarrow } - '-' { T _ _ ITminus } - '!' { T _ _ ITbang } - '*' { T _ _ ITstar } - '-<' { T _ _ ITlarrowtail } -- for arrow notation - '>-' { T _ _ ITrarrowtail } -- for arrow notation - '-<<' { T _ _ ITLarrowtail } -- for arrow notation - '>>-' { T _ _ ITRarrowtail } -- for arrow notation - '.' { T _ _ ITdot } - - '{' { T _ _ ITocurly } -- special symbols - '}' { T _ _ ITccurly } - '{|' { T _ _ ITocurlybar } - '|}' { T _ _ ITccurlybar } - vocurly { T _ _ ITvocurly } -- virtual open curly (from layout) - vccurly { T _ _ ITvccurly } -- virtual close curly (from layout) - '[' { T _ _ ITobrack } - ']' { T _ _ ITcbrack } - '[:' { T _ _ ITopabrack } - ':]' { T _ _ ITcpabrack } - '(' { T _ _ IToparen } - ')' { T _ _ ITcparen } - '(#' { T _ _ IToubxparen } - '#)' { T _ _ ITcubxparen } - '(|' { T _ _ IToparenbar } - '|)' { T _ _ ITcparenbar } - ';' { T _ _ ITsemi } - ',' { T _ _ ITcomma } - '`' { T _ _ ITbackquote } - - VARID { T _ _ (ITvarid $$) } -- identifiers - CONID { T _ _ (ITconid $$) } - VARSYM { T _ _ (ITvarsym $$) } - CONSYM { T _ _ (ITconsym $$) } - QVARID { T _ _ (ITqvarid $$) } - QCONID { T _ _ (ITqconid $$) } - QVARSYM { T _ _ (ITqvarsym $$) } - QCONSYM { T _ _ (ITqconsym $$) } - - IPDUPVARID { T _ _ (ITdupipvarid $$) } -- GHC extension - IPSPLITVARID { T _ _ (ITsplitipvarid $$) } -- GHC extension - - CHAR { T _ _ (ITchar $$) } - STRING { T _ _ (ITstring $$) } - INTEGER { T _ _ (ITinteger $$) } - RATIONAL { T _ _ (ITrational $$) } - - PRIMCHAR { T _ _ (ITprimchar $$) } - PRIMSTRING { T _ _ (ITprimstring $$) } - PRIMINTEGER { T _ _ (ITprimint $$) } - PRIMFLOAT { T _ _ (ITprimfloat $$) } - PRIMDOUBLE { T _ _ (ITprimdouble $$) } - --- Template Haskell -'[|' { T _ _ ITopenExpQuote } -'[p|' { T _ _ ITopenPatQuote } -'[t|' { T _ _ ITopenTypQuote } -'[d|' { T _ _ ITopenDecQuote } -'|]' { T _ _ ITcloseQuote } -TH_ID_SPLICE { T _ _ (ITidEscape $$) } -- $x -'$(' { T _ _ ITparenEscape } -- $( exp ) -TH_VAR_QUOTE { T _ _ ITvarQuote } -- 'x -TH_TY_QUOTE { T _ _ ITtyQuote } -- ''T - -%monad { P } { >>= } { return } -%lexer { lexer } { T _ _ ITeof } -%name parseModule module -%name parseStmt maybe_stmt -%name parseIdentifier identifier -%name parseIface iface -%tokentype { Token } -%% - ------------------------------------------------------------------------------ --- Module Header - --- The place for module deprecation is really too restrictive, but if it --- was allowed at its natural place just before 'module', we get an ugly --- s/r conflict with the second alternative. Another solution would be the --- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, --- either, and DEPRECATED is only expected to be used by people who really --- know what they are doing. :-) - -module :: { RdrNameHsModule } - : srcloc 'module' modid maybemoddeprec maybeexports 'where' body - { HsModule (Just (mkHomeModule $3)) $5 (fst $7) (snd $7) $4 $1 } - | srcloc missing_module_keyword top close - { HsModule Nothing Nothing (fst $3) (snd $3) Nothing $1 } - -missing_module_keyword :: { () } - : {- empty -} {% pushCurrentContext } - -maybemoddeprec :: { Maybe DeprecTxt } - : '{-# DEPRECATED' STRING '#-}' { Just $2 } - | {- empty -} { Nothing } - -body :: { ([RdrNameImportDecl], [RdrNameHsDecl]) } - : '{' top '}' { $2 } - | vocurly top close { $2 } - -top :: { ([RdrNameImportDecl], [RdrNameHsDecl]) } - : importdecls { (reverse $1,[]) } - | importdecls ';' cvtopdecls { (reverse $1,$3) } - | cvtopdecls { ([],$1) } - -cvtopdecls :: { [RdrNameHsDecl] } - : topdecls { cvTopDecls $1 } - ------------------------------------------------------------------------------ --- Interfaces (.hi-boot files) - -iface :: { ModIface } - : 'module' modid 'where' ifacebody { mkBootIface $2 $4 } - -ifacebody :: { [HsDecl RdrName] } - : '{' ifacedecls '}' { $2 } - | vocurly ifacedecls close { $2 } - -ifacedecls :: { [HsDecl RdrName] } - : ifacedecl ';' ifacedecls { $1 : $3 } - | ';' ifacedecls { $2 } - | ifacedecl { [$1] } - | {- empty -} { [] } - -ifacedecl :: { HsDecl RdrName } - : var '::' sigtype - { SigD (Sig $1 $3 noSrcLoc) } - | 'type' syn_hdr '=' ctype - { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4 noSrcLoc) } - | new_or_data tycl_hdr - { TyClD (mkTyData $1 $2 [] Nothing noSrcLoc) } - | 'class' tycl_hdr fds - { TyClD (mkClassDecl $2 $3 [] EmptyMonoBinds noSrcLoc) } - -new_or_data :: { NewOrData } - : 'data' { DataType } - | 'newtype' { NewType } - ------------------------------------------------------------------------------ --- The Export List - -maybeexports :: { Maybe [RdrNameIE] } - : '(' exportlist ')' { Just $2 } - | {- empty -} { Nothing } - -exportlist :: { [RdrNameIE] } - : exportlist ',' export { $3 : $1 } - | exportlist ',' { $1 } - | export { [$1] } - | {- empty -} { [] } - - -- No longer allow things like [] and (,,,) to be exported - -- They are built in syntax, always available -export :: { RdrNameIE } - : qvar { IEVar $1 } - | oqtycon { IEThingAbs $1 } - | oqtycon '(' '..' ')' { IEThingAll $1 } - | oqtycon '(' ')' { IEThingWith $1 [] } - | oqtycon '(' qcnames ')' { IEThingWith $1 (reverse $3) } - | 'module' modid { IEModuleContents $2 } - -qcnames :: { [RdrName] } - : qcnames ',' qcname { $3 : $1 } - | qcname { [$1] } - -qcname :: { RdrName } -- Variable or data constructor - : qvar { $1 } - | gcon { $1 } - ------------------------------------------------------------------------------ --- Import Declarations - --- import decls can be *empty*, or even just a string of semicolons --- whereas topdecls must contain at least one topdecl. - -importdecls :: { [RdrNameImportDecl] } - : importdecls ';' importdecl { $3 : $1 } - | importdecls ';' { $1 } - | importdecl { [ $1 ] } - | {- empty -} { [] } - -importdecl :: { RdrNameImportDecl } - : 'import' srcloc maybe_src optqualified modid maybeas maybeimpspec - { ImportDecl $5 $3 $4 $6 $7 $2 } - -maybe_src :: { IsBootInterface } - : '{-# SOURCE' '#-}' { True } - | {- empty -} { False } - -optqualified :: { Bool } - : 'qualified' { True } - | {- empty -} { False } - -maybeas :: { Maybe ModuleName } - : 'as' modid { Just $2 } - | {- empty -} { Nothing } - -maybeimpspec :: { Maybe (Bool, [RdrNameIE]) } - : impspec { Just $1 } - | {- empty -} { Nothing } - -impspec :: { (Bool, [RdrNameIE]) } - : '(' exportlist ')' { (False, reverse $2) } - | 'hiding' '(' exportlist ')' { (True, reverse $3) } - ------------------------------------------------------------------------------ --- Fixity Declarations - -prec :: { Int } - : {- empty -} { 9 } - | INTEGER {% checkPrecP (fromInteger $1) } - -infix :: { FixityDirection } - : 'infix' { InfixN } - | 'infixl' { InfixL } - | 'infixr' { InfixR } - -ops :: { [RdrName] } - : ops ',' op { $3 : $1 } - | op { [$1] } - ------------------------------------------------------------------------------ --- Top-Level Declarations - -topdecls :: { [RdrBinding] } -- Reversed - : topdecls ';' topdecl { $3 : $1 } - | topdecls ';' { $1 } - | topdecl { [$1] } - -topdecl :: { RdrBinding } - : tycl_decl { RdrHsDecl (TyClD $1) } - | srcloc 'instance' inst_type where - { let (binds,sigs) = cvMonoBindsAndSigs $4 - in RdrHsDecl (InstD (InstDecl $3 binds sigs $1)) } - | srcloc 'default' '(' comma_types0 ')' { RdrHsDecl (DefD (DefaultDecl $4 $1)) } - | 'foreign' fdecl { RdrHsDecl $2 } - | '{-# DEPRECATED' deprecations '#-}' { RdrBindings (reverse $2) } - | '{-# RULES' rules '#-}' { RdrBindings (reverse $2) } - | srcloc '$(' exp ')' { RdrHsDecl (SpliceD (SpliceDecl $3 $1)) } - | decl { $1 } - -tycl_decl :: { RdrNameTyClDecl } - : srcloc 'type' syn_hdr '=' ctype - -- Note ctype, not sigtype. - -- We allow an explicit for-all but we don't insert one - -- in type Foo a = (b,b) - -- Instead we just say b is out of scope - { let (tc,tvs) = $3 in TySynonym tc tvs $5 $1 } - - | srcloc 'data' tycl_hdr constrs deriving - { mkTyData DataType $3 (reverse $4) $5 $1 } - - | srcloc 'newtype' tycl_hdr '=' newconstr deriving - { mkTyData NewType $3 [$5] $6 $1 } - - | srcloc 'class' tycl_hdr fds where - { let - (binds,sigs) = cvMonoBindsAndSigs $5 - in - mkClassDecl $3 $4 sigs binds $1 } - -syn_hdr :: { (RdrName, [RdrNameHsTyVar]) } -- We don't retain the syntax of an infix - -- type synonym declaration. Oh well. - : tycon tv_bndrs { ($1, $2) } - | tv_bndr tyconop tv_bndr { ($2, [$1,$3]) } - --- tycl_hdr parses the header of a type or class decl, --- which takes the form --- T a b --- Eq a => T a --- (Eq a, Ord b) => T a b --- Rather a lot of inlining here, else we get reduce/reduce errors -tycl_hdr :: { (RdrNameContext, RdrName, [RdrNameHsTyVar]) } - : context '=>' type {% checkTyClHdr $1 $3 } - | type {% checkTyClHdr [] $1 } - ------------------------------------------------------------------------------ --- Nested declarations - -decls :: { [RdrBinding] } -- Reversed - : decls ';' decl { $3 : $1 } - | decls ';' { $1 } - | decl { [$1] } - | {- empty -} { [] } - - -decllist :: { [RdrBinding] } -- Reversed - : '{' decls '}' { $2 } - | vocurly decls close { $2 } - -where :: { [RdrBinding] } -- Reversed - -- No implicit parameters - : 'where' decllist { $2 } - | {- empty -} { [] } - -binds :: { RdrNameHsBinds } -- May have implicit parameters - : decllist { cvBinds $1 } - | '{' dbinds '}' { IPBinds $2 } - | vocurly dbinds close { IPBinds $2 } - -wherebinds :: { RdrNameHsBinds } -- May have implicit parameters - : 'where' binds { $2 } - | {- empty -} { EmptyBinds } - - - ------------------------------------------------------------------------------ --- Transformation Rules - -rules :: { [RdrBinding] } -- Reversed - : rules ';' rule { $3 : $1 } - | rules ';' { $1 } - | rule { [$1] } - | {- empty -} { [] } - -rule :: { RdrBinding } - : STRING activation rule_forall infixexp '=' srcloc exp - { RdrHsDecl (RuleD (HsRule $1 $2 $3 $4 $7 $6)) } - -activation :: { Activation } -- Omitted means AlwaysActive - : {- empty -} { AlwaysActive } - | explicit_activation { $1 } - -inverse_activation :: { Activation } -- Omitted means NeverActive - : {- empty -} { NeverActive } - | explicit_activation { $1 } - -explicit_activation :: { Activation } -- In brackets - : '[' INTEGER ']' { ActiveAfter (fromInteger $2) } - | '[' '~' INTEGER ']' { ActiveBefore (fromInteger $3) } - -rule_forall :: { [RdrNameRuleBndr] } - : 'forall' rule_var_list '.' { $2 } - | {- empty -} { [] } - -rule_var_list :: { [RdrNameRuleBndr] } - : rule_var { [$1] } - | rule_var rule_var_list { $1 : $2 } - -rule_var :: { RdrNameRuleBndr } - : varid { RuleBndr $1 } - | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } - ------------------------------------------------------------------------------ --- Deprecations (c.f. rules) - -deprecations :: { [RdrBinding] } -- Reversed - : deprecations ';' deprecation { $3 : $1 } - | deprecations ';' { $1 } - | deprecation { [$1] } - | {- empty -} { [] } - --- SUP: TEMPORARY HACK, not checking for `module Foo' -deprecation :: { RdrBinding } - : srcloc depreclist STRING - { RdrBindings - [ RdrHsDecl (DeprecD (Deprecation n $3 $1)) | n <- $2 ] } - - ------------------------------------------------------------------------------ --- Foreign import and export declarations - --- for the time being, the following accepts foreign declarations conforming --- to the FFI Addendum, Version 1.0 as well as pre-standard declarations --- --- * a flag indicates whether pre-standard declarations have been used and --- triggers a deprecation warning further down the road --- --- NB: The first two rules could be combined into one by replacing `safety1' --- with `safety'. However, the combined rule conflicts with the --- DEPRECATED rules. --- -fdecl :: { RdrNameHsDecl } -fdecl : srcloc 'import' callconv safety1 fspec {% mkImport $3 $4 $5 $1 } - | srcloc 'import' callconv fspec {% mkImport $3 (PlaySafe False) $4 $1 } - | srcloc 'export' callconv fspec {% mkExport $3 $4 $1 } - -- the following syntax is DEPRECATED - | srcloc fdecl1DEPRECATED { ForD ($2 True $1) } - | srcloc fdecl2DEPRECATED { $2 $1 } - -fdecl1DEPRECATED :: { Bool -> SrcLoc -> ForeignDecl RdrName } -fdecl1DEPRECATED - ----------- DEPRECATED label decls ------------ - : 'label' ext_name varid '::' sigtype - { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS - (CLabel ($2 `orElse` mkExtName $3))) } - - ----------- DEPRECATED ccall/stdcall decls ------------ - -- - -- NB: This business with the case expression below may seem overly - -- complicated, but it is necessary to avoid some conflicts. - - -- DEPRECATED variant #1: lack of a calling convention specification - -- (import) - | 'import' {-no callconv-} ext_name safety varid_no_unsafe '::' sigtype - { let - target = StaticTarget ($2 `orElse` mkExtName $4) - in - ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS - (CFunction target)) } - - -- DEPRECATED variant #2: external name consists of two separate strings - -- (module name and function name) (import) - | 'import' callconv STRING STRING safety varid_no_unsafe '::' sigtype - {% case $2 of - DNCall -> parseError "Illegal format of .NET foreign import" - CCall cconv -> return $ - let - imp = CFunction (StaticTarget $4) - in - ForeignImport $6 $8 (CImport cconv $5 nilFS nilFS imp) } - - -- DEPRECATED variant #3: `unsafe' after entity - | 'import' callconv STRING 'unsafe' varid_no_unsafe '::' sigtype - {% case $2 of - DNCall -> parseError "Illegal format of .NET foreign import" - CCall cconv -> return $ - let - imp = CFunction (StaticTarget $3) - in - ForeignImport $5 $7 (CImport cconv PlayRisky nilFS nilFS imp) } - - -- DEPRECATED variant #4: use of the special identifier `dynamic' without - -- an explicit calling convention (import) - | 'import' {-no callconv-} 'dynamic' safety varid_no_unsafe '::' sigtype - { ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS - (CFunction DynamicTarget)) } - - -- DEPRECATED variant #5: use of the special identifier `dynamic' (import) - | 'import' callconv 'dynamic' safety varid_no_unsafe '::' sigtype - {% case $2 of - DNCall -> parseError "Illegal format of .NET foreign import" - CCall cconv -> return $ - ForeignImport $5 $7 (CImport cconv $4 nilFS nilFS - (CFunction DynamicTarget)) } - - -- DEPRECATED variant #6: lack of a calling convention specification - -- (export) - | 'export' {-no callconv-} ext_name varid '::' sigtype - { ForeignExport $3 $5 (CExport (CExportStatic ($2 `orElse` mkExtName $3) - defaultCCallConv)) } - - -- DEPRECATED variant #7: external name consists of two separate strings - -- (module name and function name) (export) - | 'export' callconv STRING STRING varid '::' sigtype - {% case $2 of - DNCall -> parseError "Illegal format of .NET foreign import" - CCall cconv -> return $ - ForeignExport $5 $7 - (CExport (CExportStatic $4 cconv)) } - - -- DEPRECATED variant #8: use of the special identifier `dynamic' without - -- an explicit calling convention (export) - | 'export' {-no callconv-} 'dynamic' varid '::' sigtype - { ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS - CWrapper) } - - -- DEPRECATED variant #9: use of the special identifier `dynamic' (export) - | 'export' callconv 'dynamic' varid '::' sigtype - {% case $2 of - DNCall -> parseError "Illegal format of .NET foreign import" - CCall cconv -> return $ - ForeignImport $4 $6 (CImport cconv (PlaySafe False) nilFS nilFS CWrapper) } - - ----------- DEPRECATED .NET decls ------------ - -- NB: removed the .NET call declaration, as it is entirely subsumed - -- by the new standard FFI declarations - -fdecl2DEPRECATED :: { SrcLoc -> RdrNameHsDecl } -fdecl2DEPRECATED - : 'import' 'dotnet' 'type' ext_name tycon - { \loc -> TyClD (ForeignType $5 $4 DNType loc) } - -- left this one unchanged for the moment as type imports are not - -- covered currently by the FFI standard -=chak - - -callconv :: { CallConv } - : 'stdcall' { CCall StdCallConv } - | 'ccall' { CCall CCallConv } - | 'dotnet' { DNCall } - -safety :: { Safety } - : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe False } - | 'threadsafe' { PlaySafe True } - | {- empty -} { PlaySafe False } - -safety1 :: { Safety } - : 'unsafe' { PlayRisky } - | 'safe' { PlaySafe False } - | 'threadsafe' { PlaySafe True } - -- only needed to avoid conflicts with the DEPRECATED rules - -fspec :: { (FastString, RdrName, RdrNameHsType) } - : STRING var '::' sigtype { ($1 , $2, $4) } - | var '::' sigtype { (nilFS, $1, $3) } - -- if the entity string is missing, it defaults to the empty string; - -- the meaning of an empty entity string depends on the calling - -- convention - --- DEPRECATED syntax -ext_name :: { Maybe CLabelString } - : STRING { Just $1 } - | STRING STRING { Just $2 } -- Ignore "module name" for now - | {- empty -} { Nothing } - - ------------------------------------------------------------------------------ --- Type signatures - -opt_sig :: { Maybe RdrNameHsType } - : {- empty -} { Nothing } - | '::' sigtype { Just $2 } - -opt_asig :: { Maybe RdrNameHsType } - : {- empty -} { Nothing } - | '::' atype { Just $2 } - -sigtypes :: { [RdrNameHsType] } - : sigtype { [ $1 ] } - | sigtypes ',' sigtype { $3 : $1 } - -sigtype :: { RdrNameHsType } - : ctype { mkImplicitHsForAllTy [] $1 } - -- Wrap an Implicit forall if there isn't one there already - -sig_vars :: { [RdrName] } - : sig_vars ',' var { $3 : $1 } - | var { [ $1 ] } - ------------------------------------------------------------------------------ --- Types - --- A ctype is a for-all type -ctype :: { RdrNameHsType } - : 'forall' tv_bndrs '.' ctype { mkExplicitHsForAllTy $2 [] $4 } - | context '=>' type { mkImplicitHsForAllTy $1 $3 } - -- A type of form (context => type) is an *implicit* HsForAllTy - | type { $1 } - --- We parse a context as a btype so that we don't get reduce/reduce --- errors in ctype. The basic problem is that --- (Eq a, Ord a) --- looks so much like a tuple type. We can't tell until we find the => -context :: { RdrNameContext } - : btype {% checkContext $1 } - -type :: { RdrNameHsType } - : ipvar '::' gentype { mkHsIParamTy $1 $3 } - | gentype { $1 } - -gentype :: { RdrNameHsType } - : btype { $1 } - | btype qtyconop gentype { HsOpTy $1 $2 $3 } - | btype '`' tyvar '`' gentype { HsOpTy $1 $3 $5 } - | btype '->' gentype { HsFunTy $1 $3 } - -btype :: { RdrNameHsType } - : btype atype { HsAppTy $1 $2 } - | atype { $1 } - -atype :: { RdrNameHsType } - : gtycon { HsTyVar $1 } - | tyvar { HsTyVar $1 } - | '(' type ',' comma_types1 ')' { HsTupleTy Boxed ($2:$4) } - | '(#' comma_types1 '#)' { HsTupleTy Unboxed $2 } - | '[' type ']' { HsListTy $2 } - | '[:' type ':]' { HsPArrTy $2 } - | '(' ctype ')' { HsParTy $2 } - | '(' ctype '::' kind ')' { HsKindSig $2 $4 } --- Generics - | INTEGER { HsNumTy $1 } - --- An inst_type is what occurs in the head of an instance decl --- e.g. (Foo a, Gaz b) => Wibble a b --- It's kept as a single type, with a MonoDictTy at the right --- hand corner, for convenience. -inst_type :: { RdrNameHsType } - : ctype {% checkInstType $1 } - -comma_types0 :: { [RdrNameHsType] } - : comma_types1 { $1 } - | {- empty -} { [] } - -comma_types1 :: { [RdrNameHsType] } - : type { [$1] } - | type ',' comma_types1 { $1 : $3 } - -tv_bndrs :: { [RdrNameHsTyVar] } - : tv_bndr tv_bndrs { $1 : $2 } - | {- empty -} { [] } - -tv_bndr :: { RdrNameHsTyVar } - : tyvar { UserTyVar $1 } - | '(' tyvar '::' kind ')' { KindedTyVar $2 $4 } - -fds :: { [([RdrName], [RdrName])] } - : {- empty -} { [] } - | '|' fds1 { reverse $2 } - -fds1 :: { [([RdrName], [RdrName])] } - : fds1 ',' fd { $3 : $1 } - | fd { [$1] } - -fd :: { ([RdrName], [RdrName]) } - : varids0 '->' varids0 { (reverse $1, reverse $3) } - -varids0 :: { [RdrName] } - : {- empty -} { [] } - | varids0 tyvar { $2 : $1 } - ------------------------------------------------------------------------------ --- Kinds - -kind :: { Kind } - : akind { $1 } - | akind '->' kind { mkArrowKind $1 $3 } - -akind :: { Kind } - : '*' { liftedTypeKind } - | '(' kind ')' { $2 } - - ------------------------------------------------------------------------------ --- Datatype declarations - -newconstr :: { RdrNameConDecl } - : srcloc conid atype { ConDecl $2 [] [] (PrefixCon [unbangedType $3]) $1 } - | srcloc conid '{' var '::' ctype '}' - { ConDecl $2 [] [] (RecCon [($4, unbangedType $6)]) $1 } - -constrs :: { [RdrNameConDecl] } - : {- empty; a GHC extension -} { [] } - | '=' constrs1 { $2 } - -constrs1 :: { [RdrNameConDecl] } - : constrs1 '|' constr { $3 : $1 } - | constr { [$1] } - -constr :: { RdrNameConDecl } - : srcloc forall context '=>' constr_stuff - { ConDecl (fst $5) $2 $3 (snd $5) $1 } - | srcloc forall constr_stuff - { ConDecl (fst $3) $2 [] (snd $3) $1 } - -forall :: { [RdrNameHsTyVar] } - : 'forall' tv_bndrs '.' { $2 } - | {- empty -} { [] } - -constr_stuff :: { (RdrName, RdrNameConDetails) } - : btype {% mkPrefixCon $1 [] } - | btype strict_mark atype satypes {% mkPrefixCon $1 (BangType $2 $3 : $4) } - | oqtycon '{' '}' {% mkRecCon $1 [] } - | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 } - | sbtype conop sbtype { ($2, InfixCon $1 $3) } - -satypes :: { [RdrNameBangType] } - : atype satypes { unbangedType $1 : $2 } - | strict_mark atype satypes { BangType $1 $2 : $3 } - | {- empty -} { [] } - -sbtype :: { RdrNameBangType } - : btype { unbangedType $1 } - | strict_mark atype { BangType $1 $2 } - -fielddecls :: { [([RdrName],RdrNameBangType)] } - : fielddecl ',' fielddecls { $1 : $3 } - | fielddecl { [$1] } - -fielddecl :: { ([RdrName],RdrNameBangType) } - : sig_vars '::' stype { (reverse $1, $3) } - -stype :: { RdrNameBangType } - : ctype { unbangedType $1 } - | strict_mark atype { BangType $1 $2 } - -strict_mark :: { HsBang } - : '!' { HsStrict } - | '{-# UNPACK' '#-}' '!' { HsUnbox } - -deriving :: { Maybe RdrNameContext } - : {- empty -} { Nothing } - | 'deriving' context { Just $2 } - -- Glasgow extension: allow partial - -- applications in derivings - ------------------------------------------------------------------------------ --- Value definitions - -{- There's an awkward overlap with a type signature. Consider - f :: Int -> Int = ...rhs... - Then we can't tell whether it's a type signature or a value - definition with a result signature until we see the '='. - So we have to inline enough to postpone reductions until we know. --} - -{- - ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var - instead of qvar, we get another shift/reduce-conflict. Consider the - following programs: - - { (^^) :: Int->Int ; } Type signature; only var allowed - - { (^^) :: Int->Int = ... ; } Value defn with result signature; - qvar allowed (because of instance decls) - - We can't tell whether to reduce var to qvar until after we've read the signatures. --} - -decl :: { RdrBinding } - : sigdecl { $1 } - | infixexp srcloc opt_sig rhs {% checkValDef $1 $3 $4 $2 } - -rhs :: { RdrNameGRHSs } - : '=' srcloc exp wherebinds { GRHSs (unguardedRHS $3 $2) $4 placeHolderType } - | gdrhs wherebinds { GRHSs (reverse $1) $2 placeHolderType } - -gdrhs :: { [RdrNameGRHS] } - : gdrhs gdrh { $2 : $1 } - | gdrh { [$1] } - -gdrh :: { RdrNameGRHS } - : '|' srcloc quals '=' exp { GRHS (reverse (ResultStmt $5 $2 : $3)) $2 } - -sigdecl :: { RdrBinding } - : infixexp srcloc '::' sigtype - {% checkValSig $1 $4 $2 } - -- See the above notes for why we need infixexp here - | var ',' sig_vars srcloc '::' sigtype - { mkSigDecls [ Sig n $6 $4 | n <- $1:$3 ] } - | srcloc infix prec ops { mkSigDecls [ FixSig (FixitySig n (Fixity $3 $2) $1) - | n <- $4 ] } - | '{-# INLINE' srcloc activation qvar '#-}' - { RdrHsDecl (SigD (InlineSig True $4 $3 $2)) } - | '{-# NOINLINE' srcloc inverse_activation qvar '#-}' - { RdrHsDecl (SigD (InlineSig False $4 $3 $2)) } - | '{-# SPECIALISE' srcloc qvar '::' sigtypes '#-}' - { mkSigDecls [ SpecSig $3 t $2 | t <- $5] } - | '{-# SPECIALISE' srcloc 'instance' inst_type '#-}' - { RdrHsDecl (SigD (SpecInstSig $4 $2)) } - ------------------------------------------------------------------------------ --- Expressions - -exp :: { RdrNameHsExpr } - : infixexp '::' sigtype { ExprWithTySig $1 $3 } - | fexp srcloc '-<' exp { HsArrApp $1 $4 placeHolderType HsFirstOrderApp True $2 } - | fexp srcloc '>-' exp { HsArrApp $4 $1 placeHolderType HsFirstOrderApp False $2 } - | fexp srcloc '-<<' exp { HsArrApp $1 $4 placeHolderType HsHigherOrderApp True $2 } - | fexp srcloc '>>-' exp { HsArrApp $4 $1 placeHolderType HsHigherOrderApp False $2 } - | infixexp { $1 } - -infixexp :: { RdrNameHsExpr } - : exp10 { $1 } - | infixexp qop exp10 { (OpApp $1 (HsVar $2) - (panic "fixity") $3 )} - -exp10 :: { RdrNameHsExpr } - : '\\' srcloc aexp aexps opt_asig '->' srcloc exp - {% checkPatterns $2 ($3 : reverse $4) >>= \ ps -> - return (HsLam (Match ps $5 - (GRHSs (unguardedRHS $8 $7) - EmptyBinds placeHolderType))) } - | 'let' binds 'in' exp { HsLet $2 $4 } - | 'if' srcloc exp 'then' exp 'else' exp { HsIf $3 $5 $7 $2 } - | 'case' srcloc exp 'of' altslist { HsCase $3 $5 $2 } - | '-' fexp { mkHsNegApp $2 } - | srcloc 'do' stmtlist {% checkDo $3 >>= \ stmts -> - return (mkHsDo DoExpr stmts $1) } - | srcloc 'mdo' stmtlist {% checkMDo $3 >>= \ stmts -> - return (mkHsDo MDoExpr stmts $1) } - - | scc_annot exp { if opt_SccProfilingOn - then HsSCC $1 $2 - else HsPar $2 } - - | 'proc' srcloc aexp '->' srcloc exp - {% checkPattern $2 $3 >>= \ p -> - return (HsProc p (HsCmdTop $6 [] placeHolderType undefined) $5) } - - | '{-# CORE' STRING '#-}' exp { HsCoreAnn $2 $4 } -- hdaume: core annotation - - | fexp { $1 } - -scc_annot :: { FastString } - : '_scc_' STRING { $2 } - | '{-# SCC' STRING '#-}' { $2 } - -fexp :: { RdrNameHsExpr } - : fexp aexp { HsApp $1 $2 } - | aexp { $1 } - -aexps :: { [RdrNameHsExpr] } - : aexps aexp { $2 : $1 } - | {- empty -} { [] } - -aexp :: { RdrNameHsExpr } - : qvar '@' aexp { EAsPat $1 $3 } - | '~' aexp { ELazyPat $2 } - | aexp1 { $1 } - -aexp1 :: { RdrNameHsExpr } - : aexp1 '{' fbinds '}' {% (mkRecConstrOrUpdate $1 (reverse $3)) } - | aexp2 { $1 } - --- Here was the syntax for type applications that I was planning --- but there are difficulties (e.g. what order for type args) --- so it's not enabled yet. --- But this case *is* used for the left hand side of a generic definition, --- which is parsed as an expression before being munged into a pattern - | qcname '{|' gentype '|}' { (HsApp (HsVar $1) (HsType $3)) } - -aexp2 :: { RdrNameHsExpr } - : ipvar { HsIPVar $1 } - | qcname { HsVar $1 } - | literal { HsLit $1 } - | INTEGER { HsOverLit $! mkHsIntegral $1 } - | RATIONAL { HsOverLit $! mkHsFractional $1 } - | '(' exp ')' { HsPar $2 } - | '(' exp ',' texps ')' { ExplicitTuple ($2 : reverse $4) Boxed} - | '(#' texps '#)' { ExplicitTuple (reverse $2) Unboxed } - | '[' list ']' { $2 } - | '[:' parr ':]' { $2 } - | '(' infixexp qop ')' { (SectionL $2 (HsVar $3)) } - | '(' qopm infixexp ')' { (SectionR $2 $3) } - | '_' { EWildPat } - - -- MetaHaskell Extension - | srcloc TH_ID_SPLICE { mkHsSplice (HsVar (mkUnqual varName $2)) $1 } -- $x - | srcloc '$(' exp ')' { mkHsSplice $3 $1 } -- $( exp ) - | srcloc TH_VAR_QUOTE qvar { HsBracket (VarBr $3) $1 } - | srcloc TH_VAR_QUOTE qcon { HsBracket (VarBr $3) $1 } - | srcloc TH_TY_QUOTE tyvar { HsBracket (VarBr $3) $1 } - | srcloc TH_TY_QUOTE gtycon { HsBracket (VarBr $3) $1 } - | srcloc '[|' exp '|]' { HsBracket (ExpBr $3) $1 } - | srcloc '[t|' ctype '|]' { HsBracket (TypBr $3) $1 } - | srcloc '[p|' infixexp '|]' {% checkPattern $1 $3 >>= \p -> - return (HsBracket (PatBr p) $1) } - | srcloc '[d|' cvtopbody '|]' { HsBracket (DecBr (mkGroup $3)) $1 } - - -- arrow notation extension - | srcloc '(|' aexp2 cmdargs '|)' - { HsArrForm $3 Nothing (reverse $4) $1 } - -cmdargs :: { [RdrNameHsCmdTop] } - : cmdargs acmd { $2 : $1 } - | {- empty -} { [] } - -acmd :: { RdrNameHsCmdTop } - : aexp2 { HsCmdTop $1 [] placeHolderType undefined } - -cvtopbody :: { [RdrNameHsDecl] } - : '{' cvtopdecls '}' { $2 } - | vocurly cvtopdecls close { $2 } - -texps :: { [RdrNameHsExpr] } - : texps ',' exp { $3 : $1 } - | exp { [$1] } - - ------------------------------------------------------------------------------ --- List expressions - --- The rules below are little bit contorted to keep lexps left-recursive while --- avoiding another shift/reduce-conflict. - -list :: { RdrNameHsExpr } - : exp { ExplicitList placeHolderType [$1] } - | lexps { ExplicitList placeHolderType (reverse $1) } - | exp '..' { ArithSeqIn (From $1) } - | exp ',' exp '..' { ArithSeqIn (FromThen $1 $3) } - | exp '..' exp { ArithSeqIn (FromTo $1 $3) } - | exp ',' exp '..' exp { ArithSeqIn (FromThenTo $1 $3 $5) } - | exp srcloc pquals { mkHsDo ListComp - (reverse (ResultStmt $1 $2 : $3)) - $2 - } - -lexps :: { [RdrNameHsExpr] } - : lexps ',' exp { $3 : $1 } - | exp ',' exp { [$3,$1] } - ------------------------------------------------------------------------------ --- List Comprehensions - -pquals :: { [RdrNameStmt] } -- Either a singleton ParStmt, or a reversed list of Stmts - : pquals1 { case $1 of - [qs] -> qs - qss -> [ParStmt stmtss] - where - stmtss = [ (reverse qs, undefined) - | qs <- qss ] - } - -pquals1 :: { [[RdrNameStmt]] } - : pquals1 '|' quals { $3 : $1 } - | '|' quals { [$2] } - -quals :: { [RdrNameStmt] } - : quals ',' qual { $3 : $1 } - | qual { [$1] } - ------------------------------------------------------------------------------ --- Parallel array expressions - --- The rules below are little bit contorted; see the list case for details. --- Note that, in contrast to lists, we only have finite arithmetic sequences. --- Moreover, we allow explicit arrays with no element (represented by the nil --- constructor in the list case). - -parr :: { RdrNameHsExpr } - : { ExplicitPArr placeHolderType [] } - | exp { ExplicitPArr placeHolderType [$1] } - | lexps { ExplicitPArr placeHolderType - (reverse $1) } - | exp '..' exp { PArrSeqIn (FromTo $1 $3) } - | exp ',' exp '..' exp { PArrSeqIn (FromThenTo $1 $3 $5) } - | exp srcloc pquals { mkHsDo PArrComp - (reverse (ResultStmt $1 $2 : $3)) - $2 - } - --- We are reusing `lexps' and `pquals' from the list case. - ------------------------------------------------------------------------------ --- Case alternatives - -altslist :: { [RdrNameMatch] } - : '{' alts '}' { reverse $2 } - | vocurly alts close { reverse $2 } - -alts :: { [RdrNameMatch] } - : alts1 { $1 } - | ';' alts { $2 } - -alts1 :: { [RdrNameMatch] } - : alts1 ';' alt { $3 : $1 } - | alts1 ';' { $1 } - | alt { [$1] } - -alt :: { RdrNameMatch } - : srcloc infixexp opt_sig ralt wherebinds - {% (checkPattern $1 $2 >>= \p -> - return (Match [p] $3 - (GRHSs $4 $5 placeHolderType)) )} - -ralt :: { [RdrNameGRHS] } - : '->' srcloc exp { [GRHS [ResultStmt $3 $2] $2] } - | gdpats { reverse $1 } - -gdpats :: { [RdrNameGRHS] } - : gdpats gdpat { $2 : $1 } - | gdpat { [$1] } - -gdpat :: { RdrNameGRHS } - : srcloc '|' quals '->' exp { GRHS (reverse (ResultStmt $5 $1:$3)) $1} - ------------------------------------------------------------------------------ --- Statement sequences - -stmtlist :: { [RdrNameStmt] } - : '{' stmts '}' { $2 } - | vocurly stmts close { $2 } - --- do { ;; s ; s ; ; s ;; } --- The last Stmt should be a ResultStmt, but that's hard to enforce --- here, because we need too much lookahead if we see do { e ; } --- So we use ExprStmts throughout, and switch the last one over --- in ParseUtils.checkDo instead -stmts :: { [RdrNameStmt] } - : stmt stmts_help { $1 : $2 } - | ';' stmts { $2 } - | {- empty -} { [] } - -stmts_help :: { [RdrNameStmt] } - : ';' stmts { $2 } - | {- empty -} { [] } - --- For typing stmts at the GHCi prompt, where --- the input may consist of just comments. -maybe_stmt :: { Maybe RdrNameStmt } - : stmt { Just $1 } - | {- nothing -} { Nothing } - -stmt :: { RdrNameStmt } - : qual { $1 } - | srcloc infixexp '->' exp {% checkPattern $1 $4 >>= \p -> - return (BindStmt p $2 $1) } - | srcloc 'rec' stmtlist { RecStmt $3 undefined undefined undefined } - -qual :: { RdrNameStmt } - : srcloc infixexp '<-' exp {% checkPattern $1 $2 >>= \p -> - return (BindStmt p $4 $1) } - | srcloc exp { ExprStmt $2 placeHolderType $1 } - | srcloc 'let' binds { LetStmt $3 } - ------------------------------------------------------------------------------ --- Record Field Update/Construction - -fbinds :: { RdrNameHsRecordBinds } - : fbinds1 { $1 } - | {- empty -} { [] } - -fbinds1 :: { RdrNameHsRecordBinds } - : fbinds1 ',' fbind { $3 : $1 } - | fbind { [$1] } - -fbind :: { (RdrName, RdrNameHsExpr) } - : qvar '=' exp { ($1,$3) } - ------------------------------------------------------------------------------ --- Implicit Parameter Bindings - -dbinds :: { [(IPName RdrName, RdrNameHsExpr)] } - : dbinds ';' dbind { $3 : $1 } - | dbinds ';' { $1 } - | dbind { [$1] } --- | {- empty -} { [] } - -dbind :: { (IPName RdrName, RdrNameHsExpr) } -dbind : ipvar '=' exp { ($1, $3) } - ------------------------------------------------------------------------------ --- Variables, Constructors and Operators. - -identifier :: { RdrName } - : qvar { $1 } - | gcon { $1 } - | qop { $1 } - -depreclist :: { [RdrName] } -depreclist : deprec_var { [$1] } - | deprec_var ',' depreclist { $1 : $3 } - -deprec_var :: { RdrName } -deprec_var : var { $1 } - | tycon { $1 } - -gcon :: { RdrName } -- Data constructor namespace - : sysdcon { nameRdrName (dataConName $1) } - | qcon { $1 } --- the case of '[:' ':]' is part of the production `parr' - -sysdcon :: { DataCon } -- Wired in data constructors - : '(' ')' { unitDataCon } - | '(' commas ')' { tupleCon Boxed $2 } - | '[' ']' { nilDataCon } - -var :: { RdrName } - : varid { $1 } - | '(' varsym ')' { $2 } - -qvar :: { RdrName } - : qvarid { $1 } - | '(' varsym ')' { $2 } - | '(' qvarsym1 ')' { $2 } --- We've inlined qvarsym here so that the decision about --- whether it's a qvar or a var can be postponed until --- *after* we see the close paren. - -ipvar :: { IPName RdrName } - : IPDUPVARID { Dupable (mkUnqual varName $1) } - | IPSPLITVARID { Linear (mkUnqual varName $1) } - -qcon :: { RdrName } - : qconid { $1 } - | '(' qconsym ')' { $2 } - -varop :: { RdrName } - : varsym { $1 } - | '`' varid '`' { $2 } - -qvarop :: { RdrName } - : qvarsym { $1 } - | '`' qvarid '`' { $2 } - -qvaropm :: { RdrName } - : qvarsym_no_minus { $1 } - | '`' qvarid '`' { $2 } - -conop :: { RdrName } - : consym { $1 } - | '`' conid '`' { $2 } - -qconop :: { RdrName } - : qconsym { $1 } - | '`' qconid '`' { $2 } - ------------------------------------------------------------------------------ --- Type constructors - -gtycon :: { RdrName } -- A "general" qualified tycon - : oqtycon { $1 } - | '(' ')' { getRdrName unitTyCon } - | '(' commas ')' { getRdrName (tupleTyCon Boxed $2) } - | '(' '->' ')' { getRdrName funTyCon } - | '[' ']' { listTyCon_RDR } - | '[:' ':]' { parrTyCon_RDR } - -oqtycon :: { RdrName } -- An "ordinary" qualified tycon - : qtycon { $1 } - | '(' qtyconsym ')' { $2 } - -qtyconop :: { RdrName } -- Qualified or unqualified - : qtyconsym { $1 } - | '`' qtycon '`' { $2 } - -tyconop :: { RdrName } -- Unqualified - : tyconsym { $1 } - | '`' tycon '`' { $2 } - -qtycon :: { RdrName } -- Qualified or unqualified - : QCONID { mkQual tcClsName $1 } - | tycon { $1 } - -tycon :: { RdrName } -- Unqualified - : CONID { mkUnqual tcClsName $1 } - -qtyconsym :: { RdrName } - : QCONSYM { mkQual tcClsName $1 } - | tyconsym { $1 } - -tyconsym :: { RdrName } - : CONSYM { mkUnqual tcClsName $1 } - ------------------------------------------------------------------------------ --- Any operator - -op :: { RdrName } -- used in infix decls - : varop { $1 } - | conop { $1 } - -qop :: { RdrName {-HsExpr-} } -- used in sections - : qvarop { $1 } - | qconop { $1 } - -qopm :: { RdrNameHsExpr } -- used in sections - : qvaropm { HsVar $1 } - | qconop { HsVar $1 } - ------------------------------------------------------------------------------ --- VarIds - -qvarid :: { RdrName } - : varid { $1 } - | QVARID { mkQual varName $1 } - -varid :: { RdrName } - : varid_no_unsafe { $1 } - | 'unsafe' { mkUnqual varName FSLIT("unsafe") } - | 'safe' { mkUnqual varName FSLIT("safe") } - | 'threadsafe' { mkUnqual varName FSLIT("threadsafe") } - -varid_no_unsafe :: { RdrName } - : VARID { mkUnqual varName $1 } - | special_id { mkUnqual varName $1 } - | 'forall' { mkUnqual varName FSLIT("forall") } - -tyvar :: { RdrName } - : VARID { mkUnqual tvName $1 } - | special_id { mkUnqual tvName $1 } - | 'unsafe' { mkUnqual tvName FSLIT("unsafe") } - | 'safe' { mkUnqual tvName FSLIT("safe") } - | 'threadsafe' { mkUnqual tvName FSLIT("threadsafe") } - --- These special_ids are treated as keywords in various places, --- but as ordinary ids elsewhere. 'special_id' collects all these --- except 'unsafe' and 'forall' whose treatment differs depending on context -special_id :: { UserFS } -special_id - : 'as' { FSLIT("as") } - | 'qualified' { FSLIT("qualified") } - | 'hiding' { FSLIT("hiding") } - | 'export' { FSLIT("export") } - | 'label' { FSLIT("label") } - | 'dynamic' { FSLIT("dynamic") } - | 'stdcall' { FSLIT("stdcall") } - | 'ccall' { FSLIT("ccall") } - ------------------------------------------------------------------------------ --- Variables - -qvarsym :: { RdrName } - : varsym { $1 } - | qvarsym1 { $1 } - -qvarsym_no_minus :: { RdrName } - : varsym_no_minus { $1 } - | qvarsym1 { $1 } - -qvarsym1 :: { RdrName } -qvarsym1 : QVARSYM { mkQual varName $1 } - -varsym :: { RdrName } - : varsym_no_minus { $1 } - | '-' { mkUnqual varName FSLIT("-") } - -varsym_no_minus :: { RdrName } -- varsym not including '-' - : VARSYM { mkUnqual varName $1 } - | special_sym { mkUnqual varName $1 } - - --- See comments with special_id -special_sym :: { UserFS } -special_sym : '!' { FSLIT("!") } - | '.' { FSLIT(".") } - | '*' { FSLIT("*") } - ------------------------------------------------------------------------------ --- Data constructors - -qconid :: { RdrName } -- Qualified or unqualifiedb - : conid { $1 } - | QCONID { mkQual dataName $1 } - -conid :: { RdrName } - : CONID { mkUnqual dataName $1 } - -qconsym :: { RdrName } -- Qualified or unqualified - : consym { $1 } - | QCONSYM { mkQual dataName $1 } - -consym :: { RdrName } - : CONSYM { mkUnqual dataName $1 } - - -- ':' means only list cons - | ':' { consDataCon_RDR } - - ------------------------------------------------------------------------------ --- Literals - -literal :: { HsLit } - : CHAR { HsChar (ord $1) } --TODO remove ord - | STRING { HsString $1 } - | PRIMINTEGER { HsIntPrim $1 } - | PRIMCHAR { HsCharPrim (ord $1) } --TODO remove ord - | PRIMSTRING { HsStringPrim $1 } - | PRIMFLOAT { HsFloatPrim $1 } - | PRIMDOUBLE { HsDoublePrim $1 } - -srcloc :: { SrcLoc } : {% getSrcLoc } - ------------------------------------------------------------------------------ --- Layout - -close :: { () } - : vccurly { () } -- context popped in lexer. - | error {% popContext } - ------------------------------------------------------------------------------ --- Miscellaneous (mostly renamings) - -modid :: { ModuleName } - : CONID { mkModuleNameFS $1 } - | QCONID { mkModuleNameFS - (mkFastString - (unpackFS (fst $1) ++ - '.':unpackFS (snd $1))) - } - -commas :: { Int } - : commas ',' { $1 + 1 } - | ',' { 2 } - ------------------------------------------------------------------------------ - -{ -happyError :: P a -happyError = srcParseFail -} diff --git a/ghc/compiler/parser/Parser.y.pp b/ghc/compiler/parser/Parser.y.pp new file mode 100644 index 0000000000..b3d6196471 --- /dev/null +++ b/ghc/compiler/parser/Parser.y.pp @@ -0,0 +1,1538 @@ +-- -*-haskell-*- +-- --------------------------------------------------------------------------- +-- (c) The University of Glasgow 1997-2003 +--- +-- The GHC grammar. +-- +-- Author(s): Simon Marlow, Sven Panne 1997, 1998, 1999 +-- --------------------------------------------------------------------------- + +{ +module Parser ( parseModule, parseStmt, parseIdentifier, parseIface ) where + +#define INCLUDE #include +INCLUDE "HsVersions.h" + +import HsSyn +import RdrHsSyn +import HscTypes ( ModIface, IsBootInterface, DeprecTxt ) +import Lexer +import RdrName +import TysWiredIn ( unitTyCon, unitDataCon, tupleTyCon, tupleCon, nilDataCon, + listTyCon_RDR, parrTyCon_RDR, consDataCon_RDR ) +import Type ( funTyCon ) +import ForeignCall ( Safety(..), CExportSpec(..), + CCallConv(..), CCallTarget(..), defaultCCallConv + ) +import OccName ( UserFS, varName, dataName, tcClsName, tvName ) +import DataCon ( DataCon, dataConName ) +import SrcLoc ( Located(..), unLoc, getLoc, noLoc, combineSrcSpans, + SrcSpan, combineLocs, mkGeneralSrcSpan, srcLocFile ) +import Module +import CmdLineOpts ( opt_SccProfilingOn ) +import Type ( Kind, mkArrowKind, liftedTypeKind ) +import BasicTypes ( Boxity(..), Fixity(..), FixityDirection(..), IPName(..), + NewOrData(..), Activation(..) ) +import Bag ( emptyBag ) +import Panic + +import GLAEXTS +import CStrings ( CLabelString ) +import FastString +import Maybes ( orElse ) +import Outputable +} + +{- +----------------------------------------------------------------------------- +Conflicts: 29 shift/reduce, [SDM 19/9/2002] + +10 for abiguity in 'if x then y else z + 1' [State 136] + (shift parses as 'if x then y else (z + 1)', as per longest-parse rule) + 10 because op might be: : - ! * . `x` VARSYM CONSYM QVARSYM QCONSYM + +1 for ambiguity in 'if x then y else z with ?x=3' [State 136] + (shift parses as 'if x then y else (z with ?x=3)' + +1 for ambiguity in 'if x then y else z :: T' [State 136] + (shift parses as 'if x then y else (z :: T)', as per longest-parse rule) + +8 for ambiguity in 'e :: a `b` c'. Does this mean [States 160,246] + (e::a) `b` c, or + (e :: (a `b` c)) + +1 for ambiguity in 'let ?x ...' [State 268] + the parser can't tell whether the ?x is the lhs of a normal binding or + an implicit binding. Fortunately resolving as shift gives it the only + sensible meaning, namely the lhs of an implicit binding. + +1 for ambiguity in '{-# RULES "name" [ ... #-} [State 332] + we don't know whether the '[' starts the activation or not: it + might be the start of the declaration with the activation being + empty. --SDM 1/4/2002 + +1 for ambiguity in '{-# RULES "name" forall = ... #-}' [State 394] + since 'forall' is a valid variable name, we don't know whether + to treat a forall on the input as the beginning of a quantifier + or the beginning of the rule itself. Resolving to shift means + it's always treated as a quantifier, hence the above is disallowed. + This saves explicitly defining a grammar for the rule lhs that + doesn't include 'forall'. + +6 for conflicts between `fdecl' and `fdeclDEPRECATED', [States 384,385] + which are resolved correctly, and moreover, + should go away when `fdeclDEPRECATED' is removed. + +-- --------------------------------------------------------------------------- +-- Adding location info + +This is done in a stylised way using the three macros below, L0, L1 +and LL. Each of these macros can be thought of as having type + + L0, L1, LL :: a -> Located a + +They each add a SrcSpan to their argument. + + L0 adds 'noSrcSpan', used for empty productions + + L1 for a production with a single token on the lhs. Grabs the SrcSpan + from that token. + + LL for a production with >1 token on the lhs. Makes up a SrcSpan from + the first and last tokens. + +These suffice for the majority of cases. However, we must be +especially careful with empty productions: LL won't work if the first +or last token on the lhs can represent an empty span. In these cases, +we have to calculate the span using more of the tokens from the lhs, eg. + + | 'newtype' tycl_hdr '=' newconstr deriving + { L (comb3 $1 $4 $5) + (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) } + +We provide comb3 and comb4 functions which are useful in such cases. + +Be careful: there's no checking that you actually got this right, the +only symptom will be that the SrcSpans of your syntax will be +incorrect. + +/* + * We must expand these macros *before* running Happy, which is why this file is + * Parser.y.pp rather than just Parser.y - we run the C pre-processor first. + */ +#define L0 L noSrcSpan +#define L1 sL (getLoc $1) +#define LL sL (comb2 $1 $>) + +-- ----------------------------------------------------------------------------- + +-} + +%token + '_' { L _ ITunderscore } -- Haskell keywords + 'as' { L _ ITas } + 'case' { L _ ITcase } + 'class' { L _ ITclass } + 'data' { L _ ITdata } + 'default' { L _ ITdefault } + 'deriving' { L _ ITderiving } + 'do' { L _ ITdo } + 'else' { L _ ITelse } + 'hiding' { L _ IThiding } + 'if' { L _ ITif } + 'import' { L _ ITimport } + 'in' { L _ ITin } + 'infix' { L _ ITinfix } + 'infixl' { L _ ITinfixl } + 'infixr' { L _ ITinfixr } + 'instance' { L _ ITinstance } + 'let' { L _ ITlet } + 'module' { L _ ITmodule } + 'newtype' { L _ ITnewtype } + 'of' { L _ ITof } + 'qualified' { L _ ITqualified } + 'then' { L _ ITthen } + 'type' { L _ ITtype } + 'where' { L _ ITwhere } + '_scc_' { L _ ITscc } -- ToDo: remove + + 'forall' { L _ ITforall } -- GHC extension keywords + 'foreign' { L _ ITforeign } + 'export' { L _ ITexport } + 'label' { L _ ITlabel } + 'dynamic' { L _ ITdynamic } + 'safe' { L _ ITsafe } + 'threadsafe' { L _ ITthreadsafe } + 'unsafe' { L _ ITunsafe } + 'mdo' { L _ ITmdo } + 'stdcall' { L _ ITstdcallconv } + 'ccall' { L _ ITccallconv } + 'dotnet' { L _ ITdotnet } + 'proc' { L _ ITproc } -- for arrow notation extension + 'rec' { L _ ITrec } -- for arrow notation extension + + '{-# SPECIALISE' { L _ ITspecialise_prag } + '{-# SOURCE' { L _ ITsource_prag } + '{-# INLINE' { L _ ITinline_prag } + '{-# NOINLINE' { L _ ITnoinline_prag } + '{-# RULES' { L _ ITrules_prag } + '{-# CORE' { L _ ITcore_prag } -- hdaume: annotated core + '{-# SCC' { L _ ITscc_prag } + '{-# DEPRECATED' { L _ ITdeprecated_prag } + '{-# UNPACK' { L _ ITunpack_prag } + '#-}' { L _ ITclose_prag } + + '..' { L _ ITdotdot } -- reserved symbols + ':' { L _ ITcolon } + '::' { L _ ITdcolon } + '=' { L _ ITequal } + '\\' { L _ ITlam } + '|' { L _ ITvbar } + '<-' { L _ ITlarrow } + '->' { L _ ITrarrow } + '@' { L _ ITat } + '~' { L _ ITtilde } + '=>' { L _ ITdarrow } + '-' { L _ ITminus } + '!' { L _ ITbang } + '*' { L _ ITstar } + '-<' { L _ ITlarrowtail } -- for arrow notation + '>-' { L _ ITrarrowtail } -- for arrow notation + '-<<' { L _ ITLarrowtail } -- for arrow notation + '>>-' { L _ ITRarrowtail } -- for arrow notation + '.' { L _ ITdot } + + '{' { L _ ITocurly } -- special symbols + '}' { L _ ITccurly } + '{|' { L _ ITocurlybar } + '|}' { L _ ITccurlybar } + vocurly { L _ ITvocurly } -- virtual open curly (from layout) + vccurly { L _ ITvccurly } -- virtual close curly (from layout) + '[' { L _ ITobrack } + ']' { L _ ITcbrack } + '[:' { L _ ITopabrack } + ':]' { L _ ITcpabrack } + '(' { L _ IToparen } + ')' { L _ ITcparen } + '(#' { L _ IToubxparen } + '#)' { L _ ITcubxparen } + '(|' { L _ IToparenbar } + '|)' { L _ ITcparenbar } + ';' { L _ ITsemi } + ',' { L _ ITcomma } + '`' { L _ ITbackquote } + + VARID { L _ (ITvarid _) } -- identifiers + CONID { L _ (ITconid _) } + VARSYM { L _ (ITvarsym _) } + CONSYM { L _ (ITconsym _) } + QVARID { L _ (ITqvarid _) } + QCONID { L _ (ITqconid _) } + QVARSYM { L _ (ITqvarsym _) } + QCONSYM { L _ (ITqconsym _) } + + IPDUPVARID { L _ (ITdupipvarid _) } -- GHC extension + IPSPLITVARID { L _ (ITsplitipvarid _) } -- GHC extension + + CHAR { L _ (ITchar _) } + STRING { L _ (ITstring _) } + INTEGER { L _ (ITinteger _) } + RATIONAL { L _ (ITrational _) } + + PRIMCHAR { L _ (ITprimchar _) } + PRIMSTRING { L _ (ITprimstring _) } + PRIMINTEGER { L _ (ITprimint _) } + PRIMFLOAT { L _ (ITprimfloat _) } + PRIMDOUBLE { L _ (ITprimdouble _) } + +-- Template Haskell +'[|' { L _ ITopenExpQuote } +'[p|' { L _ ITopenPatQuote } +'[t|' { L _ ITopenTypQuote } +'[d|' { L _ ITopenDecQuote } +'|]' { L _ ITcloseQuote } +TH_ID_SPLICE { L _ (ITidEscape _) } -- $x +'$(' { L _ ITparenEscape } -- $( exp ) +TH_VAR_QUOTE { L _ ITvarQuote } -- 'x +TH_TY_QUOTE { L _ ITtyQuote } -- ''T + +%monad { P } { >>= } { return } +%lexer { lexer } { L _ ITeof } +%name parseModule module +%name parseStmt maybe_stmt +%name parseIdentifier identifier +%name parseIface iface +%tokentype { Located Token } +%% + +----------------------------------------------------------------------------- +-- Module Header + +-- The place for module deprecation is really too restrictive, but if it +-- was allowed at its natural place just before 'module', we get an ugly +-- s/r conflict with the second alternative. Another solution would be the +-- introduction of a new pragma DEPRECATED_MODULE, but this is not very nice, +-- either, and DEPRECATED is only expected to be used by people who really +-- know what they are doing. :-) + +module :: { Located (HsModule RdrName) } + : 'module' modid maybemoddeprec maybeexports 'where' body + {% fileSrcSpan >>= \ loc -> + return (L loc (HsModule (Just (L (getLoc $2) + (mkHomeModule (unLoc $2)))) + $4 (fst $6) (snd $6) $3)) } + | missing_module_keyword top close + {% fileSrcSpan >>= \ loc -> + return (L loc (HsModule Nothing Nothing + (fst $2) (snd $2) Nothing)) } + +missing_module_keyword :: { () } + : {- empty -} {% pushCurrentContext } + +maybemoddeprec :: { Maybe DeprecTxt } + : '{-# DEPRECATED' STRING '#-}' { Just (getSTRING $2) } + | {- empty -} { Nothing } + +body :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } + : '{' top '}' { $2 } + | vocurly top close { $2 } + +top :: { ([LImportDecl RdrName], [LHsDecl RdrName]) } + : importdecls { (reverse $1,[]) } + | importdecls ';' cvtopdecls { (reverse $1,$3) } + | cvtopdecls { ([],$1) } + +cvtopdecls :: { [LHsDecl RdrName] } + : topdecls { cvTopDecls $1 } + +----------------------------------------------------------------------------- +-- Interfaces (.hi-boot files) + +iface :: { ModIface } + : 'module' modid 'where' ifacebody { mkBootIface (unLoc $2) $4 } + +ifacebody :: { [HsDecl RdrName] } + : '{' ifacedecls '}' { $2 } + | vocurly ifacedecls close { $2 } + +ifacedecls :: { [HsDecl RdrName] } + : ifacedecl ';' ifacedecls { $1 : $3 } + | ';' ifacedecls { $2 } + | ifacedecl { [$1] } + | {- empty -} { [] } + +ifacedecl :: { HsDecl RdrName } + : var '::' sigtype + { SigD (Sig $1 $3) } + | 'type' syn_hdr '=' ctype + { let (tc,tvs) = $2 in TyClD (TySynonym tc tvs $4) } + | 'data' tycl_hdr + { TyClD (mkTyData DataType (unLoc $2) [] Nothing) } + | 'newtype' tycl_hdr + { TyClD (mkTyData NewType (unLoc $2) [] Nothing) } + | 'class' tycl_hdr fds + { TyClD (mkClassDecl (unLoc $2) (unLoc $3) [] emptyBag) } + +----------------------------------------------------------------------------- +-- The Export List + +maybeexports :: { Maybe [LIE RdrName] } + : '(' exportlist ')' { Just $2 } + | {- empty -} { Nothing } + +exportlist :: { [LIE RdrName] } + : exportlist ',' export { $3 : $1 } + | exportlist ',' { $1 } + | export { [$1] } + | {- empty -} { [] } + + -- No longer allow things like [] and (,,,) to be exported + -- They are built in syntax, always available +export :: { LIE RdrName } + : qvar { L1 (IEVar (unLoc $1)) } + | oqtycon { L1 (IEThingAbs (unLoc $1)) } + | oqtycon '(' '..' ')' { LL (IEThingAll (unLoc $1)) } + | oqtycon '(' ')' { LL (IEThingWith (unLoc $1) []) } + | oqtycon '(' qcnames ')' { LL (IEThingWith (unLoc $1) (reverse $3)) } + | 'module' modid { LL (IEModuleContents (unLoc $2)) } + +qcnames :: { [RdrName] } + : qcnames ',' qcname { unLoc $3 : $1 } + | qcname { [unLoc $1] } + +qcname :: { Located RdrName } -- Variable or data constructor + : qvar { $1 } + | gcon { $1 } + +----------------------------------------------------------------------------- +-- Import Declarations + +-- import decls can be *empty*, or even just a string of semicolons +-- whereas topdecls must contain at least one topdecl. + +importdecls :: { [LImportDecl RdrName] } + : importdecls ';' importdecl { $3 : $1 } + | importdecls ';' { $1 } + | importdecl { [ $1 ] } + | {- empty -} { [] } + +importdecl :: { LImportDecl RdrName } + : 'import' maybe_src optqualified modid maybeas maybeimpspec + { L (comb4 $1 $4 $5 $6) (ImportDecl $4 $2 $3 (unLoc $5) (unLoc $6)) } + +maybe_src :: { IsBootInterface } + : '{-# SOURCE' '#-}' { True } + | {- empty -} { False } + +optqualified :: { Bool } + : 'qualified' { True } + | {- empty -} { False } + +maybeas :: { Located (Maybe ModuleName) } + : 'as' modid { LL (Just (unLoc $2)) } + | {- empty -} { noLoc Nothing } + +maybeimpspec :: { Located (Maybe (Bool, [LIE RdrName])) } + : impspec { L1 (Just (unLoc $1)) } + | {- empty -} { noLoc Nothing } + +impspec :: { Located (Bool, [LIE RdrName]) } + : '(' exportlist ')' { LL (False, reverse $2) } + | 'hiding' '(' exportlist ')' { LL (True, reverse $3) } + +----------------------------------------------------------------------------- +-- Fixity Declarations + +prec :: { Int } + : {- empty -} { 9 } + | INTEGER {% checkPrecP (L1 (fromInteger (getINTEGER $1))) } + +infix :: { Located FixityDirection } + : 'infix' { L1 InfixN } + | 'infixl' { L1 InfixL } + | 'infixr' { L1 InfixR } + +ops :: { Located [Located RdrName] } + : ops ',' op { LL ($3 : unLoc $1) } + | op { L1 [$1] } + +----------------------------------------------------------------------------- +-- Top-Level Declarations + +topdecls :: { [RdrBinding] } -- Reversed + : topdecls ';' topdecl { $3 : $1 } + | topdecls ';' { $1 } + | topdecl { [$1] } + +topdecl :: { RdrBinding } + : tycl_decl { RdrHsDecl (L1 (TyClD (unLoc $1))) } + | 'instance' inst_type where + { let (binds,sigs) = cvBindsAndSigs (unLoc $3) + in RdrHsDecl (L (comb3 $1 $2 $3) (InstD (InstDecl $2 binds sigs))) } + | 'default' '(' comma_types0 ')' { RdrHsDecl (LL $ DefD (DefaultDecl $3)) } + | 'foreign' fdecl { RdrHsDecl (LL (unLoc $2)) } + | '{-# DEPRECATED' deprecations '#-}' { RdrBindings (reverse $2) } + | '{-# RULES' rules '#-}' { RdrBindings (reverse $2) } + | '$(' exp ')' { RdrHsDecl (LL $ SpliceD (SpliceDecl $2)) } + | decl { unLoc $1 } + +tycl_decl :: { LTyClDecl RdrName } + : 'type' syn_hdr '=' ctype + -- Note ctype, not sigtype. + -- We allow an explicit for-all but we don't insert one + -- in type Foo a = (b,b) + -- Instead we just say b is out of scope + { LL $ let (tc,tvs) = $2 in TySynonym tc tvs $4 } + + | 'data' tycl_hdr constrs deriving + { L (comb4 $1 $2 $3 $4) + (mkTyData DataType (unLoc $2) (reverse (unLoc $3)) (unLoc $4)) } + + | 'newtype' tycl_hdr '=' newconstr deriving + { L (comb3 $1 $4 $5) + (mkTyData NewType (unLoc $2) [$4] (unLoc $5)) } + + | 'class' tycl_hdr fds where + { let + (binds,sigs) = cvBindsAndSigs (unLoc $4) + in + L (comb4 $1 $2 $3 $4) (mkClassDecl (unLoc $2) (unLoc $3) sigs + binds) } + +syn_hdr :: { (Located RdrName, [LHsTyVarBndr RdrName]) } + -- We don't retain the syntax of an infix + -- type synonym declaration. Oh well. + : tycon tv_bndrs { ($1, $2) } + | tv_bndr tyconop tv_bndr { ($2, [$1,$3]) } + +-- tycl_hdr parses the header of a type or class decl, +-- which takes the form +-- T a b +-- Eq a => T a +-- (Eq a, Ord b) => T a b +-- Rather a lot of inlining here, else we get reduce/reduce errors +tycl_hdr :: { Located (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) } + : context '=>' type {% checkTyClHdr $1 $3 >>= return.LL } + | type {% checkTyClHdr (noLoc []) $1 >>= return.L1 } + +----------------------------------------------------------------------------- +-- Nested declarations + +decls :: { Located [RdrBinding] } -- Reversed + : decls ';' decl { LL (unLoc $3 : unLoc $1) } + | decls ';' { LL (unLoc $1) } + | decl { L1 [unLoc $1] } + | {- empty -} { noLoc [] } + + +decllist :: { Located [RdrBinding] } -- Reversed + : '{' decls '}' { LL (unLoc $2) } + | vocurly decls close { $2 } + +where :: { Located [RdrBinding] } -- Reversed + -- No implicit parameters + : 'where' decllist { LL (unLoc $2) } + | {- empty -} { noLoc [] } + +binds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters + : decllist { L1 [cvBindGroup (unLoc $1)] } + | '{' dbinds '}' { LL [HsIPBinds (unLoc $2)] } + | vocurly dbinds close { L (getLoc $2) [HsIPBinds (unLoc $2)] } + +wherebinds :: { Located [HsBindGroup RdrName] } -- May have implicit parameters + : 'where' binds { LL (unLoc $2) } + | {- empty -} { noLoc [] } + + +----------------------------------------------------------------------------- +-- Transformation Rules + +rules :: { [RdrBinding] } -- Reversed + : rules ';' rule { $3 : $1 } + | rules ';' { $1 } + | rule { [$1] } + | {- empty -} { [] } + +rule :: { RdrBinding } + : STRING activation rule_forall infixexp '=' exp + { RdrHsDecl (LL $ RuleD (HsRule (getSTRING $1) $2 $3 $4 $6)) } + +activation :: { Activation } -- Omitted means AlwaysActive + : {- empty -} { AlwaysActive } + | explicit_activation { $1 } + +inverse_activation :: { Activation } -- Omitted means NeverActive + : {- empty -} { NeverActive } + | explicit_activation { $1 } + +explicit_activation :: { Activation } -- In brackets + : '[' INTEGER ']' { ActiveAfter (fromInteger (getINTEGER $2)) } + | '[' '~' INTEGER ']' { ActiveBefore (fromInteger (getINTEGER $3)) } + +rule_forall :: { [RuleBndr RdrName] } + : 'forall' rule_var_list '.' { $2 } + | {- empty -} { [] } + +rule_var_list :: { [RuleBndr RdrName] } + : rule_var { [$1] } + | rule_var rule_var_list { $1 : $2 } + +rule_var :: { RuleBndr RdrName } + : varid { RuleBndr $1 } + | '(' varid '::' ctype ')' { RuleBndrSig $2 $4 } + +----------------------------------------------------------------------------- +-- Deprecations (c.f. rules) + +deprecations :: { [RdrBinding] } -- Reversed + : deprecations ';' deprecation { $3 : $1 } + | deprecations ';' { $1 } + | deprecation { [$1] } + | {- empty -} { [] } + +-- SUP: TEMPORARY HACK, not checking for `module Foo' +deprecation :: { RdrBinding } + : depreclist STRING + { RdrBindings [ RdrHsDecl (LL $ DeprecD (Deprecation n (getSTRING $2))) | n <- unLoc $1 ] } + + +----------------------------------------------------------------------------- +-- Foreign import and export declarations + +-- for the time being, the following accepts foreign declarations conforming +-- to the FFI Addendum, Version 1.0 as well as pre-standard declarations +-- +-- * a flag indicates whether pre-standard declarations have been used and +-- triggers a deprecation warning further down the road +-- +-- NB: The first two rules could be combined into one by replacing `safety1' +-- with `safety'. However, the combined rule conflicts with the +-- DEPRECATED rules. +-- +fdecl :: { LHsDecl RdrName } +fdecl : 'import' callconv safety1 fspec + {% mkImport $2 $3 (unLoc $4) >>= return.LL } + | 'import' callconv fspec + {% do { d <- mkImport $2 (PlaySafe False) (unLoc $3); + return (LL d) } } + | 'export' callconv fspec + {% mkExport $2 (unLoc $3) >>= return.LL } + -- the following syntax is DEPRECATED + | fdecl1DEPRECATED { L1 (ForD (unLoc $1)) } + | fdecl2DEPRECATED { L1 (unLoc $1) } + +fdecl1DEPRECATED :: { LForeignDecl RdrName } +fdecl1DEPRECATED + ----------- DEPRECATED label decls ------------ + : 'label' ext_name varid '::' sigtype + { LL $ ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS + (CLabel ($2 `orElse` mkExtName (unLoc $3)))) True } + + ----------- DEPRECATED ccall/stdcall decls ------------ + -- + -- NB: This business with the case expression below may seem overly + -- complicated, but it is necessary to avoid some conflicts. + + -- DEPRECATED variant #1: lack of a calling convention specification + -- (import) + | 'import' {-no callconv-} ext_name safety varid_no_unsafe '::' sigtype + { let + target = StaticTarget ($2 `orElse` mkExtName (unLoc $4)) + in + LL $ ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS + (CFunction target)) True } + + -- DEPRECATED variant #2: external name consists of two separate strings + -- (module name and function name) (import) + | 'import' callconv STRING STRING safety varid_no_unsafe '::' sigtype + {% case $2 of + DNCall -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import" + CCall cconv -> return $ + let + imp = CFunction (StaticTarget (getSTRING $4)) + in + LL $ ForeignImport $6 $8 (CImport cconv $5 nilFS nilFS imp) True } + + -- DEPRECATED variant #3: `unsafe' after entity + | 'import' callconv STRING 'unsafe' varid_no_unsafe '::' sigtype + {% case $2 of + DNCall -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import" + CCall cconv -> return $ + let + imp = CFunction (StaticTarget (getSTRING $3)) + in + LL $ ForeignImport $5 $7 (CImport cconv PlayRisky nilFS nilFS imp) True } + + -- DEPRECATED variant #4: use of the special identifier `dynamic' without + -- an explicit calling convention (import) + | 'import' {-no callconv-} 'dynamic' safety varid_no_unsafe '::' sigtype + { LL $ ForeignImport $4 $6 (CImport defaultCCallConv $3 nilFS nilFS + (CFunction DynamicTarget)) True } + + -- DEPRECATED variant #5: use of the special identifier `dynamic' (import) + | 'import' callconv 'dynamic' safety varid_no_unsafe '::' sigtype + {% case $2 of + DNCall -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import" + CCall cconv -> return $ + LL $ ForeignImport $5 $7 (CImport cconv $4 nilFS nilFS + (CFunction DynamicTarget)) True } + + -- DEPRECATED variant #6: lack of a calling convention specification + -- (export) + | 'export' {-no callconv-} ext_name varid '::' sigtype + { LL $ ForeignExport $3 $5 (CExport (CExportStatic ($2 `orElse` mkExtName (unLoc $3)) + defaultCCallConv)) True } + + -- DEPRECATED variant #7: external name consists of two separate strings + -- (module name and function name) (export) + | 'export' callconv STRING STRING varid '::' sigtype + {% case $2 of + DNCall -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import" + CCall cconv -> return $ + LL $ ForeignExport $5 $7 + (CExport (CExportStatic (getSTRING $4) cconv)) True } + + -- DEPRECATED variant #8: use of the special identifier `dynamic' without + -- an explicit calling convention (export) + | 'export' {-no callconv-} 'dynamic' varid '::' sigtype + { LL $ ForeignImport $3 $5 (CImport defaultCCallConv (PlaySafe False) nilFS nilFS + CWrapper) True } + + -- DEPRECATED variant #9: use of the special identifier `dynamic' (export) + | 'export' callconv 'dynamic' varid '::' sigtype + {% case $2 of + DNCall -> parseError (comb2 $1 $>) "Illegal format of .NET foreign import" + CCall cconv -> return $ + LL $ ForeignImport $4 $6 + (CImport cconv (PlaySafe False) nilFS nilFS CWrapper) True } + + ----------- DEPRECATED .NET decls ------------ + -- NB: removed the .NET call declaration, as it is entirely subsumed + -- by the new standard FFI declarations + +fdecl2DEPRECATED :: { LHsDecl RdrName } +fdecl2DEPRECATED + : 'import' 'dotnet' 'type' ext_name tycon { LL $ TyClD (ForeignType $5 $4 DNType) } + -- left this one unchanged for the moment as type imports are not + -- covered currently by the FFI standard -=chak + + +callconv :: { CallConv } + : 'stdcall' { CCall StdCallConv } + | 'ccall' { CCall CCallConv } + | 'dotnet' { DNCall } + +safety :: { Safety } + : 'unsafe' { PlayRisky } + | 'safe' { PlaySafe False } + | 'threadsafe' { PlaySafe True } + | {- empty -} { PlaySafe False } + +safety1 :: { Safety } + : 'unsafe' { PlayRisky } + | 'safe' { PlaySafe False } + | 'threadsafe' { PlaySafe True } + -- only needed to avoid conflicts with the DEPRECATED rules + +fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } + : STRING var '::' sigtype { LL (L (getLoc $1) (getSTRING $1), $2, $4) } + | var '::' sigtype { LL (noLoc nilFS, $1, $3) } + -- if the entity string is missing, it defaults to the empty string; + -- the meaning of an empty entity string depends on the calling + -- convention + +-- DEPRECATED syntax +ext_name :: { Maybe CLabelString } + : STRING { Just (getSTRING $1) } + | STRING STRING { Just (getSTRING $2) } -- Ignore "module name" for now + | {- empty -} { Nothing } + + +----------------------------------------------------------------------------- +-- Type signatures + +opt_sig :: { Maybe (LHsType RdrName) } + : {- empty -} { Nothing } + | '::' sigtype { Just $2 } + +opt_asig :: { Maybe (LHsType RdrName) } + : {- empty -} { Nothing } + | '::' atype { Just $2 } + +sigtypes :: { [LHsType RdrName] } + : sigtype { [ $1 ] } + | sigtypes ',' sigtype { $3 : $1 } + +sigtype :: { LHsType RdrName } + : ctype { L1 (mkImplicitHsForAllTy (noLoc []) $1) } + -- Wrap an Implicit forall if there isn't one there already + +sig_vars :: { Located [Located RdrName] } + : sig_vars ',' var { LL ($3 : unLoc $1) } + | var { L1 [$1] } + +----------------------------------------------------------------------------- +-- Types + +-- A ctype is a for-all type +ctype :: { LHsType RdrName } + : 'forall' tv_bndrs '.' ctype { LL $ mkExplicitHsForAllTy $2 (noLoc []) $4 } + | context '=>' type { LL $ mkImplicitHsForAllTy $1 $3 } + -- A type of form (context => type) is an *implicit* HsForAllTy + | type { $1 } + +-- We parse a context as a btype so that we don't get reduce/reduce +-- errors in ctype. The basic problem is that +-- (Eq a, Ord a) +-- looks so much like a tuple type. We can't tell until we find the => +context :: { LHsContext RdrName } + : btype {% checkContext $1 } + +type :: { LHsType RdrName } + : ipvar '::' gentype { LL (HsPredTy (LL $ HsIParam (unLoc $1) $3)) } + | gentype { $1 } + +gentype :: { LHsType RdrName } + : btype { $1 } + | btype qtyconop gentype { LL $ HsOpTy $1 $2 $3 } + | btype '`' tyvar '`' gentype { LL $ HsOpTy $1 $3 $5 } + | btype '->' gentype { LL $ HsFunTy $1 $3 } + +btype :: { LHsType RdrName } + : btype atype { LL $ HsAppTy $1 $2 } + | atype { $1 } + +atype :: { LHsType RdrName } + : gtycon { L1 (HsTyVar (unLoc $1)) } + | tyvar { L1 (HsTyVar (unLoc $1)) } + | '(' type ',' comma_types1 ')' { LL $ HsTupleTy Boxed ($2:$4) } + | '(#' comma_types1 '#)' { LL $ HsTupleTy Unboxed $2 } + | '[' type ']' { LL $ HsListTy $2 } + | '[:' type ':]' { LL $ HsPArrTy $2 } + | '(' ctype ')' { LL $ HsParTy $2 } + | '(' ctype '::' kind ')' { LL $ HsKindSig $2 $4 } +-- Generics + | INTEGER { L1 (HsNumTy (getINTEGER $1)) } + +-- An inst_type is what occurs in the head of an instance decl +-- e.g. (Foo a, Gaz b) => Wibble a b +-- It's kept as a single type, with a MonoDictTy at the right +-- hand corner, for convenience. +inst_type :: { LHsType RdrName } + : ctype {% checkInstType $1 } + +comma_types0 :: { [LHsType RdrName] } + : comma_types1 { $1 } + | {- empty -} { [] } + +comma_types1 :: { [LHsType RdrName] } + : type { [$1] } + | type ',' comma_types1 { $1 : $3 } + +tv_bndrs :: { [LHsTyVarBndr RdrName] } + : tv_bndr tv_bndrs { $1 : $2 } + | {- empty -} { [] } + +tv_bndr :: { LHsTyVarBndr RdrName } + : tyvar { L1 (UserTyVar (unLoc $1)) } + | '(' tyvar '::' kind ')' { LL (KindedTyVar (unLoc $2) $4) } + +fds :: { Located [Located ([RdrName], [RdrName])] } + : {- empty -} { noLoc [] } + | '|' fds1 { LL (reverse (unLoc $2)) } + +fds1 :: { Located [Located ([RdrName], [RdrName])] } + : fds1 ',' fd { LL ($3 : unLoc $1) } + | fd { L1 [$1] } + +fd :: { Located ([RdrName], [RdrName]) } + : varids0 '->' varids0 { L (comb3 $1 $2 $3) + (reverse (unLoc $1), reverse (unLoc $3)) } + +varids0 :: { Located [RdrName] } + : {- empty -} { noLoc [] } + | varids0 tyvar { LL (unLoc $2 : unLoc $1) } + +----------------------------------------------------------------------------- +-- Kinds + +kind :: { Kind } + : akind { $1 } + | akind '->' kind { mkArrowKind $1 $3 } + +akind :: { Kind } + : '*' { liftedTypeKind } + | '(' kind ')' { $2 } + + +----------------------------------------------------------------------------- +-- Datatype declarations + +newconstr :: { LConDecl RdrName } + : conid atype { LL $ ConDecl $1 [] (noLoc []) + (PrefixCon [(unbangedType $2)]) } + | conid '{' var '::' ctype '}' + { LL $ ConDecl $1 [] (noLoc []) + (RecCon [($3, (unbangedType $5))]) } + +constrs :: { Located [LConDecl RdrName] } + : {- empty; a GHC extension -} { noLoc [] } + | '=' constrs1 { LL (unLoc $2) } + +constrs1 :: { Located [LConDecl RdrName] } + : constrs1 '|' constr { LL ($3 : unLoc $1) } + | constr { L1 [$1] } + +constr :: { LConDecl RdrName } + : forall context '=>' constr_stuff + { let (con,details) = unLoc $4 in + LL (ConDecl con (unLoc $1) $2 details) } + | forall constr_stuff + { let (con,details) = unLoc $2 in + LL (ConDecl con (unLoc $1) (noLoc []) details) } + +forall :: { Located [LHsTyVarBndr RdrName] } + : 'forall' tv_bndrs '.' { LL $2 } + | {- empty -} { noLoc [] } + +constr_stuff :: { Located (Located RdrName, HsConDetails RdrName (LBangType RdrName)) } + : btype {% mkPrefixCon $1 [] >>= return.LL } + | btype bang_atype satypes {% do { r <- mkPrefixCon $1 ($2 : unLoc $3); + return (L (comb3 $1 $2 $3) r) } } + | oqtycon '{' '}' {% mkRecCon $1 [] >>= return.LL } + | oqtycon '{' fielddecls '}' {% mkRecCon $1 $3 >>= return.LL } + | sbtype conop sbtype { LL ($2, InfixCon $1 $3) } + +bang_atype :: { LBangType RdrName } + : strict_mark atype { LL (BangType (unLoc $1) $2) } + +satypes :: { Located [LBangType RdrName] } + : atype satypes { LL (unbangedType $1 : unLoc $2) } + | bang_atype satypes { LL ($1 : unLoc $2) } + | {- empty -} { noLoc [] } + +sbtype :: { LBangType RdrName } + : btype { unbangedType $1 } + | strict_mark atype { LL (BangType (unLoc $1) $2) } + +fielddecls :: { [([Located RdrName], LBangType RdrName)] } + : fielddecl ',' fielddecls { unLoc $1 : $3 } + | fielddecl { [unLoc $1] } + +fielddecl :: { Located ([Located RdrName], LBangType RdrName) } + : sig_vars '::' stype { LL (reverse (unLoc $1), $3) } + +stype :: { LBangType RdrName } + : ctype { unbangedType $1 } + | strict_mark atype { LL (BangType (unLoc $1) $2) } + +strict_mark :: { Located HsBang } + : '!' { L1 HsStrict } + | '{-# UNPACK' '#-}' '!' { LL HsUnbox } + +deriving :: { Located (Maybe (LHsContext RdrName)) } + : {- empty -} { noLoc Nothing } + | 'deriving' context { LL (Just $2) } + -- Glasgow extension: allow partial + -- applications in derivings + +----------------------------------------------------------------------------- +-- Value definitions + +{- There's an awkward overlap with a type signature. Consider + f :: Int -> Int = ...rhs... + Then we can't tell whether it's a type signature or a value + definition with a result signature until we see the '='. + So we have to inline enough to postpone reductions until we know. +-} + +{- + ATTENTION: Dirty Hackery Ahead! If the second alternative of vars is var + instead of qvar, we get another shift/reduce-conflict. Consider the + following programs: + + { (^^) :: Int->Int ; } Type signature; only var allowed + + { (^^) :: Int->Int = ... ; } Value defn with result signature; + qvar allowed (because of instance decls) + + We can't tell whether to reduce var to qvar until after we've read the signatures. +-} + +decl :: { Located RdrBinding } + : sigdecl { $1 } + | infixexp opt_sig rhs {% do { r <- checkValDef $1 $2 (unLoc $3); + return (LL $ RdrValBinding (LL r)) } } + +rhs :: { Located (GRHSs RdrName) } + : '=' exp wherebinds { L (comb3 $1 $2 $3) $ GRHSs (unguardedRHS $2) (unLoc $3) placeHolderType } + | gdrhs wherebinds { LL $ GRHSs (reverse (unLoc $1)) (unLoc $2) placeHolderType } + +gdrhs :: { Located [LGRHS RdrName] } + : gdrhs gdrh { LL ($2 : unLoc $1) } + | gdrh { L1 [$1] } + +gdrh :: { LGRHS RdrName } + : '|' quals '=' exp { LL $ GRHS (reverse (L (getLoc $4) (ResultStmt $4) : + unLoc $2)) } + +sigdecl :: { Located RdrBinding } + : infixexp '::' sigtype + {% do s <- checkValSig $1 $3; + return (LL $ RdrHsDecl (LL $ SigD s)) } + -- See the above notes for why we need infixexp here + | var ',' sig_vars '::' sigtype + { LL $ mkSigDecls [ LL $ Sig n $5 | n <- $1 : unLoc $3 ] } + | infix prec ops { LL $ mkSigDecls [ LL $ FixSig (FixitySig n (Fixity $2 (unLoc $1))) + | n <- unLoc $3 ] } + | '{-# INLINE' activation qvar '#-}' + { LL $ RdrHsDecl (LL $ SigD (InlineSig True $3 $2)) } + | '{-# NOINLINE' inverse_activation qvar '#-}' + { LL $ RdrHsDecl (LL $ SigD (InlineSig False $3 $2)) } + | '{-# SPECIALISE' qvar '::' sigtypes '#-}' + { LL $ mkSigDecls [ LL $ SpecSig $2 t | t <- $4] } + | '{-# SPECIALISE' 'instance' inst_type '#-}' + { LL $ RdrHsDecl (LL $ SigD (SpecInstSig $3)) } + +----------------------------------------------------------------------------- +-- Expressions + +exp :: { LHsExpr RdrName } + : infixexp '::' sigtype { LL $ ExprWithTySig $1 $3 } + | fexp '-<' exp { LL $ HsArrApp $1 $3 placeHolderType HsFirstOrderApp True } + | fexp '>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsFirstOrderApp False } + | fexp '-<<' exp { LL $ HsArrApp $1 $3 placeHolderType HsHigherOrderApp True } + | fexp '>>-' exp { LL $ HsArrApp $3 $1 placeHolderType HsHigherOrderApp False} + | infixexp { $1 } + +infixexp :: { LHsExpr RdrName } + : exp10 { $1 } + | infixexp qop exp10 { LL (OpApp $1 $2 (panic "fixity") $3) } + +exp10 :: { LHsExpr RdrName } + : '\\' aexp aexps opt_asig '->' exp + {% checkPatterns ($2 : reverse $3) >>= \ ps -> + return (LL $ HsLam (LL $ Match ps $4 + (GRHSs (unguardedRHS $6) [] + placeHolderType))) } + | 'let' binds 'in' exp { LL $ HsLet (unLoc $2) $4 } + | 'if' exp 'then' exp 'else' exp { LL $ HsIf $2 $4 $6 } + | 'case' exp 'of' altslist { LL $ HsCase $2 (unLoc $4) } + | '-' fexp { LL $ mkHsNegApp $2 } + + | 'do' stmtlist {% let loc = comb2 $1 $2 in + checkDo loc (unLoc $2) >>= \ stmts -> + return (L loc (mkHsDo DoExpr stmts)) } + | 'mdo' stmtlist {% let loc = comb2 $1 $2 in + checkMDo loc (unLoc $2) >>= \ stmts -> + return (L loc (mkHsDo MDoExpr stmts)) } + + | scc_annot exp { LL $ if opt_SccProfilingOn + then HsSCC (unLoc $1) $2 + else HsPar $2 } + + | 'proc' aexp '->' exp + {% checkPattern $2 >>= \ p -> + return (LL $ HsProc p (LL $ HsCmdTop $4 [] + placeHolderType undefined)) } + -- TODO: is LL right here? + + | '{-# CORE' STRING '#-}' exp { LL $ HsCoreAnn (getSTRING $2) $4 } + -- hdaume: core annotation + | fexp { $1 } + +scc_annot :: { Located FastString } + : '_scc_' STRING { LL $ getSTRING $2 } + | '{-# SCC' STRING '#-}' { LL $ getSTRING $2 } + +fexp :: { LHsExpr RdrName } + : fexp aexp { LL $ HsApp $1 $2 } + | aexp { $1 } + +aexps :: { [LHsExpr RdrName] } + : aexps aexp { $2 : $1 } + | {- empty -} { [] } + +aexp :: { LHsExpr RdrName } + : qvar '@' aexp { LL $ EAsPat $1 $3 } + | '~' aexp { LL $ ELazyPat $2 } + | aexp1 { $1 } + +aexp1 :: { LHsExpr RdrName } + : aexp1 '{' fbinds '}' {% do { r <- mkRecConstrOrUpdate $1 (comb2 $2 $4) + (reverse $3); + return (LL r) }} + | aexp2 { $1 } + +-- Here was the syntax for type applications that I was planning +-- but there are difficulties (e.g. what order for type args) +-- so it's not enabled yet. +-- But this case *is* used for the left hand side of a generic definition, +-- which is parsed as an expression before being munged into a pattern + | qcname '{|' gentype '|}' { LL $ HsApp (sL (getLoc $1) (HsVar (unLoc $1))) + (sL (getLoc $3) (HsType $3)) } + +aexp2 :: { LHsExpr RdrName } + : ipvar { L1 (HsIPVar $! unLoc $1) } + | qcname { L1 (HsVar $! unLoc $1) } + | literal { L1 (HsLit $! unLoc $1) } + | INTEGER { L1 (HsOverLit $! mkHsIntegral (getINTEGER $1)) } + | RATIONAL { L1 (HsOverLit $! mkHsFractional (getRATIONAL $1)) } + | '(' exp ')' { LL (HsPar $2) } + | '(' exp ',' texps ')' { LL $ ExplicitTuple ($2 : reverse $4) Boxed } + | '(#' texps '#)' { LL $ ExplicitTuple (reverse $2) Unboxed } + | '[' list ']' { LL (unLoc $2) } + | '[:' parr ':]' { LL (unLoc $2) } + | '(' infixexp qop ')' { LL $ SectionL $2 $3 } + | '(' qopm infixexp ')' { LL $ SectionR $2 $3 } + | '_' { L1 EWildPat } + + -- MetaHaskell Extension + | TH_ID_SPLICE { L1 $ mkHsSplice + (L1 $ HsVar (mkUnqual varName + (getTH_ID_SPLICE $1))) } -- $x + | '$(' exp ')' { LL $ mkHsSplice $2 } -- $( exp ) + | TH_VAR_QUOTE qvar { LL $ HsBracket (VarBr (unLoc $2)) } + | TH_VAR_QUOTE qcon { LL $ HsBracket (VarBr (unLoc $2)) } + | TH_TY_QUOTE tyvar { LL $ HsBracket (VarBr (unLoc $2)) } + | TH_TY_QUOTE gtycon { LL $ HsBracket (VarBr (unLoc $2)) } + | '[|' exp '|]' { LL $ HsBracket (ExpBr $2) } + | '[t|' ctype '|]' { LL $ HsBracket (TypBr $2) } + | '[p|' infixexp '|]' {% checkPattern $2 >>= \p -> + return (LL $ HsBracket (PatBr p)) } + | '[d|' cvtopbody '|]' { LL $ HsBracket (DecBr (mkGroup $2)) } + + -- arrow notation extension + | '(|' aexp2 cmdargs '|)' { LL $ HsArrForm $2 Nothing (reverse $3) } + +cmdargs :: { [LHsCmdTop RdrName] } + : cmdargs acmd { $2 : $1 } + | {- empty -} { [] } + +acmd :: { LHsCmdTop RdrName } + : aexp2 { L1 $ HsCmdTop $1 [] placeHolderType undefined } + +cvtopbody :: { [LHsDecl RdrName] } + : '{' cvtopdecls '}' { $2 } + | vocurly cvtopdecls close { $2 } + +texps :: { [LHsExpr RdrName] } + : texps ',' exp { $3 : $1 } + | exp { [$1] } + + +----------------------------------------------------------------------------- +-- List expressions + +-- The rules below are little bit contorted to keep lexps left-recursive while +-- avoiding another shift/reduce-conflict. + +list :: { LHsExpr RdrName } + : exp { L1 $ ExplicitList placeHolderType [$1] } + | lexps { L1 $ ExplicitList placeHolderType (reverse (unLoc $1)) } + | exp '..' { LL $ ArithSeqIn (From $1) } + | exp ',' exp '..' { LL $ ArithSeqIn (FromThen $1 $3) } + | exp '..' exp { LL $ ArithSeqIn (FromTo $1 $3) } + | exp ',' exp '..' exp { LL $ ArithSeqIn (FromThenTo $1 $3 $5) } + | exp pquals { LL $ mkHsDo ListComp + (reverse (L (getLoc $1) (ResultStmt $1) : + unLoc $2)) } + +lexps :: { Located [LHsExpr RdrName] } + : lexps ',' exp { LL ($3 : unLoc $1) } + | exp ',' exp { LL [$3,$1] } + +----------------------------------------------------------------------------- +-- List Comprehensions + +pquals :: { Located [LStmt RdrName] } -- Either a singleton ParStmt, + -- or a reversed list of Stmts + : pquals1 { case unLoc $1 of + [qs] -> L1 qs + qss -> L1 [L1 (ParStmt stmtss)] + where + stmtss = [ (reverse qs, undefined) + | qs <- qss ] + } + +pquals1 :: { Located [[LStmt RdrName]] } + : pquals1 '|' quals { LL (unLoc $3 : unLoc $1) } + | '|' quals { L (getLoc $2) [unLoc $2] } + +quals :: { Located [LStmt RdrName] } + : quals ',' qual { LL ($3 : unLoc $1) } + | qual { L1 [$1] } + +----------------------------------------------------------------------------- +-- Parallel array expressions + +-- The rules below are little bit contorted; see the list case for details. +-- Note that, in contrast to lists, we only have finite arithmetic sequences. +-- Moreover, we allow explicit arrays with no element (represented by the nil +-- constructor in the list case). + +parr :: { LHsExpr RdrName } + : { noLoc (ExplicitPArr placeHolderType []) } + | exp { L1 $ ExplicitPArr placeHolderType [$1] } + | lexps { L1 $ ExplicitPArr placeHolderType + (reverse (unLoc $1)) } + | exp '..' exp { LL $ PArrSeqIn (FromTo $1 $3) } + | exp ',' exp '..' exp { LL $ PArrSeqIn (FromThenTo $1 $3 $5) } + | exp pquals { LL $ mkHsDo PArrComp + (reverse (L (getLoc $1) (ResultStmt $1) : + unLoc $2)) + } + +-- We are reusing `lexps' and `pquals' from the list case. + +----------------------------------------------------------------------------- +-- Case alternatives + +altslist :: { Located [LMatch RdrName] } + : '{' alts '}' { LL (reverse (unLoc $2)) } + | vocurly alts close { L (getLoc $2) (reverse (unLoc $2)) } + +alts :: { Located [LMatch RdrName] } + : alts1 { L1 (unLoc $1) } + | ';' alts { LL (unLoc $2) } + +alts1 :: { Located [LMatch RdrName] } + : alts1 ';' alt { LL ($3 : unLoc $1) } + | alts1 ';' { LL (unLoc $1) } + | alt { L1 [$1] } + +alt :: { LMatch RdrName } + : infixexp opt_sig alt_rhs {% checkPattern $1 >>= \p -> + return (LL (Match [p] $2 (unLoc $3))) } + +alt_rhs :: { Located (GRHSs RdrName) } + : ralt wherebinds { LL (GRHSs (unLoc $1) (unLoc $2) + placeHolderType) } + +ralt :: { Located [LGRHS RdrName] } + : '->' exp { LL (unguardedRHS $2) } + | gdpats { L1 (reverse (unLoc $1)) } + +gdpats :: { Located [LGRHS RdrName] } + : gdpats gdpat { LL ($2 : unLoc $1) } + | gdpat { L1 [$1] } + +gdpat :: { LGRHS RdrName } + : '|' quals '->' exp { let r = L (getLoc $4) (ResultStmt $4) + in LL $ GRHS (reverse (r : unLoc $2)) } + +----------------------------------------------------------------------------- +-- Statement sequences + +stmtlist :: { Located [LStmt RdrName] } + : '{' stmts '}' { LL (unLoc $2) } + | vocurly stmts close { $2 } + +-- do { ;; s ; s ; ; s ;; } +-- The last Stmt should be a ResultStmt, but that's hard to enforce +-- here, because we need too much lookahead if we see do { e ; } +-- So we use ExprStmts throughout, and switch the last one over +-- in ParseUtils.checkDo instead +stmts :: { Located [LStmt RdrName] } + : stmt stmts_help { LL ($1 : unLoc $2) } + | ';' stmts { LL (unLoc $2) } + | {- empty -} { noLoc [] } + +stmts_help :: { Located [LStmt RdrName] } -- might be empty + : ';' stmts { LL (unLoc $2) } + | {- empty -} { noLoc [] } + +-- For typing stmts at the GHCi prompt, where +-- the input may consist of just comments. +maybe_stmt :: { Maybe (LStmt RdrName) } + : stmt { Just $1 } + | {- nothing -} { Nothing } + +stmt :: { LStmt RdrName } + : qual { $1 } + | infixexp '->' exp {% checkPattern $3 >>= \p -> + return (LL $ BindStmt p $1) } + | 'rec' stmtlist { LL $ RecStmt (unLoc $2) undefined undefined undefined } + +qual :: { LStmt RdrName } + : infixexp '<-' exp {% checkPattern $1 >>= \p -> + return (LL $ BindStmt p $3) } + | exp { L1 $ ExprStmt $1 placeHolderType } + | 'let' binds { LL $ LetStmt (unLoc $2) } + +----------------------------------------------------------------------------- +-- Record Field Update/Construction + +fbinds :: { HsRecordBinds RdrName } + : fbinds1 { $1 } + | {- empty -} { [] } + +fbinds1 :: { HsRecordBinds RdrName } + : fbinds1 ',' fbind { $3 : $1 } + | fbind { [$1] } + +fbind :: { (Located RdrName, LHsExpr RdrName) } + : qvar '=' exp { ($1,$3) } + +----------------------------------------------------------------------------- +-- Implicit Parameter Bindings + +dbinds :: { Located [LIPBind RdrName] } + : dbinds ';' dbind { LL ($3 : unLoc $1) } + | dbinds ';' { LL (unLoc $1) } + | dbind { L1 [$1] } +-- | {- empty -} { [] } + +dbind :: { LIPBind RdrName } +dbind : ipvar '=' exp { LL (IPBind (unLoc $1) $3) } + +----------------------------------------------------------------------------- +-- Variables, Constructors and Operators. + +identifier :: { Located RdrName } + : qvar { $1 } + | gcon { $1 } + | qvarop { $1 } + | qconop { $1 } + +depreclist :: { Located [RdrName] } +depreclist : deprec_var { L1 [unLoc $1] } + | deprec_var ',' depreclist { LL (unLoc $1 : unLoc $3) } + +deprec_var :: { Located RdrName } +deprec_var : var { $1 } + | tycon { $1 } + +gcon :: { Located RdrName } -- Data constructor namespace + : sysdcon { L1 $ nameRdrName (dataConName (unLoc $1)) } + | qcon { $1 } +-- the case of '[:' ':]' is part of the production `parr' + +sysdcon :: { Located DataCon } -- Wired in data constructors + : '(' ')' { LL unitDataCon } + | '(' commas ')' { LL $ tupleCon Boxed $2 } + | '[' ']' { LL nilDataCon } + +var :: { Located RdrName } + : varid { $1 } + | '(' varsym ')' { LL (unLoc $2) } + +qvar :: { Located RdrName } + : qvarid { $1 } + | '(' varsym ')' { LL (unLoc $2) } + | '(' qvarsym1 ')' { LL (unLoc $2) } +-- We've inlined qvarsym here so that the decision about +-- whether it's a qvar or a var can be postponed until +-- *after* we see the close paren. + +ipvar :: { Located (IPName RdrName) } + : IPDUPVARID { L1 (Dupable (mkUnqual varName (getIPDUPVARID $1))) } + | IPSPLITVARID { L1 (Linear (mkUnqual varName (getIPSPLITVARID $1))) } + +qcon :: { Located RdrName } + : qconid { $1 } + | '(' qconsym ')' { LL (unLoc $2) } + +varop :: { Located RdrName } + : varsym { $1 } + | '`' varid '`' { LL (unLoc $2) } + +qvarop :: { Located RdrName } + : qvarsym { $1 } + | '`' qvarid '`' { LL (unLoc $2) } + +qvaropm :: { Located RdrName } + : qvarsym_no_minus { $1 } + | '`' qvarid '`' { LL (unLoc $2) } + +conop :: { Located RdrName } + : consym { $1 } + | '`' conid '`' { LL (unLoc $2) } + +qconop :: { Located RdrName } + : qconsym { $1 } + | '`' qconid '`' { LL (unLoc $2) } + +----------------------------------------------------------------------------- +-- Type constructors + +gtycon :: { Located RdrName } -- A "general" qualified tycon + : oqtycon { $1 } + | '(' ')' { LL $ getRdrName unitTyCon } + | '(' commas ')' { LL $ getRdrName (tupleTyCon Boxed $2) } + | '(' '->' ')' { LL $ getRdrName funTyCon } + | '[' ']' { LL $ listTyCon_RDR } + | '[:' ':]' { LL $ parrTyCon_RDR } + +oqtycon :: { Located RdrName } -- An "ordinary" qualified tycon + : qtycon { $1 } + | '(' qtyconsym ')' { LL (unLoc $2) } + +qtyconop :: { Located RdrName } -- Qualified or unqualified + : qtyconsym { $1 } + | '`' qtycon '`' { LL (unLoc $2) } + +tyconop :: { Located RdrName } -- Unqualified + : tyconsym { $1 } + | '`' tycon '`' { LL (unLoc $2) } + +qtycon :: { Located RdrName } -- Qualified or unqualified + : QCONID { L1 $! mkQual tcClsName (getQCONID $1) } + | tycon { $1 } + +tycon :: { Located RdrName } -- Unqualified + : CONID { L1 $! mkUnqual tcClsName (getCONID $1) } + +qtyconsym :: { Located RdrName } + : QCONSYM { L1 $! mkQual tcClsName (getQCONSYM $1) } + | tyconsym { $1 } + +tyconsym :: { Located RdrName } + : CONSYM { L1 $! mkUnqual tcClsName (getCONSYM $1) } + +----------------------------------------------------------------------------- +-- Any operator + +op :: { Located RdrName } -- used in infix decls + : varop { $1 } + | conop { $1 } + +qop :: { LHsExpr RdrName } -- used in sections + : qvarop { L1 $ HsVar (unLoc $1) } + | qconop { L1 $ HsVar (unLoc $1) } + +qopm :: { LHsExpr RdrName } -- used in sections + : qvaropm { L1 $ HsVar (unLoc $1) } + | qconop { L1 $ HsVar (unLoc $1) } + +----------------------------------------------------------------------------- +-- VarIds + +qvarid :: { Located RdrName } + : varid { $1 } + | QVARID { L1 $ mkQual varName (getQVARID $1) } + +varid :: { Located RdrName } + : varid_no_unsafe { $1 } + | 'unsafe' { L1 $! mkUnqual varName FSLIT("unsafe") } + | 'safe' { L1 $! mkUnqual varName FSLIT("safe") } + | 'threadsafe' { L1 $! mkUnqual varName FSLIT("threadsafe") } + +varid_no_unsafe :: { Located RdrName } + : VARID { L1 $! mkUnqual varName (getVARID $1) } + | special_id { L1 $! mkUnqual varName (unLoc $1) } + | 'forall' { L1 $! mkUnqual varName FSLIT("forall") } + +tyvar :: { Located RdrName } + : VARID { L1 $! mkUnqual tvName (getVARID $1) } + | special_id { L1 $! mkUnqual tvName (unLoc $1) } + | 'unsafe' { L1 $! mkUnqual tvName FSLIT("unsafe") } + | 'safe' { L1 $! mkUnqual tvName FSLIT("safe") } + | 'threadsafe' { L1 $! mkUnqual tvName FSLIT("threadsafe") } + +-- These special_ids are treated as keywords in various places, +-- but as ordinary ids elsewhere. 'special_id' collects all these +-- except 'unsafe' and 'forall' whose treatment differs depending on context +special_id :: { Located UserFS } +special_id + : 'as' { L1 FSLIT("as") } + | 'qualified' { L1 FSLIT("qualified") } + | 'hiding' { L1 FSLIT("hiding") } + | 'export' { L1 FSLIT("export") } + | 'label' { L1 FSLIT("label") } + | 'dynamic' { L1 FSLIT("dynamic") } + | 'stdcall' { L1 FSLIT("stdcall") } + | 'ccall' { L1 FSLIT("ccall") } + +----------------------------------------------------------------------------- +-- Variables + +qvarsym :: { Located RdrName } + : varsym { $1 } + | qvarsym1 { $1 } + +qvarsym_no_minus :: { Located RdrName } + : varsym_no_minus { $1 } + | qvarsym1 { $1 } + +qvarsym1 :: { Located RdrName } +qvarsym1 : QVARSYM { L1 $ mkQual varName (getQVARSYM $1) } + +varsym :: { Located RdrName } + : varsym_no_minus { $1 } + | '-' { L1 $ mkUnqual varName FSLIT("-") } + +varsym_no_minus :: { Located RdrName } -- varsym not including '-' + : VARSYM { L1 $ mkUnqual varName (getVARSYM $1) } + | special_sym { L1 $ mkUnqual varName (unLoc $1) } + + +-- See comments with special_id +special_sym :: { Located UserFS } +special_sym : '!' { L1 FSLIT("!") } + | '.' { L1 FSLIT(".") } + | '*' { L1 FSLIT("*") } + +----------------------------------------------------------------------------- +-- Data constructors + +qconid :: { Located RdrName } -- Qualified or unqualifiedb + : conid { $1 } + | QCONID { L1 $ mkQual dataName (getQCONID $1) } + +conid :: { Located RdrName } + : CONID { L1 $ mkUnqual dataName (getCONID $1) } + +qconsym :: { Located RdrName } -- Qualified or unqualified + : consym { $1 } + | QCONSYM { L1 $ mkQual dataName (getQCONSYM $1) } + +consym :: { Located RdrName } + : CONSYM { L1 $ mkUnqual dataName (getCONSYM $1) } + + -- ':' means only list cons + | ':' { L1 $ consDataCon_RDR } + + +----------------------------------------------------------------------------- +-- Literals + +literal :: { Located HsLit } + : CHAR { L1 $ HsChar $ getCHAR $1 } + | STRING { L1 $ HsString $ getSTRING $1 } + | PRIMINTEGER { L1 $ HsIntPrim $ getPRIMINTEGER $1 } + | PRIMCHAR { L1 $ HsCharPrim $ getPRIMCHAR $1 } + | PRIMSTRING { L1 $ HsStringPrim $ getPRIMSTRING $1 } + | PRIMFLOAT { L1 $ HsFloatPrim $ getPRIMFLOAT $1 } + | PRIMDOUBLE { L1 $ HsDoublePrim $ getPRIMDOUBLE $1 } + +----------------------------------------------------------------------------- +-- Layout + +close :: { () } + : vccurly { () } -- context popped in lexer. + | error {% popContext } + +----------------------------------------------------------------------------- +-- Miscellaneous (mostly renamings) + +modid :: { Located ModuleName } + : CONID { L1 $ mkModuleNameFS (getCONID $1) } + | QCONID { L1 $ let (mod,c) = getQCONID $1 in + mkModuleNameFS + (mkFastString + (unpackFS mod ++ '.':unpackFS c)) + } + +commas :: { Int } + : commas ',' { $1 + 1 } + | ',' { 2 } + +----------------------------------------------------------------------------- + +{ +happyError :: P a +happyError = srcParseFail + +getVARID (L _ (ITvarid x)) = x +getCONID (L _ (ITconid x)) = x +getVARSYM (L _ (ITvarsym x)) = x +getCONSYM (L _ (ITconsym x)) = x +getQVARID (L _ (ITqvarid x)) = x +getQCONID (L _ (ITqconid x)) = x +getQVARSYM (L _ (ITqvarsym x)) = x +getQCONSYM (L _ (ITqconsym x)) = x +getIPDUPVARID (L _ (ITdupipvarid x)) = x +getIPSPLITVARID (L _ (ITsplitipvarid x)) = x +getCHAR (L _ (ITchar x)) = x +getSTRING (L _ (ITstring x)) = x +getINTEGER (L _ (ITinteger x)) = x +getRATIONAL (L _ (ITrational x)) = x +getPRIMCHAR (L _ (ITprimchar x)) = x +getPRIMSTRING (L _ (ITprimstring x)) = x +getPRIMINTEGER (L _ (ITprimint x)) = x +getPRIMFLOAT (L _ (ITprimfloat x)) = x +getPRIMDOUBLE (L _ (ITprimdouble x)) = x +getTH_ID_SPLICE (L _ (ITidEscape x)) = x + +-- Utilities for combining source spans +comb2 :: Located a -> Located b -> SrcSpan +comb2 = combineLocs + +comb3 :: Located a -> Located b -> Located c -> SrcSpan +comb3 a b c = combineSrcSpans (getLoc a) (combineSrcSpans (getLoc b) (getLoc c)) + +comb4 :: Located a -> Located b -> Located c -> Located d -> SrcSpan +comb4 a b c d = combineSrcSpans (getLoc a) $ combineSrcSpans (getLoc b) $ + combineSrcSpans (getLoc c) (getLoc d) + +-- strict constructor version: +{-# INLINE sL #-} +sL :: SrcSpan -> a -> Located a +sL span a = span `seq` L span a + +-- Make a source location that is just the filename. This seems slightly +-- neater than trying to construct the span of the text within the file. +fileSrcSpan :: P SrcSpan +fileSrcSpan = do l <- getSrcLoc; return (mkGeneralSrcSpan (srcLocFile l)) +} diff --git a/ghc/compiler/parser/ParserCore.y b/ghc/compiler/parser/ParserCore.y index 32e8d916b2..95abaf43a1 100644 --- a/ghc/compiler/parser/ParserCore.y +++ b/ghc/compiler/parser/ParserCore.y @@ -20,6 +20,7 @@ import TysPrim( wordPrimTyCon, intPrimTyCon, charPrimTyCon, import TyCon ( TyCon, tyConName ) import FastString import Outputable +import Char #include "../HsVersions.h" @@ -84,32 +85,33 @@ tdefs :: { [TyClDecl RdrName] } tdef :: { TyClDecl RdrName } : '%data' q_tc_name tv_bndrs '=' '{' cons1 '}' - { mkTyData DataType ([], ifaceExtRdrName $2, map toHsTvBndr $3) $6 Nothing noSrcLoc } + { mkTyData DataType (noLoc [], noLoc (ifaceExtRdrName $2), map toHsTvBndr $3) $6 Nothing } | '%newtype' q_tc_name tv_bndrs trep { let tc_rdr = ifaceExtRdrName $2 in - mkTyData NewType ([], tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing noSrcLoc } + mkTyData NewType (noLoc [], noLoc tc_rdr, map toHsTvBndr $3) ($4 (rdrNameOcc tc_rdr)) Nothing } -- For a newtype we have to invent a fake data constructor name -- It doesn't matter what it is, because it won't be used -trep :: { OccName -> [ConDecl RdrName] } +trep :: { OccName -> [LConDecl RdrName] } : {- empty -} { (\ tc_occ -> []) } | '=' ty { (\ tc_occ -> let { dc_name = mkRdrUnqual (setOccNameSpace dataName tc_occ) ; con_info = PrefixCon [unbangedType (toHsType $2)] } - in [ConDecl dc_name [] [] con_info noSrcLoc]) } + in [noLoc $ ConDecl (noLoc dc_name) [] + (noLoc []) con_info]) } -cons1 :: { [ConDecl RdrName] } +cons1 :: { [LConDecl RdrName] } : con { [$1] } | con ';' cons1 { $1:$3 } -con :: { ConDecl RdrName } +con :: { LConDecl RdrName } : d_pat_occ attv_bndrs hs_atys - { ConDecl (mkRdrUnqual $1) $2 [] (PrefixCon (map unbangedType $3)) noSrcLoc} + { noLoc $ ConDecl (noLoc (mkRdrUnqual $1)) $2 (noLoc []) (PrefixCon (map unbangedType $3))} -attv_bndrs :: { [HsTyVarBndr RdrName] } +attv_bndrs :: { [LHsTyVarBndr RdrName] } : {- empty -} { [] } | '@' tv_bndr attv_bndrs { toHsTvBndr $2 : $3 } -hs_atys :: { [HsType RdrName] } +hs_atys :: { [LHsType RdrName] } : atys { map toHsType $1 } @@ -248,7 +250,7 @@ alt :: { IfaceAlt } lit :: { Literal } : '(' INTEGER '::' aty ')' { convIntLit $2 $4 } | '(' RATIONAL '::' aty ')' { convRatLit $2 $4 } - | '(' CHAR '::' aty ')' { MachChar (fromEnum $2) } + | '(' CHAR '::' aty ')' { MachChar $2 } | '(' STRING '::' aty ')' { MachStr (mkFastString $2) } tv_occ :: { OccName } @@ -281,7 +283,7 @@ convIntLit :: Integer -> IfaceType -> Literal convIntLit i (IfaceTyConApp tc []) | tc `eqTc` intPrimTyCon = MachInt i | tc `eqTc` wordPrimTyCon = MachWord i - | tc `eqTc` charPrimTyCon = MachChar (fromInteger i) + | tc `eqTc` charPrimTyCon = MachChar (chr (fromInteger i)) | tc `eqTc` addrPrimTyCon && i == 0 = MachNullAddr convIntLit i aty = pprPanic "Unknown integer literal type" (ppr aty) @@ -304,22 +306,24 @@ eqTc (IfaceTc (ExtPkg mod occ)) tycon -- and convert to HsTypes here. But the IfaceTypes we can see here -- are very limited (see the productions for 'ty', so the translation -- isn't hard -toHsType :: IfaceType -> HsType RdrName -toHsType (IfaceTyVar v) = HsTyVar (mkRdrUnqual v) -toHsType (IfaceAppTy t1 t2) = HsAppTy (toHsType t1) (toHsType t2) -toHsType (IfaceFunTy t1 t2) = HsFunTy (toHsType t1) (toHsType t2) -toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl HsAppTy (HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) +toHsType :: IfaceType -> LHsType RdrName +toHsType (IfaceTyVar v) = noLoc $ HsTyVar (mkRdrUnqual v) +toHsType (IfaceAppTy t1 t2) = noLoc $ HsAppTy (toHsType t1) (toHsType t2) +toHsType (IfaceFunTy t1 t2) = noLoc $ HsFunTy (toHsType t1) (toHsType t2) +toHsType (IfaceTyConApp (IfaceTc tc) ts) = foldl mkHsAppTy (noLoc $ HsTyVar (ifaceExtRdrName tc)) (map toHsType ts) toHsType (IfaceForAllTy tv t) = add_forall (toHsTvBndr tv) (toHsType t) -toHsTvBndr :: IfaceTvBndr -> HsTyVarBndr RdrName -toHsTvBndr (tv,k) = KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k) +toHsTvBndr :: IfaceTvBndr -> LHsTyVarBndr RdrName +toHsTvBndr (tv,k) = noLoc $ KindedTyVar (mkRdrUnqual tv) (tcIfaceKind k) ifaceExtRdrName :: IfaceExtName -> RdrName ifaceExtRdrName (ExtPkg mod occ) = mkOrig mod occ ifaceExtRdrName other = pprPanic "ParserCore.ifaceExtRdrName" (ppr other) -add_forall tv (HsForAllTy exp tvs cxt t) = HsForAllTy exp (tv:tvs) cxt t -add_forall tv t = HsForAllTy Explicit [tv] [] t +add_forall tv (L _ (HsForAllTy exp tvs cxt t)) + = noLoc $ HsForAllTy exp (tv:tvs) cxt t +add_forall tv t + = noLoc $ HsForAllTy Explicit [tv] (noLoc []) t happyError :: P a happyError s l = failP (show l ++ ": Parse error\n") (take 100 s) l diff --git a/ghc/compiler/parser/RdrHsSyn.lhs b/ghc/compiler/parser/RdrHsSyn.lhs index 7d51a54c07..3761f74f44 100644 --- a/ghc/compiler/parser/RdrHsSyn.lhs +++ b/ghc/compiler/parser/RdrHsSyn.lhs @@ -8,41 +8,7 @@ they are used somewhat later on in the compiler...) \begin{code} module RdrHsSyn ( - RdrNameArithSeqInfo, - RdrNameBangType, - RdrNameClassOpSig, - RdrNameConDecl, - RdrNameConDetails, - RdrNameContext, - RdrNameDefaultDecl, - RdrNameForeignDecl, - RdrNameGRHS, - RdrNameGRHSs, - RdrNameHsBinds, - RdrNameHsCmd, - RdrNameHsCmdTop, - RdrNameHsDecl, - RdrNameHsExpr, - RdrNameHsModule, - RdrNameIE, - RdrNameImportDecl, - RdrNameInstDecl, - RdrNameMatch, - RdrNameMonoBinds, - RdrNamePat, - RdrNameHsType, - RdrNameHsTyVar, - RdrNameSig, - RdrNameStmt, - RdrNameTyClDecl, - RdrNameRuleDecl, - RdrNameRuleBndr, - RdrNameDeprecation, - RdrNameHsRecordBinds, - RdrNameFixitySig, - RdrBinding(..), - RdrMatch(..), main_RDR_Unqual, @@ -50,26 +16,24 @@ module RdrHsSyn ( extractHsRhoRdrTyVars, extractGenericPatTyVars, mkHsOpApp, mkClassDecl, - mkHsNegApp, mkNPlusKPat, mkHsIntegral, mkHsFractional, + mkHsNegApp, mkHsIntegral, mkHsFractional, mkHsDo, mkHsSplice, mkSigDecls, mkTyData, mkPrefixCon, mkRecCon, mkRecConstrOrUpdate, -- HsExp -> [HsFieldUpdate] -> P HsExp mkBootIface, - cvBinds, - cvMonoBindsAndSigs, + cvBindGroup, + cvBindsAndSigs, cvTopDecls, - findSplice, addImpDecls, emptyGroup, mkGroup, + findSplice, mkGroup, -- Stuff to do with Foreign declarations , CallConv(..) , mkImport -- CallConv -> Safety -- -> (FastString, RdrName, RdrNameHsType) - -- -> SrcLoc -- -> P RdrNameHsDecl , mkExport -- CallConv -- -> (FastString, RdrName, RdrNameHsType) - -- -> SrcLoc -- -> P RdrNameHsDecl , mkExtName -- RdrName -> CLabelString @@ -78,7 +42,6 @@ module RdrHsSyn ( , checkPrecP -- Int -> P Int , checkContext -- HsType -> P HsContext , checkPred -- HsType -> P HsPred - , checkTyVars -- [HsTyVar] -> P [HsType] , checkTyClHdr -- HsType -> (name,[tyvar]) , checkInstType -- HsType -> P HsType , checkPattern -- HsExp -> P HsPat @@ -96,27 +59,29 @@ import HsSyn -- Lots of it import IfaceType import HscTypes ( ModIface(..), emptyModIface, mkIfaceVerCache ) import IfaceSyn ( IfaceDecl(..), IfaceIdInfo(..) ) -import RdrName ( RdrName, isRdrTyVar, mkRdrUnqual, mkUnqual, rdrNameOcc, +import RdrName ( RdrName, isRdrTyVar, mkUnqual, rdrNameOcc, isRdrTyVar, isRdrDataCon, isUnqual, getRdrName, isQual, setRdrNameSpace, rdrNameModule ) import BasicTypes ( RecFlag(..), mapIPName, maxPrecedence, initialVersion ) -import Lexer ( P, setSrcLocFor, getSrcLoc, failLocMsgP ) +import Lexer ( P, failSpanMsgP ) import HscTypes ( GenAvailInfo(..) ) import TysWiredIn ( unitTyCon ) import ForeignCall ( CCallConv, Safety, CCallTarget(..), CExportSpec(..), DNCallSpec(..), DNKind(..)) import OccName ( OccName, srcDataName, varName, isDataOcc, isTcOcc, - occNameUserString, mkVarOcc, isValOcc ) + occNameUserString, isValOcc ) import BasicTypes ( initialVersion ) import TyCon ( DataConDetails(..) ) import Module ( ModuleName ) import SrcLoc import CStrings ( CLabelString ) import CmdLineOpts ( opt_InPackage ) -import List ( isSuffixOf, nub ) +import Bag ( Bag, emptyBag, snocBag, consBag, foldrBag ) import Outputable import FastString import Panic + +import List ( isSuffixOf, nubBy ) \end{code} @@ -127,43 +92,6 @@ import Panic %************************************************************************ \begin{code} -type RdrNameArithSeqInfo = ArithSeqInfo RdrName -type RdrNameBangType = BangType RdrName -type RdrNameClassOpSig = Sig RdrName -type RdrNameConDecl = ConDecl RdrName -type RdrNameConDetails = HsConDetails RdrName RdrNameBangType -type RdrNameContext = HsContext RdrName -type RdrNameHsDecl = HsDecl RdrName -type RdrNameDefaultDecl = DefaultDecl RdrName -type RdrNameForeignDecl = ForeignDecl RdrName -type RdrNameGRHS = GRHS RdrName -type RdrNameGRHSs = GRHSs RdrName -type RdrNameHsBinds = HsBinds RdrName -type RdrNameHsExpr = HsExpr RdrName -type RdrNameHsCmd = HsCmd RdrName -type RdrNameHsCmdTop = HsCmdTop RdrName -type RdrNameHsModule = HsModule RdrName -type RdrNameIE = IE RdrName -type RdrNameImportDecl = ImportDecl RdrName -type RdrNameInstDecl = InstDecl RdrName -type RdrNameMatch = Match RdrName -type RdrNameMonoBinds = MonoBinds RdrName -type RdrNamePat = InPat RdrName -type RdrNameHsType = HsType RdrName -type RdrNameHsTyVar = HsTyVarBndr RdrName -type RdrNameSig = Sig RdrName -type RdrNameStmt = Stmt RdrName -type RdrNameTyClDecl = TyClDecl RdrName - -type RdrNameRuleBndr = RuleBndr RdrName -type RdrNameRuleDecl = RuleDecl RdrName -type RdrNameDeprecation = DeprecDecl RdrName -type RdrNameFixitySig = FixitySig RdrName - -type RdrNameHsRecordBinds = HsRecordBinds RdrName -\end{code} - -\begin{code} main_RDR_Unqual :: RdrName main_RDR_Unqual = mkUnqual varName FSLIT("main") -- We definitely don't want an Orig RdrName, because @@ -180,51 +108,53 @@ main_RDR_Unqual = mkUnqual varName FSLIT("main") It's used when making the for-alls explicit. \begin{code} -extractHsTyRdrTyVars :: RdrNameHsType -> [RdrName] -extractHsTyRdrTyVars ty = nub (filter isRdrTyVar (extract_ty ty [])) +extractHsTyRdrTyVars :: LHsType RdrName -> [Located RdrName] +extractHsTyRdrTyVars ty = nubBy eqLocated (extract_lty ty []) -extractHsRhoRdrTyVars :: HsContext RdrName -> RdrNameHsType -> [RdrName] +extractHsRhoRdrTyVars :: LHsContext RdrName -> LHsType RdrName -> [Located RdrName] -- This one takes the context and tau-part of a -- sigma type and returns their free type variables -extractHsRhoRdrTyVars ctxt ty = nub $ filter isRdrTyVar $ - extract_ctxt ctxt (extract_ty ty []) - -extract_ctxt ctxt acc = foldr extract_pred acc ctxt - -extract_pred (HsClassP cls tys) acc = foldr extract_ty (cls : acc) tys -extract_pred (HsIParam n ty) acc = extract_ty ty acc - -extract_ty (HsAppTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsListTy ty) acc = extract_ty ty acc -extract_ty (HsPArrTy ty) acc = extract_ty ty acc -extract_ty (HsTupleTy _ tys) acc = foldr extract_ty acc tys -extract_ty (HsFunTy ty1 ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsPredTy p) acc = extract_pred p acc -extract_ty (HsTyVar tv) acc = tv : acc -extract_ty (HsOpTy ty1 nam ty2) acc = extract_ty ty1 (extract_ty ty2 acc) -extract_ty (HsParTy ty) acc = extract_ty ty acc +extractHsRhoRdrTyVars ctxt ty + = nubBy eqLocated $ extract_lctxt ctxt (extract_lty ty []) + +extract_lctxt ctxt acc = foldr (extract_pred.unLoc) acc (unLoc ctxt) + +extract_pred (HsClassP cls tys) acc = foldr extract_lty acc tys +extract_pred (HsIParam n ty) acc = extract_lty ty acc + +extract_lty (L loc (HsTyVar tv)) acc + | isRdrTyVar tv = L loc tv : acc + | otherwise = acc +extract_lty ty acc = extract_ty (unLoc ty) acc + +extract_ty (HsAppTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) +extract_ty (HsListTy ty) acc = extract_lty ty acc +extract_ty (HsPArrTy ty) acc = extract_lty ty acc +extract_ty (HsTupleTy _ tys) acc = foldr extract_lty acc tys +extract_ty (HsFunTy ty1 ty2) acc = extract_lty ty1 (extract_lty ty2 acc) +extract_ty (HsPredTy p) acc = extract_pred (unLoc p) acc +extract_ty (HsOpTy ty1 nam ty2) acc = extract_lty ty1 (extract_lty ty2 acc) +extract_ty (HsParTy ty) acc = extract_lty ty acc extract_ty (HsNumTy num) acc = acc -extract_ty (HsKindSig ty k) acc = extract_ty ty acc -extract_ty (HsForAllTy exp [] cx ty) acc = extract_ctxt cx (extract_ty ty acc) +extract_ty (HsKindSig ty k) acc = extract_lty ty acc +extract_ty (HsForAllTy exp [] cx ty) acc = extract_lctxt cx (extract_lty ty acc) extract_ty (HsForAllTy exp tvs cx ty) - acc = acc ++ - (filter (`notElem` locals) $ - extract_ctxt cx (extract_ty ty [])) + acc = (filter ((`notElem` locals) . unLoc) $ + extract_lctxt cx (extract_lty ty [])) ++ acc where - locals = hsTyVarNames tvs + locals = hsLTyVarNames tvs -extractGenericPatTyVars :: RdrNameMonoBinds -> [RdrName] +extractGenericPatTyVars :: LHsBinds RdrName -> [Located RdrName] -- Get the type variables out of the type patterns in a bunch of -- possibly-generic bindings in a class declaration extractGenericPatTyVars binds - = filter isRdrTyVar (nub (get binds [])) + = nubBy eqLocated (foldrBag get [] binds) where - get (AndMonoBinds b1 b2) acc = get b1 (get b2 acc) - get (FunMonoBind _ _ ms _) acc = foldr get_m acc ms - get other acc = acc + get (L _ (FunBind _ _ ms)) acc = foldr (get_m.unLoc) acc ms + get other acc = acc - get_m (Match (TypePat ty : _) _ _) acc = extract_ty ty acc - get_m other acc = acc + get_m (Match (L _ (TypePat ty) : _) _ _) acc = extract_lty ty acc + get_m other acc = acc \end{code} @@ -245,54 +175,29 @@ Similarly for mkConDecl, mkClassOpSig and default-method names. *** See "THE NAMING STORY" in HsDecls **** \begin{code} -mkClassDecl (cxt, cname, tyvars) fds sigs mbinds loc - = ClassDecl { tcdCtxt = cxt, tcdName = cname, tcdTyVars = tyvars, +mkClassDecl (cxt, cname, tyvars) fds sigs mbinds + = ClassDecl { tcdCtxt = cxt, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, tcdMeths = mbinds, - tcdLoc = loc } + } -mkTyData new_or_data (context, tname, tyvars) data_cons maybe src - = TyData { tcdND = new_or_data, tcdCtxt = context, tcdName = tname, +mkTyData new_or_data (context, tname, tyvars) data_cons maybe + = TyData { tcdND = new_or_data, tcdCtxt = context, tcdLName = tname, tcdTyVars = tyvars, tcdCons = data_cons, - tcdDerivs = maybe, tcdLoc = src } + tcdDerivs = maybe } \end{code} \begin{code} -mkHsNegApp :: RdrNameHsExpr -> RdrNameHsExpr --- If the type checker sees (negate 3#) it will barf, because negate +mkHsNegApp :: LHsExpr RdrName -> HsExpr RdrName +-- RdrName If the type checker sees (negate 3#) it will barf, because negate -- can't take an unboxed arg. But that is exactly what it will see when -- we write "-3#". So we have to do the negation right now! - -mkHsNegApp (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) -mkHsNegApp (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) -mkHsNegApp (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) -mkHsNegApp expr = NegApp expr placeHolderName -\end{code} - -A useful function for building @OpApps@. The operator is always a -variable, and we don't know the fixity yet. - -\begin{code} -mkHsOpApp e1 op e2 = OpApp e1 (HsVar op) (error "mkOpApp:fixity") e2 -\end{code} - -These are the bits of syntax that contain rebindable names -See RnEnv.lookupSyntaxName - -\begin{code} -mkHsIntegral i = HsIntegral i placeHolderName -mkHsFractional f = HsFractional f placeHolderName -mkNPlusKPat n k = NPlusKPatIn n k placeHolderName -mkHsDo ctxt stmts loc = HsDo ctxt stmts [] placeHolderType loc -\end{code} - -\begin{code} -mkHsSplice e loc = HsSplice unqualSplice e loc - -unqualSplice = mkRdrUnqual (mkVarOcc FSLIT("splice")) - -- A name (uniquified later) to - -- identify the splice +mkHsNegApp (L loc e) = f e + where f (HsLit (HsIntPrim i)) = HsLit (HsIntPrim (-i)) + f (HsLit (HsFloatPrim i)) = HsLit (HsFloatPrim (-i)) + f (HsLit (HsDoublePrim i)) = HsLit (HsDoublePrim (-i)) + f expr = NegApp (L loc e) placeHolderName \end{code} %************************************************************************ @@ -342,22 +247,22 @@ hsIfaceDecl :: HsDecl RdrName -> IfaceDecl -- for hi-boot files to look the same -- -- NB: no constructors or class ops to worry about -hsIfaceDecl (SigD (Sig name ty _)) - = IfaceId { ifName = rdrNameOcc name, - ifType = hsIfaceType ty, +hsIfaceDecl (SigD (Sig name ty)) + = IfaceId { ifName = rdrNameOcc (unLoc name), + ifType = hsIfaceLType ty, ifIdInfo = NoInfo } hsIfaceDecl (TyClD decl@(TySynonym {})) = IfaceSyn { ifName = rdrNameOcc (tcdName decl), ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifSynRhs = hsIfaceType (tcdSynRhs decl), + ifSynRhs = hsIfaceLType (tcdSynRhs decl), ifVrcs = [] } hsIfaceDecl (TyClD decl@(TyData {})) = IfaceData { ifND = tcdND decl, ifName = rdrNameOcc (tcdName decl), ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (tcdCtxt decl), + ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), ifCons = Unknown, ifRec = NonRecursive, ifVrcs = [], ifGeneric = False } -- I'm not sure that [] is right for ifVrcs, but @@ -366,8 +271,8 @@ hsIfaceDecl (TyClD decl@(TyData {})) hsIfaceDecl (TyClD decl@(ClassDecl {})) = IfaceClass { ifName = rdrNameOcc (tcdName decl), ifTyVars = hsIfaceTvs (tcdTyVars decl), - ifCtxt = hsIfaceCtxt (tcdCtxt decl), - ifFDs = hsIfaceFDs (tcdFDs decl), + ifCtxt = hsIfaceCtxt (unLoc (tcdCtxt decl)), + ifFDs = hsIfaceFDs (map unLoc (tcdFDs decl)), ifSigs = [], -- Is this right?? ifRec = NonRecursive, ifVrcs = [] } @@ -378,50 +283,56 @@ hsIfaceName rdr_name -- Qualify unqualifed occurrences | isUnqual rdr_name = LocalTop (rdrNameOcc rdr_name) | otherwise = ExtPkg (rdrNameModule rdr_name) (rdrNameOcc rdr_name) +hsIfaceLType :: LHsType RdrName -> IfaceType +hsIfaceLType = hsIfaceType . unLoc + hsIfaceType :: HsType RdrName -> IfaceType hsIfaceType (HsForAllTy exp tvs cxt ty) = foldr (IfaceForAllTy . hsIfaceTv) rho tvs' where - rho = foldr (IfaceFunTy . IfacePredTy . hsIfacePred) tau cxt - tau = hsIfaceType ty + rho = foldr (IfaceFunTy . IfacePredTy . hsIfaceLPred) tau (unLoc cxt) + tau = hsIfaceLType ty tvs' = case exp of - Explicit -> tvs - Implicit -> map UserTyVar (extractHsRhoRdrTyVars cxt ty) + Explicit -> map unLoc tvs + Implicit -> map (UserTyVar . unLoc) (extractHsRhoRdrTyVars cxt ty) hsIfaceType ty@(HsTyVar _) = hs_tc_app ty [] hsIfaceType ty@(HsAppTy t1 t2) = hs_tc_app ty [] -hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceType t1) (hsIfaceType t2) -hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceType t] -hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceType t] -hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceTypes ts) -hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar tc) (hsIfaceTypes [t1, t2]) -hsIfaceType (HsParTy t) = hsIfaceType t +hsIfaceType (HsFunTy t1 t2) = IfaceFunTy (hsIfaceLType t1) (hsIfaceLType t2) +hsIfaceType (HsListTy t) = IfaceTyConApp IfaceListTc [hsIfaceLType t] +hsIfaceType (HsPArrTy t) = IfaceTyConApp IfacePArrTc [hsIfaceLType t] +hsIfaceType (HsTupleTy bx ts) = IfaceTyConApp (IfaceTupTc bx (length ts)) (hsIfaceLTypes ts) +hsIfaceType (HsOpTy t1 tc t2) = hs_tc_app (HsTyVar (unLoc tc)) (hsIfaceLTypes [t1, t2]) +hsIfaceType (HsParTy t) = hsIfaceLType t hsIfaceType (HsNumTy n) = panic "hsIfaceType:HsNum" -hsIfaceType (HsPredTy p) = IfacePredTy (hsIfacePred p) -hsIfaceType (HsKindSig t _) = hsIfaceType t +hsIfaceType (HsPredTy p) = IfacePredTy (hsIfaceLPred p) +hsIfaceType (HsKindSig t _) = hsIfaceLType t ----------- -hsIfaceTypes tys = map hsIfaceType tys +hsIfaceLTypes tys = map (hsIfaceType.unLoc) tys ----------- -hsIfaceCtxt :: [HsPred RdrName] -> [IfacePredType] -hsIfaceCtxt ctxt = map hsIfacePred ctxt +hsIfaceCtxt :: [LHsPred RdrName] -> [IfacePredType] +hsIfaceCtxt ctxt = map hsIfaceLPred ctxt ----------- +hsIfaceLPred :: LHsPred RdrName -> IfacePredType +hsIfaceLPred = hsIfacePred . unLoc + hsIfacePred :: HsPred RdrName -> IfacePredType -hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceTypes ts) -hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceType t) +hsIfacePred (HsClassP cls ts) = IfaceClassP (hsIfaceName cls) (hsIfaceLTypes ts) +hsIfacePred (HsIParam ip t) = IfaceIParam (mapIPName rdrNameOcc ip) (hsIfaceLType t) ----------- hs_tc_app :: HsType RdrName -> [IfaceType] -> IfaceType -hs_tc_app (HsAppTy t1 t2) args = hs_tc_app t1 (hsIfaceType t2 : args) +hs_tc_app (HsAppTy t1 t2) args = hs_tc_app (unLoc t1) (hsIfaceLType t2 : args) hs_tc_app (HsTyVar n) args | isTcOcc (rdrNameOcc n) = IfaceTyConApp (IfaceTc (hsIfaceName n)) args | otherwise = foldl IfaceAppTy (IfaceTyVar (rdrNameOcc n)) args hs_tc_app ty args = foldl IfaceAppTy (hsIfaceType ty) args ----------- -hsIfaceTvs tvs = map hsIfaceTv tvs +hsIfaceTvs tvs = map (hsIfaceTv.unLoc) tvs ----------- hsIfaceTv (UserTyVar n) = (rdrNameOcc n, IfaceLiftedTypeKind) @@ -446,23 +357,15 @@ data RdrBinding -- signatures yet RdrBindings [RdrBinding] -- Convenience for parsing - | RdrValBinding RdrNameMonoBinds + | RdrValBinding (LHsBind RdrName) -- The remainder all fit into the main HsDecl form - | RdrHsDecl RdrNameHsDecl -\end{code} - -\begin{code} -data RdrMatch - = RdrMatch - [RdrNamePat] - (Maybe RdrNameHsType) - RdrNameGRHSs + | RdrHsDecl (LHsDecl RdrName) \end{code} %************************************************************************ %* * -\subsection[cvBinds-etc]{Converting to @HsBinds@, @MonoBinds@, etc.} +\subsection[cvBinds-etc]{Converting to @HsBinds@, etc.} %* * %************************************************************************ @@ -472,45 +375,44 @@ analyser. \begin{code} -cvTopDecls :: [RdrBinding] -> [RdrNameHsDecl] +cvTopDecls :: [RdrBinding] -> [LHsDecl RdrName] -- Incoming bindings are in reverse order; result is in ordinary order -- (a) flatten RdrBindings -- (b) Group together bindings for a single function cvTopDecls decls = go [] decls where - go :: [RdrNameHsDecl] -> [RdrBinding] -> [RdrNameHsDecl] + go :: [LHsDecl RdrName] -> [RdrBinding] -> [LHsDecl RdrName] go acc [] = acc go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 go acc (RdrHsDecl d : ds) = go (d : acc) ds - go acc (RdrValBinding b : ds) = go (ValD b' : acc) ds' + go acc (RdrValBinding b : ds) = go (L l (ValD b') : acc) ds' where - (b', ds') = getMonoBind b ds + (L l b', ds') = getMonoBind b ds -cvBinds :: [RdrBinding] -> RdrNameHsBinds -cvBinds binding - = case (cvMonoBindsAndSigs binding) of { (mbs, sigs) -> - MonoBind mbs sigs Recursive +cvBindGroup :: [RdrBinding] -> HsBindGroup RdrName +cvBindGroup binding + = case (cvBindsAndSigs binding) of { (mbs, sigs) -> + HsBindGroup mbs sigs Recursive -- just one big group for now } -cvMonoBindsAndSigs :: [RdrBinding] -> (RdrNameMonoBinds, [RdrNameSig]) +cvBindsAndSigs :: [RdrBinding] -> (Bag (LHsBind RdrName), [LSig RdrName]) -- Input bindings are in *reverse* order, --- and contain just value bindings and signatuers - -cvMonoBindsAndSigs fb - = go (EmptyMonoBinds, []) fb +-- and contain just value bindings and signatures +cvBindsAndSigs fb + = go (emptyBag, []) fb where go acc [] = acc go acc (RdrBindings ds1 : ds2) = go (go acc ds1) ds2 - go (bs, ss) (RdrHsDecl (SigD s) : ds) = go (bs, s : ss) ds - go (bs, ss) (RdrValBinding b : ds) = go (b' `AndMonoBinds` bs, ss) ds' + go (bs, ss) (RdrHsDecl (L l (SigD s)) : ds) = go (bs, L l s : ss) ds + go (bs, ss) (RdrValBinding b : ds) = go (b' `consBag` bs, ss) ds' where (b',ds') = getMonoBind b ds ----------------------------------------------------------------------------- -- Group function bindings into equation groups -getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBinding]) +getMonoBind :: LHsBind RdrName -> [RdrBinding] -> (LHsBind RdrName, [RdrBinding]) -- Suppose (b',ds') = getMonoBind b ds -- ds is a *reversed* list of parsed bindings -- b is a MonoBinds that has just been read off the front @@ -521,74 +423,89 @@ getMonoBind :: RdrNameMonoBinds -> [RdrBinding] -> (RdrNameMonoBinds, [RdrBindin -- -- No AndMonoBinds or EmptyMonoBinds here; just single equations -getMonoBind (FunMonoBind f inf mtchs loc) binds +getMonoBind (L loc (FunBind lf@(L _ f) inf mtchs)) binds | has_args mtchs = go mtchs loc binds where - go mtchs1 loc1 (RdrValBinding (FunMonoBind f2 inf2 mtchs2 loc2) : binds) - | f == f2 = go (mtchs2 ++ mtchs1) loc2 binds + go mtchs1 loc1 (RdrValBinding (L loc2 (FunBind f2 inf2 mtchs2)) : binds) + | f == unLoc f2 = go (mtchs2 ++ mtchs1) loc binds -- Remember binds is reversed, so glue mtchs2 on the front -- and use loc2 as the final location - go mtchs1 loc1 binds = (FunMonoBind f inf mtchs1 loc1, binds) + where loc = combineSrcSpans loc1 loc2 + go mtchs1 loc binds = (L loc (FunBind lf inf mtchs1), binds) getMonoBind bind binds = (bind, binds) -has_args ((Match args _ _) : _) = not (null args) - -- Don't group together FunMonoBinds if they have +has_args ((L _ (Match args _ _)) : _) = not (null args) + -- Don't group together FunBinds if they have -- no arguments. This is necessary now that variable bindings - -- with no arguments are now treated as FunMonoBinds rather + -- with no arguments are now treated as FunBinds rather -- than pattern bindings (tests/rename/should_fail/rnfail002). \end{code} \begin{code} -emptyGroup = HsGroup { hs_valds = MonoBind EmptyMonoBinds [] Recursive, - -- The renamer adds structure to the bindings; - -- they start life as a single giant MonoBinds +emptyGroup = HsGroup { hs_valds = [HsBindGroup emptyBag [] Recursive], hs_tyclds = [], hs_instds = [], hs_fixds = [], hs_defds = [], hs_fords = [], hs_depds = [] ,hs_ruleds = [] } -findSplice :: [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) -findSplice ds = add emptyGroup ds +findSplice :: [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) +findSplice ds = addl emptyGroup ds -mkGroup :: [HsDecl a] -> HsGroup a +mkGroup :: [LHsDecl a] -> HsGroup a mkGroup ds = addImpDecls emptyGroup ds -addImpDecls :: HsGroup a -> [HsDecl a] -> HsGroup a +addImpDecls :: HsGroup a -> [LHsDecl a] -> HsGroup a -- The decls are imported, and should not have a splice -addImpDecls group decls = case add group decls of +addImpDecls group decls = case addl group decls of (group', Nothing) -> group' other -> panic "addImpDecls" -add :: HsGroup a -> [HsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [HsDecl a])) +addl :: HsGroup a -> [LHsDecl a] -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) -- This stuff reverses the declarations (again) but it doesn't matter -- Base cases -add gp [] = (gp, Nothing) -add gp (SpliceD e : ds) = (gp, Just (e, ds)) +addl gp [] = (gp, Nothing) +addl gp (L l d : ds) = add gp l d ds + + +add :: HsGroup a -> SrcSpan -> HsDecl a -> [LHsDecl a] + -> (HsGroup a, Maybe (SpliceDecl a, [LHsDecl a])) + +add gp l (SpliceD e) ds = (gp, Just (e, ds)) -- Class declarations: pull out the fixity signatures to the top -add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) (TyClD d : ds) - | isClassDecl d = add (gp { hs_tyclds = d : ts, - hs_fixds = [f | FixSig f <- tcdSigs d] ++ fs }) ds - | otherwise = add (gp { hs_tyclds = d : ts }) ds +add gp@(HsGroup {hs_tyclds = ts, hs_fixds = fs}) l (TyClD d) ds + | isClassDecl d = + let fsigs = [ L l f | L l (FixSig f) <- tcdSigs d ] in + addl (gp { hs_tyclds = L l d : ts, hs_fixds = fsigs ++ fs }) ds + | otherwise = + addl (gp { hs_tyclds = L l d : ts }) ds -- Signatures: fixity sigs go a different place than all others -add gp@(HsGroup {hs_fixds = ts}) (SigD (FixSig f) : ds) = add (gp {hs_fixds = f : ts}) ds -add gp@(HsGroup {hs_valds = ts}) (SigD d : ds) = add (gp {hs_valds = add_sig d ts}) ds +add gp@(HsGroup {hs_fixds = ts}) l (SigD (FixSig f)) ds + = addl (gp {hs_fixds = L l f : ts}) ds +add gp@(HsGroup {hs_valds = ts}) l (SigD d) ds + = addl (gp {hs_valds = add_sig (L l d) ts}) ds -- Value declarations: use add_bind -add gp@(HsGroup {hs_valds = ts}) (ValD d : ds) = add (gp { hs_valds = add_bind d ts }) ds +add gp@(HsGroup {hs_valds = ts}) l (ValD d) ds + = addl (gp { hs_valds = add_bind (L l d) ts }) ds -- The rest are routine -add gp@(HsGroup {hs_instds = ts}) (InstD d : ds) = add (gp { hs_instds = d : ts }) ds -add gp@(HsGroup {hs_defds = ts}) (DefD d : ds) = add (gp { hs_defds = d : ts }) ds -add gp@(HsGroup {hs_fords = ts}) (ForD d : ds) = add (gp { hs_fords = d : ts }) ds -add gp@(HsGroup {hs_depds = ts}) (DeprecD d : ds) = add (gp { hs_depds = d : ts }) ds -add gp@(HsGroup {hs_ruleds = ts})(RuleD d : ds) = add (gp { hs_ruleds = d : ts }) ds - -add_bind b (MonoBind bs sigs r) = MonoBind (bs `AndMonoBinds` b) sigs r -add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r +add gp@(HsGroup {hs_instds = ts}) l (InstD d) ds + = addl (gp { hs_instds = L l d : ts }) ds +add gp@(HsGroup {hs_defds = ts}) l (DefD d) ds + = addl (gp { hs_defds = L l d : ts }) ds +add gp@(HsGroup {hs_fords = ts}) l (ForD d) ds + = addl (gp { hs_fords = L l d : ts }) ds +add gp@(HsGroup {hs_depds = ts}) l (DeprecD d) ds + = addl (gp { hs_depds = L l d : ts }) ds +add gp@(HsGroup {hs_ruleds = ts}) l (RuleD d) ds + = addl (gp { hs_ruleds = L l d : ts }) ds + +add_bind b [HsBindGroup bs sigs r] = [HsBindGroup (bs `snocBag` b) sigs r] +add_sig s [HsBindGroup bs sigs r] = [HsBindGroup bs (s:sigs) r] \end{code} %************************************************************************ @@ -607,114 +524,131 @@ add_sig s (MonoBind bs sigs r) = MonoBind bs (s:sigs) r -- This function splits up the type application, adds any pending -- arguments, and converts the type constructor back into a data constructor. -mkPrefixCon :: RdrNameHsType -> [RdrNameBangType] -> P (RdrName, RdrNameConDetails) - +mkPrefixCon :: LHsType RdrName -> [LBangType RdrName] + -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) mkPrefixCon ty tys = split ty tys where - split (HsAppTy t u) ts = split t (unbangedType u : ts) - split (HsTyVar tc) ts = tyConToDataCon tc >>= \ data_con -> - return (data_con, PrefixCon ts) - split _ _ = parseError "Illegal data/newtype declaration" - -mkRecCon :: RdrName -> [([RdrName],RdrNameBangType)] -> P (RdrName, RdrNameConDetails) -mkRecCon con fields - = tyConToDataCon con >>= \ data_con -> - return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) - -tyConToDataCon :: RdrName -> P RdrName -tyConToDataCon tc + split (L _ (HsAppTy t u)) ts = split t (unbangedType u : ts) + split (L l (HsTyVar tc)) ts = do data_con <- tyConToDataCon l tc + return (data_con, PrefixCon ts) + split (L l _) _ = parseError l "parse error in data/newtype declaration" + +mkRecCon :: Located RdrName -> [([Located RdrName], LBangType RdrName)] + -> P (Located RdrName, HsConDetails RdrName (LBangType RdrName)) +mkRecCon (L loc con) fields + = do data_con <- tyConToDataCon loc con + return (data_con, RecCon [ (l,t) | (ls,t) <- fields, l <- ls ]) + +tyConToDataCon :: SrcSpan -> RdrName -> P (Located RdrName) +tyConToDataCon loc tc | isTcOcc (rdrNameOcc tc) - = return (setRdrNameSpace tc srcDataName) + = return (L loc (setRdrNameSpace tc srcDataName)) | otherwise - = parseError (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) + = parseError loc (showSDoc (text "Not a constructor:" <+> quotes (ppr tc))) ---------------------------------------------------------------------------- -- Various Syntactic Checks -checkInstType :: RdrNameHsType -> P RdrNameHsType -checkInstType t +checkInstType :: LHsType RdrName -> P (LHsType RdrName) +checkInstType (L l t) = case t of - HsForAllTy exp tvs ctxt ty -> - checkDictTy ty [] >>= \ dict_ty -> - return (HsForAllTy exp tvs ctxt dict_ty) + HsForAllTy exp tvs ctxt ty -> do + dict_ty <- checkDictTy ty + return (L l (HsForAllTy exp tvs ctxt dict_ty)) HsParTy ty -> checkInstType ty - ty -> checkDictTy ty [] >>= \ dict_ty-> - return (HsForAllTy Implicit [] [] dict_ty) + ty -> do dict_ty <- checkDictTy (L l ty) + return (L l (HsForAllTy Implicit [] (noLoc []) dict_ty)) -checkTyVars :: [RdrNameHsType] -> P [RdrNameHsTyVar] +checkTyVars :: [LHsType RdrName] -> P [LHsTyVarBndr RdrName] checkTyVars tvs = mapM chk tvs where -- Check that the name space is correct! - chk (HsKindSig (HsTyVar tv) k) | isRdrTyVar tv = return (KindedTyVar tv k) - chk (HsTyVar tv) | isRdrTyVar tv = return (UserTyVar tv) - chk other = parseError "Type found where type variable expected" - -checkTyClHdr :: RdrNameContext -> RdrNameHsType -> P (RdrNameContext, RdrName, [RdrNameHsTyVar]) + chk (L l (HsKindSig (L _ (HsTyVar tv)) k)) + | isRdrTyVar tv = return (L l (KindedTyVar tv k)) + chk (L l (HsTyVar tv)) + | isRdrTyVar tv = return (L l (UserTyVar tv)) + chk (L l other) + = parseError l "Type found where type variable expected" + +checkTyClHdr :: LHsContext RdrName -> LHsType RdrName + -> P (LHsContext RdrName, Located RdrName, [LHsTyVarBndr RdrName]) -- The header of a type or class decl should look like -- (C a, D b) => T a b -- or T a b -- or a + b -- etc -checkTyClHdr cxt ty - = go ty [] >>= \ (tc, tvs) -> - mapM chk_pred cxt >>= \ _ -> - return (cxt, tc, tvs) +checkTyClHdr (L l cxt) ty + = do (tc, tvs) <- gol ty [] + mapM_ chk_pred cxt + return (L l cxt, tc, tvs) where - go (HsTyVar tc) acc - | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> - return (tc, tvs) - go (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> - return (tc, tvs) - go (HsParTy ty) acc = go ty acc - go (HsAppTy t1 t2) acc = go t1 (t2:acc) - go other acc = parseError "Malformed LHS to type of class declaration" + gol (L l ty) acc = go l ty acc + + go l (HsTyVar tc) acc + | not (isRdrTyVar tc) = checkTyVars acc >>= \ tvs -> + return (L l tc, tvs) + go l (HsOpTy t1 tc t2) acc = checkTyVars (t1:t2:acc) >>= \ tvs -> + return (tc, tvs) + go l (HsParTy ty) acc = gol ty acc + go l (HsAppTy t1 t2) acc = gol t1 (t2:acc) + go l other acc = parseError l "Malformed LHS to type of class declaration" -- The predicates in a type or class decl must all -- be HsClassPs. They need not all be type variables, -- even in Haskell 98. E.g. class (Monad m, Monad (t m)) => MonadT t m - chk_pred (HsClassP _ args) = return () - chk_pred pred = parseError "Malformed context in type or class declaration" + chk_pred (L l (HsClassP _ args)) = return () + chk_pred (L l _) + = parseError l "Malformed context in type or class declaration" -checkContext :: RdrNameHsType -> P RdrNameContext -checkContext (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type - = mapM checkPred ts +checkContext :: LHsType RdrName -> P (LHsContext RdrName) +checkContext (L l t) + = check t + where + check (HsTupleTy _ ts) -- (Eq a, Ord b) shows up as a tuple type + = do ctx <- mapM checkPred ts + return (L l ctx) + + check (HsParTy ty) -- to be sure HsParTy doesn't get into the way + = check (unLoc ty) -checkContext (HsParTy ty) -- to be sure HsParTy doesn't get into the way - = checkContext ty + check (HsTyVar t) -- Empty context shows up as a unit type () + | t == getRdrName unitTyCon = return (L l []) -checkContext (HsTyVar t) -- Empty context shows up as a unit type () - | t == getRdrName unitTyCon = return [] + check t + = do p <- checkPred (L l t) + return (L l [p]) -checkContext t - = checkPred t >>= \p -> - return [p] -checkPred :: RdrNameHsType -> P (HsPred RdrName) +checkPred :: LHsType RdrName -> P (LHsPred RdrName) -- Watch out.. in ...deriving( Show )... we use checkPred on -- the list of partially applied predicates in the deriving, -- so there can be zero args. -checkPred (HsPredTy (HsIParam n ty)) = return (HsIParam n ty) -checkPred ty - = go ty [] +checkPred (L spn (HsPredTy (L _ (HsIParam n ty))) ) + = return (L spn (HsIParam n ty)) +checkPred (L spn ty) + = check spn ty [] where - go (HsTyVar t) args | not (isRdrTyVar t) - = return (HsClassP t args) - go (HsAppTy l r) args = go l (r:args) - go (HsParTy t) args = go t args - go _ _ = parseError "Illegal class assertion" + checkl (L l ty) args = check l ty args -checkDictTy :: RdrNameHsType -> [RdrNameHsType] -> P RdrNameHsType -checkDictTy (HsTyVar t) args@(_:_) | not (isRdrTyVar t) - = return (mkHsDictTy t args) -checkDictTy (HsAppTy l r) args = checkDictTy l (r:args) -checkDictTy (HsParTy t) args = checkDictTy t args -checkDictTy _ _ = parseError "Malformed context in instance header" + check loc (HsTyVar t) args | not (isRdrTyVar t) + = return (L spn (HsClassP t args)) + check loc (HsAppTy l r) args = checkl l (r:args) + check loc (HsParTy t) args = checkl t args + check loc _ _ = parseError loc "malformed class assertion" +checkDictTy :: LHsType RdrName -> P (LHsType RdrName) +checkDictTy (L spn ty) = check ty [] + where + check (HsTyVar t) args@(_:_) | not (isRdrTyVar t) + = return (L spn (HsPredTy (L spn (HsClassP t args)))) + check (HsAppTy l r) args = check (unLoc l) (r:args) + check (HsParTy t) args = check (unLoc t) args + check _ _ = parseError spn "Malformed context in instance header" --------------------------------------------------------------------------- -- Checking statements in a do-expression @@ -727,11 +661,17 @@ checkDictTy _ _ = parseError "Malformed context in instance header" checkDo = checkDoMDo "a " "'do'" checkMDo = checkDoMDo "an " "'mdo'" -checkDoMDo _ nm [] = parseError $ "Empty " ++ nm ++ " construct" -checkDoMDo _ _ [ExprStmt e _ l] = return [ResultStmt e l] -checkDoMDo pre nm [s] = parseError $ "The last statement in " ++ pre ++ nm ++ " construct must be an expression" -checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss >>= \ ss' -> - return (s:ss') +checkDoMDo :: String -> String -> SrcSpan -> [LStmt RdrName] -> P [LStmt RdrName] +checkDoMDo pre nm loc [] = parseError loc ("Empty " ++ nm ++ " construct") +checkDoMDo pre nm loc ss = do + check ss + where + check [L l (ExprStmt e _)] = return [L l (ResultStmt e)] + check [L l _] = parseError l ("The last statement in " ++ pre ++ nm ++ + " construct must be an expression") + check (s:ss) = do + ss' <- check ss + return (s:ss') -- ------------------------------------------------------------------------- -- Checking Patterns. @@ -739,150 +679,167 @@ checkDoMDo pre nm (s:ss) = checkDoMDo pre nm ss >>= \ ss' -> -- We parse patterns as expressions and check for valid patterns below, -- converting the expression into a pattern at the same time. -checkPattern :: SrcLoc -> RdrNameHsExpr -> P RdrNamePat -checkPattern loc e = setSrcLocFor loc (checkPat e []) - -checkPatterns :: SrcLoc -> [RdrNameHsExpr] -> P [RdrNamePat] -checkPatterns loc es = mapM (checkPattern loc) es - -checkPat :: RdrNameHsExpr -> [RdrNamePat] -> P RdrNamePat -checkPat (HsVar c) args | isRdrDataCon c = return (ConPatIn c (PrefixCon args)) -checkPat (HsApp f x) args = - checkPat x [] >>= \x -> - checkPat f (x:args) -checkPat e [] = case e of - EWildPat -> return (WildPat placeHolderType) - HsVar x | isQual x -> parseError ("Qualified variable in pattern: " ++ showRdrName x) - | otherwise -> return (VarPat x) - HsLit l -> return (LitPat l) - - -- Overloaded numeric patterns (e.g. f 0 x = x) - -- Negation is recorded separately, so that the literal is zero or +ve - -- NB. Negative *primitive* literals are already handled by - -- RdrHsSyn.mkHsNegApp - HsOverLit pos_lit -> return (NPatIn pos_lit Nothing) - NegApp (HsOverLit pos_lit) _ -> return (NPatIn pos_lit (Just placeHolderName)) - - ELazyPat e -> checkPat e [] >>= (return . LazyPat) - EAsPat n e -> checkPat e [] >>= (return . AsPat n) - ExprWithTySig e t -> checkPat e [] >>= \e -> - -- Pattern signatures are parsed as sigtypes, - -- but they aren't explicit forall points. Hence - -- we have to remove the implicit forall here. - let t' = case t of - HsForAllTy Implicit _ [] ty -> ty - other -> other - in - return (SigPatIn e t') - - -- n+k patterns - OpApp (HsVar n) (HsVar plus) _ (HsOverLit lit@(HsIntegral _ _)) - | plus == plus_RDR - -> return (mkNPlusKPat n lit) - where - plus_RDR = mkUnqual varName FSLIT("+") -- Hack - - OpApp l op fix r -> checkPat l [] >>= \l -> - checkPat r [] >>= \r -> - case op of - HsVar c | isDataOcc (rdrNameOcc c) - -> return (ConPatIn c (InfixCon l r)) - _ -> patFail - - HsPar e -> checkPat e [] >>= (return . ParPat) - ExplicitList _ es -> mapM (\e -> checkPat e []) es >>= \ps -> - return (ListPat ps placeHolderType) - ExplicitPArr _ es -> mapM (\e -> checkPat e []) es >>= \ps -> - return (PArrPat ps placeHolderType) - - ExplicitTuple es b -> mapM (\e -> checkPat e []) es >>= \ps -> - return (TuplePat ps b) - - RecordCon c fs -> mapM checkPatField fs >>= \fs -> - return (ConPatIn c (RecCon fs)) +checkPattern :: LHsExpr RdrName -> P (LPat RdrName) +checkPattern e = checkLPat e + +checkPatterns :: [LHsExpr RdrName] -> P [LPat RdrName] +checkPatterns es = mapM checkPattern es + +checkLPat :: LHsExpr RdrName -> P (LPat RdrName) +checkLPat e@(L l _) = checkPat l e [] + +checkPat :: SrcSpan -> LHsExpr RdrName -> [LPat RdrName] -> P (LPat RdrName) +checkPat loc (L l (HsVar c)) args + | isRdrDataCon c = return (L loc (ConPatIn (L l c) (PrefixCon args))) +checkPat loc (L _ (HsApp f x)) args = do + x <- checkLPat x + checkPat loc f (x:args) +checkPat loc (L _ e) [] = do + p <- checkAPat loc e + return (L loc p) +checkPat loc pat _some_args + = patFail loc + +checkAPat loc e = case e of + EWildPat -> return (WildPat placeHolderType) + HsVar x | isQual x -> parseError loc ("Qualified variable in pattern: " + ++ showRdrName x) + | otherwise -> return (VarPat x) + HsLit l -> return (LitPat l) + + -- Overloaded numeric patterns (e.g. f 0 x = x) + -- Negation is recorded separately, so that the literal is zero or +ve + -- NB. Negative *primitive* literals are already handled by + -- RdrHsSyn.mkHsNegApp + HsOverLit pos_lit -> return (NPatIn pos_lit Nothing) + NegApp (L _ (HsOverLit pos_lit)) _ + -> return (NPatIn pos_lit (Just placeHolderName)) + + ELazyPat e -> checkLPat e >>= (return . LazyPat) + EAsPat n e -> checkLPat e >>= (return . AsPat n) + ExprWithTySig e t -> checkLPat e >>= \e -> + -- Pattern signatures are parsed as sigtypes, + -- but they aren't explicit forall points. Hence + -- we have to remove the implicit forall here. + let t' = case t of + L _ (HsForAllTy Implicit _ (L _ []) ty) -> ty + other -> other + in + return (SigPatIn e t') + + -- n+k patterns + OpApp (L nloc (HsVar n)) (L _ (HsVar plus)) _ + (L _ (HsOverLit lit@(HsIntegral _ _))) + | plus == plus_RDR + -> return (mkNPlusKPat (L nloc n) lit) + where + plus_RDR = mkUnqual varName FSLIT("+") -- Hack + + OpApp l op fix r -> checkLPat l >>= \l -> + checkLPat r >>= \r -> + case op of + L cl (HsVar c) | isDataOcc (rdrNameOcc c) + -> return (ConPatIn (L cl c) (InfixCon l r)) + _ -> patFail loc + + HsPar e -> checkLPat e >>= (return . ParPat) + ExplicitList _ es -> mapM (\e -> checkLPat e) es >>= \ps -> + return (ListPat ps placeHolderType) + ExplicitPArr _ es -> mapM (\e -> checkLPat e) es >>= \ps -> + return (PArrPat ps placeHolderType) + + ExplicitTuple es b -> mapM (\e -> checkLPat e) es >>= \ps -> + return (TuplePat ps b) + + RecordCon c fs -> mapM checkPatField fs >>= \fs -> + return (ConPatIn c (RecCon fs)) -- Generics - HsType ty -> return (TypePat ty) - _ -> patFail + HsType ty -> return (TypePat ty) + _ -> patFail loc -checkPat _ _ = patFail +checkAPat loc _ = patFail loc -checkPatField :: (RdrName, RdrNameHsExpr) -> P (RdrName, RdrNamePat) -checkPatField (n,e) = checkPat e [] >>= \p -> - return (n,p) +checkPatField :: (Located RdrName, LHsExpr RdrName) -> P (Located RdrName, LPat RdrName) +checkPatField (n,e) = do + p <- checkLPat e + return (n,p) -patFail = parseError "Parse error in pattern" +patFail loc = parseError loc "Parse error in pattern" --------------------------------------------------------------------------- -- Check Equation Syntax checkValDef - :: RdrNameHsExpr - -> Maybe RdrNameHsType - -> RdrNameGRHSs - -> SrcLoc - -> P RdrBinding - -checkValDef lhs opt_sig grhss loc - = case isFunLhs lhs [] of - Just (f,inf,es) - | isQual f - -> parseError ("Qualified name in function definition: " ++ showRdrName f) - | otherwise - -> checkPatterns loc es >>= \ps -> - return (RdrValBinding (FunMonoBind f inf [Match ps opt_sig grhss] loc)) - - Nothing -> - checkPattern loc lhs >>= \lhs -> - return (RdrValBinding (PatMonoBind lhs grhss loc)) + :: LHsExpr RdrName + -> Maybe (LHsType RdrName) + -> GRHSs RdrName + -> P (HsBind RdrName) + +checkValDef lhs opt_sig grhss + | Just (f,inf,es) <- isFunLhs lhs [] + = if isQual (unLoc f) + then parseError (getLoc f) ("Qualified name in function definition: " ++ + showRdrName (unLoc f)) + else do ps <- checkPatterns es + return (FunBind f inf [L (getLoc f) (Match ps opt_sig grhss)]) + -- TODO: span is wrong + | otherwise = do + lhs <- checkPattern lhs + return (PatBind lhs grhss) checkValSig - :: RdrNameHsExpr - -> RdrNameHsType - -> SrcLoc - -> P RdrBinding -checkValSig (HsVar v) ty loc | isUnqual v = return (RdrHsDecl (SigD (Sig v ty loc))) -checkValSig other ty loc = parseError "Type signature given for an expression" - -mkSigDecls :: [Sig RdrName] -> RdrBinding -mkSigDecls sigs = RdrBindings [RdrHsDecl (SigD sig) | sig <- sigs] - - --- A variable binding is parsed as an RdrNameFunMonoBind. --- See comments with HsBinds.MonoBinds - -isFunLhs :: RdrNameHsExpr -> [RdrNameHsExpr] -> Maybe (RdrName, Bool, [RdrNameHsExpr]) -isFunLhs (OpApp l (HsVar op) fix r) es | not (isRdrDataCon op) - = Just (op, True, (l:r:es)) - | otherwise - = case isFunLhs l es of - Just (op', True, j : k : es') -> - Just (op', True, j : OpApp k (HsVar op) fix r : es') - _ -> Nothing -isFunLhs (HsVar f) es | not (isRdrDataCon f) - = Just (f,False,es) -isFunLhs (HsApp f e) es = isFunLhs f (e:es) -isFunLhs (HsPar e) es@(_:_) = isFunLhs e es -isFunLhs _ _ = Nothing + :: LHsExpr RdrName + -> LHsType RdrName + -> P (Sig RdrName) +checkValSig (L l (HsVar v)) ty | isUnqual v = return (Sig (L l v) ty) +checkValSig (L l other) ty + = parseError l "Type signature given for an expression" + +mkSigDecls :: [LSig RdrName] -> RdrBinding +mkSigDecls sigs = RdrBindings [RdrHsDecl (L l (SigD sig)) | L l sig <- sigs] + + +-- A variable binding is parsed as a FunBind. + +isFunLhs :: LHsExpr RdrName -> [LHsExpr RdrName] + -> Maybe (Located RdrName, Bool, [LHsExpr RdrName]) +isFunLhs (L loc e) = isFunLhs' loc e + where + isFunLhs' loc (HsVar f) es + | not (isRdrDataCon f) = Just (L loc f, False, es) + isFunLhs' loc (HsApp f e) es = isFunLhs f (e:es) + isFunLhs' loc (HsPar e) es@(_:_) = isFunLhs e es + isFunLhs' loc (OpApp l (L loc' (HsVar op)) fix r) es + | not (isRdrDataCon op) = Just (L loc' op, True, (l:r:es)) + | otherwise = + case isFunLhs l es of + Just (op', True, j : k : es') -> + Just (op', True, + j : L loc (OpApp k (L loc' (HsVar op)) fix r) : es') + _ -> Nothing + isFunLhs' _ _ _ = Nothing --------------------------------------------------------------------------- -- Miscellaneous utilities -checkPrecP :: Int -> P Int -checkPrecP i | 0 <= i && i <= maxPrecedence = return i - | otherwise = parseError "Precedence out of range" +checkPrecP :: Located Int -> P Int +checkPrecP (L l i) + | 0 <= i && i <= maxPrecedence = return i + | otherwise = parseError l "Precedence out of range" mkRecConstrOrUpdate - :: RdrNameHsExpr - -> RdrNameHsRecordBinds - -> P RdrNameHsExpr - -mkRecConstrOrUpdate (HsVar c) fs | isRdrDataCon c - = return (RecordCon c fs) -mkRecConstrOrUpdate exp fs@(_:_) + :: LHsExpr RdrName + -> SrcSpan + -> HsRecordBinds RdrName + -> P (HsExpr RdrName) + +mkRecConstrOrUpdate (L l (HsVar c)) loc fs | isRdrDataCon c + = return (RecordCon (L l c) fs) +mkRecConstrOrUpdate exp loc fs@(_:_) = return (RecordUpd exp fs) -mkRecConstrOrUpdate _ _ - = parseError "Empty record update" +mkRecConstrOrUpdate _ loc [] + = parseError loc "Empty record update" ----------------------------------------------------------------------------- -- utilities for foreign declarations @@ -896,25 +853,24 @@ data CallConv = CCall CCallConv -- ccall or stdcall -- mkImport :: CallConv -> Safety - -> (FastString, RdrName, RdrNameHsType) - -> SrcLoc - -> P RdrNameHsDecl -mkImport (CCall cconv) safety (entity, v, ty) loc = - parseCImport entity cconv safety v >>= \importSpec -> - return $ ForD (ForeignImport v ty importSpec False loc) -mkImport (DNCall ) _ (entity, v, ty) loc = - parseDImport entity >>= \ spec -> - return $ ForD (ForeignImport v ty (DNImport spec) False loc) + -> (Located FastString, Located RdrName, LHsType RdrName) + -> P (HsDecl RdrName) +mkImport (CCall cconv) safety (entity, v, ty) = do + importSpec <- parseCImport entity cconv safety v + return (ForD (ForeignImport v ty importSpec False)) +mkImport (DNCall ) _ (entity, v, ty) = do + spec <- parseDImport entity + return $ ForD (ForeignImport v ty (DNImport spec) False) -- parse the entity string of a foreign import declaration for the `ccall' or -- `stdcall' calling convention' -- -parseCImport :: FastString +parseCImport :: Located FastString -> CCallConv -> Safety - -> RdrName + -> Located RdrName -> P ForeignImport -parseCImport entity cconv safety v +parseCImport (L loc entity) cconv safety v -- FIXME: we should allow white space around `dynamic' and `wrapper' -=chak | entity == FSLIT ("dynamic") = return $ CImport cconv safety nilFS nilFS (CFunction DynamicTarget) @@ -947,14 +903,14 @@ parseCImport entity cconv safety v parse3 ('[':rest) header isLbl = case break (== ']') rest of (lib, ']':rest) -> parse4 rest header isLbl (mkFastString lib) - _ -> parseError "Missing ']' in entity" + _ -> parseError loc "Missing ']' in entity" parse3 str header isLbl = parse4 str header isLbl nilFS -- check for name of C function - parse4 "" header isLbl lib = build (mkExtName v) header isLbl lib - parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib + parse4 "" header isLbl lib = build (mkExtName (unLoc v)) header isLbl lib + parse4 (' ':rest) header isLbl lib = parse4 rest header isLbl lib parse4 str header isLbl lib | all (== ' ') rest = build (mkFastString first) header isLbl lib - | otherwise = parseError "Malformed entity string" + | otherwise = parseError loc "Malformed entity string" where (first, rest) = break (== ' ') str -- @@ -966,8 +922,8 @@ parseCImport entity cconv safety v -- -- Unravel a dotnet spec string. -- -parseDImport :: FastString -> P DNCallSpec -parseDImport entity = parse0 comps +parseDImport :: Located FastString -> P DNCallSpec +parseDImport (L loc entity) = parse0 comps where comps = words (unpackFS entity) @@ -997,21 +953,21 @@ parseDImport entity = parse0 comps (error "FFI-dotnet-result")) parse3 _ _ _ _ = d'oh - d'oh = parseError "Malformed entity string" + d'oh = parseError loc "Malformed entity string" -- construct a foreign export declaration -- mkExport :: CallConv - -> (FastString, RdrName, RdrNameHsType) - -> SrcLoc - -> P RdrNameHsDecl -mkExport (CCall cconv) (entity, v, ty) loc = return $ - ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False loc) + -> (Located FastString, Located RdrName, LHsType RdrName) + -> P (HsDecl RdrName) +mkExport (CCall cconv) (L loc entity, v, ty) = return $ + ForD (ForeignExport v ty (CExport (CExportStatic entity' cconv)) False) where - entity' | nullFastString entity = mkExtName v + entity' | nullFastString entity = mkExtName (unLoc v) | otherwise = entity -mkExport DNCall (entity, v, ty) loc = - parseError "Foreign export is not yet supported for .NET" +mkExport DNCall (L loc entity, v, ty) = + parseError (getLoc v){-TODO: not quite right-} + "Foreign export is not yet supported for .NET" -- Supplying the ext_name in a foreign decl is optional; if it -- isn't there, the Haskell name is assumed. Note that no transformation @@ -1032,8 +988,6 @@ mkExtName rdrNm = mkFastString (occNameUserString (rdrNameOcc rdrNm)) showRdrName :: RdrName -> String showRdrName r = showSDoc (ppr r) -parseError :: String -> P a -parseError s = - getSrcLoc >>= \ loc -> - failLocMsgP loc loc s +parseError :: SrcSpan -> String -> P a +parseError span s = failSpanMsgP span s \end{code} diff --git a/ghc/compiler/rename/RnBinds.lhs b/ghc/compiler/rename/RnBinds.lhs index c5ba50eba0..ed835ca5eb 100644 --- a/ghc/compiler/rename/RnBinds.lhs +++ b/ghc/compiler/rename/RnBinds.lhs @@ -10,7 +10,7 @@ they may be affected by renaming (which isn't fully worked out yet). \begin{code} module RnBinds ( - rnTopMonoBinds, rnMonoBinds, rnMonoBindsAndThen, + rnTopBinds, rnBinds, rnBindsAndThen, rnMethodBinds, renameSigs, checkSigs ) where @@ -18,14 +18,15 @@ module RnBinds ( import HsSyn -import HsBinds ( hsSigDoc, sigLoc, eqHsSig ) +import HsBinds ( hsSigDoc, eqHsSig ) import RdrHsSyn import RnHsSyn import TcRnMonad -import RnTypes ( rnHsSigType, rnHsType, rnPat ) +import RnTypes ( rnHsSigType, rnLHsType, rnLPat ) import RnExpr ( rnMatch, rnGRHSs, checkPrecMatch ) -import RnEnv ( bindLocatedLocalsRn, lookupBndrRn, lookupInstDeclBndr, - lookupSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV, +import RnEnv ( bindLocatedLocalsRn, lookupLocatedBndrRn, + lookupLocatedInstDeclBndr, + lookupLocatedSigOccRn, bindPatSigTyVars, bindPatSigTyVarsFV, bindLocalFixities, warnUnusedLocalBinds, mapFvRn, extendTyVarEnvFVRn, ) @@ -37,7 +38,11 @@ import PrelNames ( isUnboundName ) import RdrName ( RdrName, rdrNameOcc ) import BasicTypes ( RecFlag(..), TopLevelFlag(..), isTopLevel ) import List ( unzip4 ) +import SrcLoc ( mkSrcSpan, Located(..), unLoc ) +import Bag import Outputable + +import Monad ( foldM ) \end{code} -- ToDo: Put the annotations into the monad, so that they arrive in the proper @@ -96,7 +101,7 @@ a set of variables free in @Exp@ is written @fvExp@ %************************************************************************ %* * -%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) * +%* analysing polymorphic bindings (HsBindGroup, HsBind) %* * %************************************************************************ @@ -150,20 +155,20 @@ it expects the global environment to contain bindings for the binders contains bindings for the binders of this particular binding. \begin{code} -rnTopMonoBinds :: RdrNameMonoBinds - -> [RdrNameSig] - -> RnM (RenamedHsBinds, DefUses) +rnTopBinds :: Bag (LHsBind RdrName) + -> [LSig RdrName] + -> RnM ([HsBindGroup Name], DefUses) -- The binders of the binding are in scope already; -- the top level scope resolution does that -rnTopMonoBinds mbinds sigs - = bindPatSigTyVars (collectSigTysFromMonoBinds mbinds) $ \ _ -> +rnTopBinds mbinds sigs + = bindPatSigTyVars (collectSigTysFromHsBinds (bagToList mbinds)) $ \ _ -> -- Hmm; by analogy with Ids, this doesn't look right -- Top-level bound type vars should really scope over -- everything, but we only scope them over the other bindings - rnMonoBinds TopLevel mbinds sigs + rnBinds TopLevel mbinds sigs \end{code} @@ -174,24 +179,24 @@ rnTopMonoBinds mbinds sigs %************************************************************************ \begin{code} -rnMonoBindsAndThen :: RdrNameMonoBinds - -> [RdrNameSig] - -> (RenamedHsBinds -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) +rnBindsAndThen :: Bag (LHsBind RdrName) + -> [LSig RdrName] + -> ([HsBindGroup Name] -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) -rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds +rnBindsAndThen mbinds sigs thing_inside = -- Extract all the binders in this group, and extend the -- current scope, inventing new names for the new binders -- This also checks that the names form a set bindLocatedLocalsRn doc mbinders_w_srclocs $ \ _ -> - bindPatSigTyVarsFV (collectSigTysFromMonoBinds mbinds) $ + bindPatSigTyVarsFV (collectSigTysFromHsBinds (bagToList mbinds)) $ -- Then install local fixity declarations -- Notice that they scope over thing_inside too - bindLocalFixities [sig | FixSig sig <- sigs ] $ + bindLocalFixities [sig | L _ (FixSig sig) <- sigs ] $ -- Do the business - rnMonoBinds NotTopLevel mbinds sigs `thenM` \ (binds, bind_dus) -> + rnBinds NotTopLevel mbinds sigs `thenM` \ (binds, bind_dus) -> -- Now do the "thing inside" thing_inside binds `thenM` \ (result,result_fvs) -> @@ -213,15 +218,15 @@ rnMonoBindsAndThen mbinds sigs thing_inside -- Non-empty monobinds -- bindings in the wrong order, and the type checker will complain -- that x isn't in scope where - mbinders_w_srclocs = collectLocatedMonoBinders mbinds + mbinders_w_srclocs = collectHsBindLocatedBinders mbinds doc = text "In the binding group for:" - <+> pprWithCommas ppr (map fst mbinders_w_srclocs) + <+> pprWithCommas ppr (map unLoc mbinders_w_srclocs) \end{code} %************************************************************************ %* * -\subsubsection{ MonoBinds -- the main work is done here} +\subsubsection{rnBinds -- the main work is done here} %* * %************************************************************************ @@ -231,27 +236,26 @@ This is done {\em either} by pass 3 (for the top-level bindings), {\em or} by @rnMonoBinds@ (for the nested ones). \begin{code} -rnMonoBinds :: TopLevelFlag - -> RdrNameMonoBinds - -> [RdrNameSig] - -> RnM (RenamedHsBinds, DefUses) +rnBinds :: TopLevelFlag + -> Bag (LHsBind RdrName) + -> [LSig RdrName] + -> RnM ([HsBindGroup Name], DefUses) -- Assumes the binders of the binding are in scope already -rnMonoBinds top_lvl mbinds sigs +rnBinds top_lvl mbinds sigs = renameSigs sigs `thenM` \ siglist -> - -- Rename the bindings, returning a MonoBindsInfo + -- Rename the bindings, returning a [HsBindVertex] -- which is a list of indivisible vertices so far as -- the strongly-connected-components (SCC) analysis is concerned - flattenMonoBinds siglist mbinds `thenM` \ mbinds_info -> + mkBindVertices siglist mbinds `thenM` \ mbinds_info -> -- Do the SCC analysis let scc_result = rnSCC mbinds_info - (binds_s, bind_dus_s) = unzip (map reconstructCycle scc_result) + (groups, bind_dus_s) = unzip (map reconstructCycle scc_result) bind_dus = mkDUs bind_dus_s - final_binds = foldr ThenBinds EmptyBinds binds_s binders = duDefs bind_dus in -- Check for duplicate or mis-placed signatures @@ -264,7 +268,7 @@ rnMonoBinds top_lvl mbinds sigs (if isTopLevel top_lvl && warn_missing_sigs then let - type_sig_vars = [n | Sig n _ _ <- siglist] + type_sig_vars = [ unLoc n | L _ (Sig n _) <- siglist] un_sigd_binders = filter (not . (`elem` type_sig_vars)) (nameSetToList binders) in @@ -273,27 +277,22 @@ rnMonoBinds top_lvl mbinds sigs returnM () ) `thenM_` - returnM (final_binds, bind_dus `plusDU` usesOnly (hsSigsFVs siglist)) + returnM (groups, bind_dus `plusDU` usesOnly (hsSigsFVs siglist)) \end{code} -@flattenMonoBinds@ is ever-so-slightly magical in that it sticks +@mkBindVertices@ is ever-so-slightly magical in that it sticks unique ``vertex tags'' on its output; minor plumbing required. \begin{code} -flattenMonoBinds :: [RenamedSig] -- Signatures - -> RdrNameMonoBinds - -> RnM [FlatMonoBinds] - -flattenMonoBinds sigs EmptyMonoBinds = returnM [] +mkBindVertices :: [LSig Name] -- Signatures + -> Bag (LHsBind RdrName) + -> RnM [BindVertex] +mkBindVertices sigs = mapM (mkBindVertex sigs) . bagToList -flattenMonoBinds sigs (AndMonoBinds bs1 bs2) - = flattenMonoBinds sigs bs1 `thenM` \ flat1 -> - flattenMonoBinds sigs bs2 `thenM` \ flat2 -> - returnM (flat1 ++ flat2) - -flattenMonoBinds sigs (PatMonoBind pat grhss locn) - = addSrcLoc locn $ - rnPat pat `thenM` \ (pat', pat_fvs) -> +mkBindVertex :: [LSig Name] -> LHsBind RdrName -> RnM BindVertex +mkBindVertex sigs (L loc (PatBind pat grhss)) + = addSrcSpan loc $ + rnLPat pat `thenM` \ (pat', pat_fvs) -> -- Find which things are bound in this group let @@ -302,30 +301,33 @@ flattenMonoBinds sigs (PatMonoBind pat grhss locn) sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> rnGRHSs PatBindRhs grhss `thenM` \ (grhss', fvs) -> returnM - [(names_bound_here, fvs `plusFV` pat_fvs, - PatMonoBind pat' grhss' locn, sigs_for_me - )] + (names_bound_here, fvs `plusFV` pat_fvs, + L loc (PatBind pat' grhss'), sigs_for_me + ) -flattenMonoBinds sigs (FunMonoBind name inf matches locn) - = addSrcLoc locn $ - lookupBndrRn name `thenM` \ new_name -> +mkBindVertex sigs (L loc (FunBind name inf matches)) + = addSrcSpan loc $ + lookupLocatedBndrRn name `thenM` \ new_name -> let - names_bound_here = unitNameSet new_name + plain_name = unLoc new_name + names_bound_here = unitNameSet plain_name in sigsForMe names_bound_here sigs `thenM` \ sigs_for_me -> - mapFvRn (rnMatch (FunRhs new_name)) matches `thenM` \ (new_matches, fvs) -> - mappM_ (checkPrecMatch inf new_name) new_matches `thenM_` + mapFvRn (rnMatch (FunRhs plain_name)) matches `thenM` \ (new_matches, fvs) -> + mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_` returnM - [(unitNameSet new_name, fvs, - FunMonoBind new_name inf new_matches locn, sigs_for_me - )] + (unitNameSet plain_name, fvs, + L loc (FunBind new_name inf new_matches), sigs_for_me + ) sigsForMe names_bound_here sigs = foldlM check [] (filter (sigForThisGroup names_bound_here) sigs) where -- sigForThisGroup only returns signatures for -- which sigName returns a Just - check sigs sig = case filter (eqHsSig sig) sigs of + eq sig1 sig2 = eqHsSig (unLoc sig1) (unLoc sig2) + + check sigs sig = case filter (eq sig) sigs of [] -> returnM (sig:sigs) other -> dupSigDeclErr sig other `thenM_` returnM sigs @@ -333,7 +335,7 @@ sigsForMe names_bound_here sigs @rnMethodBinds@ is used for the method bindings of a class and an instance -declaration. Like @rnMonoBinds@ but without dependency analysis. +declaration. Like @rnBinds@ but without dependency analysis. NOTA BENE: we record each {\em binder} of a method-bind group as a free variable. That's crucial when dealing with an instance decl: @@ -350,67 +352,61 @@ a binder. \begin{code} rnMethodBinds :: Name -- Class name -> [Name] -- Names for generic type variables - -> RdrNameMonoBinds - -> RnM (RenamedMonoBinds, FreeVars) + -> (LHsBinds RdrName) + -> RnM (LHsBinds Name, FreeVars) -rnMethodBinds cls gen_tyvars EmptyMonoBinds = returnM (EmptyMonoBinds, emptyFVs) +rnMethodBinds cls gen_tyvars binds + = foldM do_one (emptyBag,emptyFVs) (bagToList binds) + where do_one (binds,fvs) bind = do + (bind', fvs_bind) <- rnMethodBind cls gen_tyvars bind + return (bind' `unionBags` binds, fvs_bind `plusFV` fvs) -rnMethodBinds cls gen_tyvars (AndMonoBinds mb1 mb2) - = rnMethodBinds cls gen_tyvars mb1 `thenM` \ (mb1', fvs1) -> - rnMethodBinds cls gen_tyvars mb2 `thenM` \ (mb2', fvs2) -> - returnM (mb1' `AndMonoBinds` mb2', fvs1 `plusFV` fvs2) -rnMethodBinds cls gen_tyvars (FunMonoBind name inf matches locn) - = addSrcLoc locn $ - - lookupInstDeclBndr cls name `thenM` \ sel_name -> +rnMethodBind cls gen_tyvars (L loc (FunBind name inf matches)) + = addSrcSpan loc $ + lookupLocatedInstDeclBndr cls name `thenM` \ sel_name -> + let plain_name = unLoc sel_name in -- We use the selector name as the binder - mapFvRn (rn_match sel_name) matches `thenM` \ (new_matches, fvs) -> - mappM_ (checkPrecMatch inf sel_name) new_matches `thenM_` - returnM (FunMonoBind sel_name inf new_matches locn, fvs `addOneFV` sel_name) + mapFvRn (rn_match plain_name) matches `thenM` \ (new_matches, fvs) -> + mappM_ (checkPrecMatch inf plain_name) new_matches `thenM_` + returnM (unitBag (L loc (FunBind sel_name inf new_matches)), fvs `addOneFV` plain_name) where -- Gruesome; bring into scope the correct members of the generic type variables -- See comments in RnSource.rnSourceDecl(ClassDecl) - rn_match sel_name match@(Match (TypePat ty : _) _ _) + rn_match sel_name match@(L _ (Match (L _ (TypePat ty) : _) _ _)) = extendTyVarEnvFVRn gen_tvs $ rnMatch (FunRhs sel_name) match where - tvs = map rdrNameOcc (extractHsTyRdrTyVars ty) + tvs = map (rdrNameOcc.unLoc) (extractHsTyRdrTyVars ty) gen_tvs = [tv | tv <- gen_tyvars, nameOccName tv `elem` tvs] rn_match sel_name match = rnMatch (FunRhs sel_name) match - + -- Can't handle method pattern-bindings which bind multiple methods. -rnMethodBinds cls gen_tyvars mbind@(PatMonoBind other_pat _ locn) - = addSrcLoc locn (addErr (methodBindErr mbind)) `thenM_` - returnM (EmptyMonoBinds, emptyFVs) +rnMethodBind cls gen_tyvars mbind@(L loc (PatBind other_pat _)) + = addLocErr mbind methodBindErr `thenM_` + returnM (emptyBag, emptyFVs) \end{code} %************************************************************************ %* * Strongly connected components - %* * %************************************************************************ -During analysis a @MonoBinds@ is flattened to a @FlatMonoBinds@. -The @RenamedMonoBinds@ is always an empty bind, a pattern binding or -a function binding, and has itself been dependency-analysed and -renamed. - \begin{code} -type FlatMonoBinds = (Defs, Uses, RenamedMonoBinds, [RenamedSig]) +type BindVertex = (Defs, Uses, LHsBind Name, [LSig Name]) -- Signatures, if any, for this vertex -rnSCC :: [FlatMonoBinds] -> [SCC FlatMonoBinds] +rnSCC :: [BindVertex] -> [SCC BindVertex] rnSCC nodes = stronglyConnComp (mkEdges nodes) type VertexTag = Int -mkEdges :: [FlatMonoBinds] -> [(FlatMonoBinds, VertexTag, [VertexTag])] +mkEdges :: [BindVertex] -> [(BindVertex, VertexTag, [VertexTag])] -- We keep the uses with the binding, -- so we can track unused bindings better mkEdges nodes @@ -426,16 +422,16 @@ mkEdges nodes defs `intersectsNameSet` uses ] -reconstructCycle :: SCC FlatMonoBinds -> (RenamedHsBinds, (Defs,Uses)) -reconstructCycle (AcyclicSCC (defs, uses, binds, sigs)) - = (MonoBind binds sigs NonRecursive, (defs, uses)) +reconstructCycle :: SCC BindVertex -> (HsBindGroup Name, (Defs,Uses)) +reconstructCycle (AcyclicSCC (defs, uses, bind, sigs)) + = (HsBindGroup (unitBag bind) sigs NonRecursive, (defs, uses)) reconstructCycle (CyclicSCC cycle) - = (MonoBind this_gp_binds this_gp_sigs Recursive, + = (HsBindGroup this_gp_binds this_gp_sigs Recursive, (unionManyNameSets defs_s, unionManyNameSets uses_s)) where (defs_s, uses_s, binds_s, sigs_s) = unzip4 cycle - this_gp_binds = foldr1 AndMonoBinds binds_s - this_gp_sigs = foldr1 (++) sigs_s + this_gp_binds = listToBag binds_s + this_gp_sigs = foldr1 (++) sigs_s \end{code} @@ -456,8 +452,8 @@ At the moment we don't gather free-var info from the types in signatures. We'd only need this if we wanted to report unused tyvars. \begin{code} -checkSigs :: (RenamedSig -> Bool) -- OK-sig predicbate - -> [RenamedSig] +checkSigs :: (LSig Name -> Bool) -- OK-sig predicbate + -> [LSig Name] -> RnM () checkSigs ok_sig sigs -- Check for (a) duplicate signatures @@ -467,7 +463,8 @@ checkSigs ok_sig sigs where bad sig = not (ok_sig sig) && case sigName sig of - Just n | isUnboundName n -> False -- Don't complain about an unbound name again + Just n | isUnboundName n -> False + -- Don't complain about an unbound name again other -> True -- We use lookupSigOccRn in the signatures, which is a little bit unsatisfactory @@ -479,33 +476,29 @@ checkSigs ok_sig sigs -- is in scope. (I'm assuming that Baz.op isn't in scope unqualified.) -- Doesn't seem worth much trouble to sort this. -renameSigs :: [Sig RdrName] -> RnM [Sig Name] -renameSigs sigs = mappM renameSig (filter (not . isFixitySig) sigs) +renameSigs :: [LSig RdrName] -> RnM [LSig Name] +renameSigs sigs = mappM (wrapLocM renameSig) (filter (not . isFixitySig . unLoc) sigs) -- Remove fixity sigs which have been dealt with already renameSig :: Sig RdrName -> RnM (Sig Name) -- FixitSig is renamed elsewhere. -renameSig (Sig v ty src_loc) - = addSrcLoc src_loc $ - lookupSigOccRn v `thenM` \ new_v -> +renameSig (Sig v ty) + = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (Sig new_v new_ty src_loc) + returnM (Sig new_v new_ty) -renameSig (SpecInstSig ty src_loc) - = addSrcLoc src_loc $ - rnHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> - returnM (SpecInstSig new_ty src_loc) +renameSig (SpecInstSig ty) + = rnLHsType (text "A SPECIALISE instance pragma") ty `thenM` \ new_ty -> + returnM (SpecInstSig new_ty) -renameSig (SpecSig v ty src_loc) - = addSrcLoc src_loc $ - lookupSigOccRn v `thenM` \ new_v -> +renameSig (SpecSig v ty) + = lookupLocatedSigOccRn v `thenM` \ new_v -> rnHsSigType (quotes (ppr v)) ty `thenM` \ new_ty -> - returnM (SpecSig new_v new_ty src_loc) + returnM (SpecSig new_v new_ty) -renameSig (InlineSig b v p src_loc) - = addSrcLoc src_loc $ - lookupSigOccRn v `thenM` \ new_v -> - returnM (InlineSig b new_v p src_loc) +renameSig (InlineSig b v p) + = lookupLocatedSigOccRn v `thenM` \ new_v -> + returnM (InlineSig b new_v p) \end{code} @@ -516,24 +509,25 @@ renameSig (InlineSig b v p src_loc) %************************************************************************ \begin{code} -dupSigDeclErr sig sigs - = addSrcLoc loc $ - addErr (vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, - nest 2 (vcat (map ppr_sig (sig:sigs)))]) +dupSigDeclErr (L loc sig) sigs + = addErrAt loc $ + vcat [ptext SLIT("Duplicate") <+> what_it_is <> colon, + nest 2 (vcat (map ppr_sig (L loc sig:sigs)))] where - (what_it_is, loc) = hsSigDoc sig - ppr_sig sig = ppr (sigLoc sig) <> colon <+> ppr sig + what_it_is = hsSigDoc sig + ppr_sig (L loc sig) = ppr loc <> colon <+> ppr sig -unknownSigErr sig - = addSrcLoc loc $ - addErr (sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, - ppr sig]) +unknownSigErr (L loc sig) + = addErrAt loc $ + sep [ptext SLIT("Misplaced") <+> what_it_is <> colon, ppr sig] where - (what_it_is, loc) = hsSigDoc sig + what_it_is = hsSigDoc sig missingSigWarn var - = addSrcLoc (nameSrcLoc var) $ - addWarn (sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)]) + = addWarnAt (mkSrcSpan loc loc) $ + sep [ptext SLIT("Definition but no type signature for"), quotes (ppr var)] + where + loc = nameSrcLoc var -- TODO: make a proper span methodBindErr mbind = hang (ptext SLIT("Can't handle multiple methods defined by one pattern binding")) diff --git a/ghc/compiler/rename/RnEnv.lhs b/ghc/compiler/rename/RnEnv.lhs index d69d5c0408..afcfe1764b 100644 --- a/ghc/compiler/rename/RnEnv.lhs +++ b/ghc/compiler/rename/RnEnv.lhs @@ -6,15 +6,18 @@ \begin{code} module RnEnv ( newTopSrcBinder, - lookupBndrRn,lookupTopBndrRn, - lookupOccRn, lookupGlobalOccRn, + lookupLocatedBndrRn, lookupBndrRn, + lookupLocatedTopBndrRn, lookupTopBndrRn, + lookupLocatedOccRn, lookupOccRn, + lookupLocatedGlobalOccRn, lookupGlobalOccRn, lookupTopFixSigNames, lookupSrcOcc_maybe, - lookupFixityRn, lookupSigOccRn, lookupInstDeclBndr, + lookupFixityRn, lookupLocatedSigOccRn, + lookupLocatedInstDeclBndr, lookupSyntaxName, lookupSyntaxNames, lookupImportedName, newLocalsRn, newIPNameRn, bindLocalNames, bindLocalNamesFV, - bindLocalsRn, bindLocalsFV, bindLocatedLocalsRn, + bindLocatedLocalsFV, bindLocatedLocalsRn, bindPatSigTyVars, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalFixities, @@ -22,7 +25,7 @@ module RnEnv ( checkDupNames, mapFvRn, warnUnusedMatches, warnUnusedModules, warnUnusedImports, warnUnusedTopBinds, warnUnusedLocalBinds, - dataTcOccs, unknownNameErr + dataTcOccs, unknownNameErr, ) where #include "HsVersions.h" @@ -30,7 +33,7 @@ module RnEnv ( import LoadIface ( loadSrcInterface ) import IfaceEnv ( lookupOrig, newGlobalBinder, newIPName ) import HsSyn -import RdrHsSyn ( RdrNameHsType, RdrNameFixitySig, extractHsTyRdrTyVars ) +import RdrHsSyn ( extractHsTyRdrTyVars ) import RdrName ( RdrName, rdrNameModule, rdrNameOcc, isQual, isUnqual, isOrig, mkRdrUnqual, setRdrNameSpace, rdrNameOcc, pprGlobalRdrEnv, lookupGRE_RdrName, @@ -50,10 +53,11 @@ import Module ( Module, ModuleName, moduleName, mkHomeModule ) import PrelNames ( mkUnboundName, rOOT_MAIN_Name, iNTERACTIVE ) import UniqSupply import BasicTypes ( IPName, mapIPName ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( srcSpanStart, Located(..), eqLocated, unLoc, + srcLocSpan ) import Outputable -import ListSetOps ( removeDups, equivClasses ) -import List ( nub ) +import ListSetOps ( removeDups ) +import List ( nubBy ) import CmdLineOpts import FastString ( FastString ) \end{code} @@ -65,8 +69,8 @@ import FastString ( FastString ) %********************************************************* \begin{code} -newTopSrcBinder :: Module -> Maybe Name -> (RdrName, SrcLoc) -> RnM Name -newTopSrcBinder mod mb_parent (rdr_name, loc) +newTopSrcBinder :: Module -> Maybe Name -> Located RdrName -> RnM Name +newTopSrcBinder mod mb_parent (L loc rdr_name) | Just name <- isExact_maybe rdr_name = returnM name @@ -82,10 +86,11 @@ newTopSrcBinder mod mb_parent (rdr_name, loc) -- not from the environment. In principle, it'd be fine to have an -- arbitrary mixture of external core definitions in a single module, -- (apart from module-initialisation issues, perhaps). - newGlobalBinder (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) mb_parent loc + newGlobalBinder (mkHomeModule rdr_mod) (rdrNameOcc rdr_name) mb_parent + (srcSpanStart loc) --TODO, should pass the whole span | otherwise - = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent loc + = newGlobalBinder mod (rdrNameOcc rdr_name) mb_parent (srcSpanStart loc) where rdr_mod = rdrNameModule rdr_name \end{code} @@ -99,12 +104,20 @@ newTopSrcBinder mod mb_parent (rdr_name, loc) Looking up a name in the RnEnv. \begin{code} +lookupLocatedBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedBndrRn = wrapLocM lookupBndrRn + +lookupBndrRn :: RdrName -> RnM Name +-- NOTE: assumes that the SrcSpan of the binder has already been addSrcSpan'd lookupBndrRn rdr_name = getLocalRdrEnv `thenM` \ local_env -> case lookupLocalRdrEnv local_env rdr_name of Just name -> returnM name Nothing -> lookupTopBndrRn rdr_name +lookupLocatedTopBndrRn :: Located RdrName -> RnM (Located Name) +lookupLocatedTopBndrRn = wrapLocM lookupTopBndrRn + lookupTopBndrRn :: RdrName -> RnM Name -- Look up a top-level source-code binder. We may be looking up an unqualified 'f', -- and there may be several imported 'f's too, which must not confuse us. @@ -143,9 +156,10 @@ lookupTopBndrRn rdr_name -- This deals with the case of derived bindings, where -- we don't bother to call newTopSrcBinder first -- We assume there is no "parent" name - = getSrcLocM `thenM` \ loc -> - newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) - (rdrNameOcc rdr_name) Nothing loc + = do + loc <- getSrcSpanM + newGlobalBinder (mkHomeModule (rdrNameModule rdr_name)) + (rdrNameOcc rdr_name) Nothing (srcSpanStart loc) | otherwise = do { mb_gre <- lookupGreLocalRn rdr_name @@ -153,7 +167,7 @@ lookupTopBndrRn rdr_name Nothing -> unboundName rdr_name Just gre -> returnM (gre_name gre) } --- lookupSigOccRn is used for type signatures and pragmas +-- lookupLocatedSigOccRn is used for type signatures and pragmas -- Is this valid? -- module A -- import M( f ) @@ -163,13 +177,16 @@ lookupTopBndrRn rdr_name -- The Haskell98 report does not stipulate this, but it will! -- So we must treat the 'f' in the signature in the same way -- as the binding occurrence of 'f', using lookupBndrRn -lookupSigOccRn :: RdrName -> RnM Name -lookupSigOccRn = lookupBndrRn +lookupLocatedSigOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedSigOccRn = lookupLocatedBndrRn -- lookupInstDeclBndr is used for the binders in an -- instance declaration. Here we use the class name to -- disambiguate. +lookupLocatedInstDeclBndr :: Name -> Located RdrName -> RnM (Located Name) +lookupLocatedInstDeclBndr cls = wrapLocM (lookupInstDeclBndr cls) + lookupInstDeclBndr :: Name -> RdrName -> RnM Name lookupInstDeclBndr cls_name rdr_name | isUnqual rdr_name -- Find all the things the rdr-name maps to @@ -196,6 +213,9 @@ newIPNameRn ip_rdr = newIPName (mapIPName rdrNameOcc ip_rdr) -- Occurrences -------------------------------------------------- +lookupLocatedOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedOccRn = wrapLocM lookupOccRn + -- lookupOccRn looks up an occurrence of a RdrName lookupOccRn :: RdrName -> RnM Name lookupOccRn rdr_name @@ -204,6 +224,9 @@ lookupOccRn rdr_name Just name -> returnM name Nothing -> lookupGlobalOccRn rdr_name +lookupLocatedGlobalOccRn :: Located RdrName -> RnM (Located Name) +lookupLocatedGlobalOccRn = wrapLocM lookupGlobalOccRn + lookupGlobalOccRn :: RdrName -> RnM Name -- lookupGlobalOccRn is like lookupOccRn, except that it looks in the global -- environment. It's used only for @@ -282,7 +305,7 @@ lookupGreLocalRn rdr_name where lookup_fn env = filter isLocalGRE (lookupGRE_RdrName rdr_name env) -lookupGreRn_help :: RdrName -- Only used in error message +lookupGreRn_help :: RdrName -- Only used in error message -> (GlobalRdrEnv -> [GlobalRdrElt]) -- Lookup function -> RnM (Maybe GlobalRdrElt) -- Checks for exactly one match; reports deprecations @@ -343,7 +366,7 @@ lookupTopFixSigNames rdr_name ; return [gre_name gre | Just gre <- mb_gres] } -------------------------------- -bindLocalFixities :: [RdrNameFixitySig] -> RnM a -> RnM a +bindLocalFixities :: [FixitySig RdrName] -> RnM a -> RnM a -- Used for nested fixity decls -- No need to worry about type constructors here, -- Should check for duplicates but we don't @@ -352,10 +375,9 @@ bindLocalFixities fixes thing_inside | otherwise = mappM rn_sig fixes `thenM` \ new_bit -> extendFixityEnv new_bit thing_inside where - rn_sig (FixitySig v fix src_loc) - = addSrcLoc src_loc $ - lookupSigOccRn v `thenM` \ new_v -> - returnM (new_v, (FixItem (rdrNameOcc v) fix src_loc)) + rn_sig (FixitySig lv@(L loc v) fix) + = addLocM lookupBndrRn lv `thenM` \ new_v -> + returnM (new_v, (FixItem (rdrNameOcc v) fix loc)) \end{code} -------------------------------- @@ -479,9 +501,9 @@ lookupSyntaxNames std_names -- Get the similarly named thing from the local environment mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names -> - returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names) + returnM (std_names `zip` map nlHsVar usr_names, mkFVs usr_names) where - normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs) + normal_case = returnM (std_names `zip` map nlHsVar std_names, emptyFVs) \end{code} @@ -492,21 +514,21 @@ lookupSyntaxNames std_names %********************************************************* \begin{code} -newLocalsRn :: [(RdrName,SrcLoc)] -> RnM [Name] +newLocalsRn :: [Located RdrName] -> RnM [Name] newLocalsRn rdr_names_w_loc = newUniqueSupply `thenM` \ us -> returnM (zipWith mk rdr_names_w_loc (uniqsFromSupply us)) where - mk (rdr_name, loc) uniq + mk (L loc rdr_name) uniq | Just name <- isExact_maybe rdr_name = name -- This happens in code generated by Template Haskell | otherwise = ASSERT2( isUnqual rdr_name, ppr rdr_name ) -- We only bind unqualified names here -- lookupRdrEnv doesn't even attempt to look up a qualified RdrName - mkInternalName uniq (rdrNameOcc rdr_name) loc + mkInternalName uniq (rdrNameOcc rdr_name) (srcSpanStart loc) bindLocatedLocalsRn :: SDoc -- Documentation string for error message - -> [(RdrName,SrcLoc)] + -> [Located RdrName] -> ([Name] -> RnM a) -> RnM a bindLocatedLocalsRn doc_str rdr_names_w_loc enclosed_scope @@ -536,16 +558,12 @@ bindLocalNamesFV names enclosed_scope ------------------------------------- -bindLocalsRn doc rdr_names enclosed_scope - = getSrcLocM `thenM` \ loc -> - bindLocatedLocalsRn doc - (rdr_names `zip` repeat loc) - enclosed_scope - -- binLocalsFVRn is the same as bindLocalsRn -- except that it deals with free vars -bindLocalsFV doc rdr_names enclosed_scope - = bindLocalsRn doc rdr_names $ \ names -> +bindLocatedLocalsFV :: SDoc -> [Located RdrName] -> ([Name] -> RnM (a,FreeVars)) + -> RnM (a, FreeVars) +bindLocatedLocalsFV doc rdr_names enclosed_scope + = bindLocatedLocalsRn doc rdr_names $ \ names -> enclosed_scope names `thenM` \ (thing, fvs) -> returnM (thing, delListFromNameSet fvs names) @@ -556,39 +574,37 @@ extendTyVarEnvFVRn tyvars enclosed_scope = bindLocalNames tyvars enclosed_scope `thenM` \ (thing, fvs) -> returnM (thing, delListFromNameSet fvs tyvars) -bindTyVarsRn :: SDoc -> [HsTyVarBndr RdrName] - -> ([HsTyVarBndr Name] -> RnM a) +bindTyVarsRn :: SDoc -> [LHsTyVarBndr RdrName] + -> ([LHsTyVarBndr Name] -> RnM a) -> RnM a bindTyVarsRn doc_str tyvar_names enclosed_scope - = getSrcLocM `thenM` \ loc -> - let - located_tyvars = [(hsTyVarName tv, loc) | tv <- tyvar_names] + = let + located_tyvars = [L loc (hsTyVarName tv) | L loc tv <- tyvar_names] in bindLocatedLocalsRn doc_str located_tyvars $ \ names -> - enclosed_scope (zipWith replaceTyVarName tyvar_names names) + enclosed_scope (zipWith replace tyvar_names names) + where + replace (L loc n1) n2 = L loc (replaceTyVarName n1 n2) -bindPatSigTyVars :: [RdrNameHsType] -> ([Name] -> RnM a) -> RnM a +bindPatSigTyVars :: [LHsType RdrName] -> ([Name] -> RnM a) -> RnM a -- Find the type variables in the pattern type -- signatures that must be brought into scope - bindPatSigTyVars tys thing_inside = getLocalRdrEnv `thenM` \ name_env -> - getSrcLocM `thenM` \ loc -> let - forall_tyvars = nub [ tv | ty <- tys, - tv <- extractHsTyRdrTyVars ty, - not (tv `elemLocalRdrEnv` name_env) + located_tyvars = nubBy eqLocated [ tv | ty <- tys, + tv <- extractHsTyRdrTyVars ty, + not (unLoc tv `elemLocalRdrEnv` name_env) ] -- The 'nub' is important. For example: -- f (x :: t) (y :: t) = .... -- We don't want to complain about binding t twice! - located_tyvars = [(tv, loc) | tv <- forall_tyvars] doc_sig = text "In a pattern type-signature" in bindLocatedLocalsRn doc_sig located_tyvars thing_inside -bindPatSigTyVarsFV :: [RdrNameHsType] +bindPatSigTyVarsFV :: [LHsType RdrName] -> RnM (a, FreeVars) -> RnM (a, FreeVars) bindPatSigTyVarsFV tys thing_inside @@ -598,26 +614,26 @@ bindPatSigTyVarsFV tys thing_inside ------------------------------------- checkDupNames :: SDoc - -> [(RdrName, SrcLoc)] + -> [Located RdrName] -> RnM () checkDupNames doc_str rdr_names_w_loc = -- Check for duplicated names in a binding group mappM_ (dupNamesErr doc_str) dups where - (_, dups) = removeDups (\(n1,l1) (n2,l2) -> n1 `compare` n2) rdr_names_w_loc + (_, dups) = removeDups (\n1 n2 -> unLoc n1 `compare` unLoc n2) rdr_names_w_loc ------------------------------------- -checkShadowing doc_str rdr_names_w_loc +checkShadowing doc_str loc_rdr_names = getLocalRdrEnv `thenM` \ local_env -> getGlobalRdrEnv `thenM` \ global_env -> let - check_shadow (rdr_name,loc) + check_shadow (L loc rdr_name) | rdr_name `elemLocalRdrEnv` local_env || not (null (lookupGRE_RdrName rdr_name global_env )) - = addSrcLoc loc $ addWarn (shadowedNameWarn doc_str rdr_name) + = addSrcSpan loc $ addWarn (shadowedNameWarn doc_str rdr_name) | otherwise = returnM () in - mappM_ check_shadow rdr_names_w_loc + mappM_ check_shadow loc_rdr_names \end{code} @@ -663,35 +679,30 @@ warnUnusedMatches names = ifOptM Opt_WarnUnusedMatches (warnUnusedLocals name ------------------------- -- Helpers -warnUnusedGREs gres = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedLocals names = warnUnusedBinds [(n,Nothing) | n<-names] +warnUnusedGREs gres + = warnUnusedBinds [(n,Just p) | GRE {gre_name = n, gre_prov = p} <- gres] -warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () -warnUnusedBinds names - = mappM_ warnUnusedGroup groups - where - -- Group by provenance - groups = equivClasses cmp (filter reportable names) - (_,prov1) `cmp` (_,prov2) = prov1 `compare` prov2 - - reportable (name,_) = reportIfUnused (nameOccName name) +warnUnusedLocals names + = warnUnusedBinds [(n,Nothing) | n<-names] +warnUnusedBinds :: [(Name,Maybe Provenance)] -> RnM () +warnUnusedBinds names = mappM_ warnUnusedName (filter reportable names) + where reportable (name,_) = reportIfUnused (nameOccName name) ------------------------- -warnUnusedGroup :: [(Name,Maybe Provenance)] -> RnM () -warnUnusedGroup names - = addSrcLoc def_loc $ - addWarn $ - sep [msg <> colon, nest 4 (fsep (punctuate comma (map (ppr.fst) names)))] +warnUnusedName :: (Name, Maybe Provenance) -> RnM () +warnUnusedName (name, prov) + = addWarnAt loc (sep [msg <> colon, nest 4 (ppr name)]) + -- TODO should be a proper span where - (name1, prov1) = head names - loc1 = nameSrcLoc name1 - (def_loc, msg) = case prov1 of - Just (Imported is _) -> (is_loc imp_spec, imp_from (is_mod imp_spec)) - where - imp_spec = head is - other -> (loc1, unused_msg) + (loc,msg) = case prov of + Just (Imported is _) -> + ( is_loc (head is), imp_from (is_mod imp_spec) ) + where + imp_spec = head is + other -> + ( srcLocSpan (nameSrcLoc name), unused_msg ) unused_msg = text "Defined but not used" imp_from mod = text "Imported from" <+> quotes (ppr mod) <+> text "but not used" @@ -724,8 +735,8 @@ badOrigBinding name = ptext SLIT("Illegal binding of built-in syntax:") <+> ppr (rdrNameOcc name) -- The rdrNameOcc is because we don't want to print Prelude.(,) -dupNamesErr descriptor ((name,loc) : dup_things) - = addSrcLoc loc $ +dupNamesErr descriptor (L loc name : dup_things) + = addSrcSpan loc $ addErr ((ptext SLIT("Conflicting definitions for") <+> quotes (ppr name)) $$ descriptor) diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index de7319da3d..fb32abeead 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -11,27 +11,27 @@ free variables. \begin{code} module RnExpr ( - rnMatch, rnGRHSs, rnExpr, rnStmts, + rnMatch, rnGRHSs, rnLExpr, rnExpr, rnStmts, checkPrecMatch ) where #include "HsVersions.h" -import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindsAndThen, rnBinds ) +import {-# SOURCE #-} RnSource ( rnSrcDecls, rnBindGroupsAndThen, rnBindGroups ) -- RnSource imports RnBinds.rnTopMonoBinds, RnExpr.rnExpr -- RnBinds imports RnExpr.rnMatch, etc -- RnExpr imports [boot] RnSource.rnSrcDecls, RnSource.rnBinds import HsSyn -import RdrHsSyn import RnHsSyn import TcRnMonad import RnEnv import OccName ( plusOccEnv ) import RnNames ( importsFromLocalDecls ) -import RnTypes ( rnHsTypeFVs, rnPat, litFVs, rnOverLit, rnPatsAndThen, - dupFieldErr, precParseErr, sectionPrecErr, patSigErr, checkTupSize ) +import RnTypes ( rnHsTypeFVs, rnLPat, litFVs, rnOverLit, rnPatsAndThen, + dupFieldErr, precParseErr, sectionPrecErr, patSigErr, + checkTupSize ) import CmdLineOpts ( DynFlag(..) ) import BasicTypes ( Fixity(..), FixityDirection(..), negateFixity, compareFixity ) import PrelNames ( hasKey, assertIdKey, assertErrorName, @@ -39,15 +39,17 @@ import PrelNames ( hasKey, assertIdKey, assertErrorName, negateName, monadNames, mfixName ) import Name ( Name, nameOccName ) import NameSet +import RdrName ( RdrName ) import UnicodeUtil ( stringToUtf8 ) import UniqFM ( isNullUFM ) import UniqSet ( emptyUniqSet ) import Util ( isSingleton ) -import List ( unzip4 ) import ListSetOps ( removeDups ) import Outputable -import SrcLoc ( noSrcLoc ) +import SrcLoc ( Located(..), unLoc, getLoc, combineLocs, cmpLocated ) import FastString + +import List ( unzip4 ) \end{code} @@ -58,11 +60,11 @@ import FastString ************************************************************************ \begin{code} -rnMatch :: HsMatchContext Name -> RdrNameMatch -> RnM (RenamedMatch, FreeVars) - -rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) - = addSrcLoc (getMatchLoc match) $ +rnMatch :: HsMatchContext Name -> LMatch RdrName -> RnM (LMatch Name, FreeVars) +rnMatch ctxt = wrapLocFstM (rnMatch' ctxt) +rnMatch' ctxt match@(Match pats maybe_rhs_sig grhss) + = -- Deal with the rhs type signature bindPatSigTyVarsFV rhs_sig_tys $ doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> @@ -70,7 +72,7 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) Nothing -> returnM (Nothing, emptyFVs) Just ty | opt_GlasgowExts -> rnHsTypeFVs doc_sig ty `thenM` \ (ty', ty_fvs) -> returnM (Just ty', ty_fvs) - | otherwise -> addErr (patSigErr ty) `thenM_` + | otherwise -> addLocErr ty patSigErr `thenM_` returnM (Nothing, emptyFVs) ) `thenM` \ (maybe_rhs_sig', ty_fvs) -> @@ -95,28 +97,30 @@ rnMatch ctxt match@(Match pats maybe_rhs_sig grhss) %************************************************************************ \begin{code} -rnGRHSs :: HsMatchContext Name -> RdrNameGRHSs -> RnM (RenamedGRHSs, FreeVars) +rnGRHSs :: HsMatchContext Name -> GRHSs RdrName -> RnM (GRHSs Name, FreeVars) rnGRHSs ctxt (GRHSs grhss binds _) - = rnBindsAndThen binds $ \ binds' -> + = rnBindGroupsAndThen binds $ \ binds' -> mapFvRn (rnGRHS ctxt) grhss `thenM` \ (grhss', fvGRHSs) -> returnM (GRHSs grhss' binds' placeHolderType, fvGRHSs) -rnGRHS ctxt (GRHS guarded locn) - = addSrcLoc locn $ - doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> +rnGRHS :: HsMatchContext Name -> LGRHS RdrName -> RnM (LGRHS Name, FreeVars) +rnGRHS ctxt = wrapLocFstM (rnGRHS' ctxt) + +rnGRHS' ctxt (GRHS guarded) + = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> checkM (opt_GlasgowExts || is_standard_guard guarded) (addWarn (nonStdGuardErr guarded)) `thenM_` rnStmts (PatGuard ctxt) guarded `thenM` \ (guarded', fvs) -> - returnM (GRHS guarded' locn, fvs) + returnM (GRHS guarded', fvs) where -- Standard Haskell 1.4 guards are just a single boolean -- expression, rather than a list of qualifiers as in the -- Glasgow extension - is_standard_guard [ResultStmt _ _] = True - is_standard_guard [ExprStmt _ _ _, ResultStmt _ _] = True - is_standard_guard other = False + is_standard_guard [L _ (ResultStmt _)] = True + is_standard_guard [L _ (ExprStmt _ _), L _ (ResultStmt _)] = True + is_standard_guard other = False \end{code} %************************************************************************ @@ -126,12 +130,12 @@ rnGRHS ctxt (GRHS guarded locn) %************************************************************************ \begin{code} -rnExprs :: [RdrNameHsExpr] -> RnM ([RenamedHsExpr], FreeVars) +rnExprs :: [LHsExpr RdrName] -> RnM ([LHsExpr Name], FreeVars) rnExprs ls = rnExprs' ls emptyUniqSet where rnExprs' [] acc = returnM ([], acc) rnExprs' (expr:exprs) acc - = rnExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> -- Now we do a "seq" on the free vars because typically it's small -- or empty, especially in very long lists of constants @@ -149,7 +153,10 @@ grubby_seqNameSet ns result | isNullUFM ns = result Variables. We look up the variable and return the resulting name. \begin{code} -rnExpr :: RdrNameHsExpr -> RnM (RenamedHsExpr, FreeVars) +rnLExpr :: LHsExpr RdrName -> RnM (LHsExpr Name, FreeVars) +rnLExpr = wrapLocFstM rnExpr + +rnExpr :: HsExpr RdrName -> RnM (HsExpr Name, FreeVars) rnExpr (HsVar v) = lookupOccRn v `thenM` \ name -> @@ -182,14 +189,14 @@ rnExpr (HsLam match) returnM (HsLam match', fvMatch) rnExpr (HsApp fun arg) - = rnExpr fun `thenM` \ (fun',fvFun) -> - rnExpr arg `thenM` \ (arg',fvArg) -> + = rnLExpr fun `thenM` \ (fun',fvFun) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> returnM (HsApp fun' arg', fvFun `plusFV` fvArg) rnExpr (OpApp e1 op _ e2) - = rnExpr e1 `thenM` \ (e1', fv_e1) -> - rnExpr e2 `thenM` \ (e2', fv_e2) -> - rnExpr op `thenM` \ (op'@(HsVar op_name), fv_op) -> + = rnLExpr e1 `thenM` \ (e1', fv_e1) -> + rnLExpr e2 `thenM` \ (e2', fv_e2) -> + rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)), fv_op) -> -- Deal with fixity -- When renaming code synthesised from "deriving" declarations @@ -203,77 +210,73 @@ rnExpr (OpApp e1 op _ e2) fv_e1 `plusFV` fv_op `plusFV` fv_e2) rnExpr (NegApp e _) - = rnExpr e `thenM` \ (e', fv_e) -> + = rnLExpr e `thenM` \ (e', fv_e) -> lookupSyntaxName negateName `thenM` \ (neg_name, fv_neg) -> mkNegAppRn e' neg_name `thenM` \ final_e -> returnM (final_e, fv_e `plusFV` fv_neg) rnExpr (HsPar e) - = rnExpr e `thenM` \ (e', fvs_e) -> + = rnLExpr e `thenM` \ (e', fvs_e) -> returnM (HsPar e', fvs_e) -- Template Haskell extensions -- Don't ifdef-GHCI them because we want to fail gracefully -- (not with an rnExpr crash) in a stage-1 compiler. -rnExpr e@(HsBracket br_body loc) - = addSrcLoc loc $ - checkTH e "bracket" `thenM_` +rnExpr e@(HsBracket br_body) + = checkTH e "bracket" `thenM_` rnBracket br_body `thenM` \ (body', fvs_e) -> - returnM (HsBracket body' loc, fvs_e) + returnM (HsBracket body', fvs_e) -rnExpr e@(HsSplice n splice loc) - = addSrcLoc loc $ - checkTH e "splice" `thenM_` - newLocalsRn [(n,loc)] `thenM` \ [n'] -> - rnExpr splice `thenM` \ (splice', fvs_e) -> - returnM (HsSplice n' splice' loc, fvs_e) +rnExpr e@(HsSplice n splice) + = checkTH e "splice" `thenM_` + getSrcSpanM `thenM` \ loc -> + newLocalsRn [L loc n] `thenM` \ [n'] -> + rnLExpr splice `thenM` \ (splice', fvs_e) -> + returnM (HsSplice n' splice', fvs_e) rnExpr section@(SectionL expr op) - = rnExpr expr `thenM` \ (expr', fvs_expr) -> - rnExpr op `thenM` \ (op', fvs_op) -> + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> + rnLExpr op `thenM` \ (op', fvs_op) -> checkSectionPrec InfixL section op' expr' `thenM_` returnM (SectionL expr' op', fvs_op `plusFV` fvs_expr) rnExpr section@(SectionR op expr) - = rnExpr op `thenM` \ (op', fvs_op) -> - rnExpr expr `thenM` \ (expr', fvs_expr) -> + = rnLExpr op `thenM` \ (op', fvs_op) -> + rnLExpr expr `thenM` \ (expr', fvs_expr) -> checkSectionPrec InfixR section op' expr' `thenM_` returnM (SectionR op' expr', fvs_op `plusFV` fvs_expr) rnExpr (HsCoreAnn ann expr) - = rnExpr expr `thenM` \ (expr', fvs_expr) -> + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsCoreAnn ann expr', fvs_expr) rnExpr (HsSCC lbl expr) - = rnExpr expr `thenM` \ (expr', fvs_expr) -> + = rnLExpr expr `thenM` \ (expr', fvs_expr) -> returnM (HsSCC lbl expr', fvs_expr) -rnExpr (HsCase expr ms src_loc) - = addSrcLoc src_loc $ - rnExpr expr `thenM` \ (new_expr, e_fvs) -> +rnExpr (HsCase expr ms) + = rnLExpr expr `thenM` \ (new_expr, e_fvs) -> mapFvRn (rnMatch CaseAlt) ms `thenM` \ (new_ms, ms_fvs) -> - returnM (HsCase new_expr new_ms src_loc, e_fvs `plusFV` ms_fvs) + returnM (HsCase new_expr new_ms, e_fvs `plusFV` ms_fvs) rnExpr (HsLet binds expr) - = rnBindsAndThen binds $ \ binds' -> - rnExpr expr `thenM` \ (expr',fvExpr) -> + = rnBindGroupsAndThen binds $ \ binds' -> + rnLExpr expr `thenM` \ (expr',fvExpr) -> returnM (HsLet binds' expr', fvExpr) -rnExpr e@(HsDo do_or_lc stmts _ _ src_loc) - = addSrcLoc src_loc $ - rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) -> +rnExpr e@(HsDo do_or_lc stmts _ _) + = rnStmts do_or_lc stmts `thenM` \ (stmts', fvs) -> -- Check the statement list ends in an expression case last stmts' of { - ResultStmt _ _ -> returnM () ; - _ -> addErr (doStmtListErr do_or_lc e) + L _ (ResultStmt _) -> returnM () ; + other -> addLocErr other (doStmtListErr do_or_lc) } `thenM_` -- Generate the rebindable syntax for the monad lookupSyntaxNames syntax_names `thenM` \ (syntax_names', monad_fvs) -> - returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType src_loc, - fvs `plusFV` monad_fvs) + returnM (HsDo do_or_lc stmts' syntax_names' placeHolderType, fvs `plusFV` monad_fvs) where syntax_names = case do_or_lc of DoExpr -> monadNames @@ -297,28 +300,27 @@ rnExpr e@(ExplicitTuple exps boxity) tycon_name = tupleTyCon_name boxity tup_size rnExpr (RecordCon con_id rbinds) - = lookupOccRn con_id `thenM` \ conname -> + = lookupLocatedOccRn con_id `thenM` \ conname -> rnRbinds "construction" rbinds `thenM` \ (rbinds', fvRbinds) -> - returnM (RecordCon conname rbinds', fvRbinds `addOneFV` conname) + returnM (RecordCon conname rbinds', fvRbinds `addOneFV` unLoc conname) rnExpr (RecordUpd expr rbinds) - = rnExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> rnRbinds "update" rbinds `thenM` \ (rbinds', fvRbinds) -> returnM (RecordUpd expr' rbinds', fvExpr `plusFV` fvRbinds) rnExpr (ExprWithTySig expr pty) - = rnExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> rnHsTypeFVs doc pty `thenM` \ (pty', fvTy) -> returnM (ExprWithTySig expr' pty', fvExpr `plusFV` fvTy) where doc = text "In an expression type signature" -rnExpr (HsIf p b1 b2 src_loc) - = addSrcLoc src_loc $ - rnExpr p `thenM` \ (p', fvP) -> - rnExpr b1 `thenM` \ (b1', fvB1) -> - rnExpr b2 `thenM` \ (b2', fvB2) -> - returnM (HsIf p' b1' b2' src_loc, plusFVs [fvP, fvB1, fvB2]) +rnExpr (HsIf p b1 b2) + = rnLExpr p `thenM` \ (p', fvP) -> + rnLExpr b1 `thenM` \ (b1', fvB1) -> + rnLExpr b2 `thenM` \ (b2', fvB2) -> + returnM (HsIf p' b1' b2', plusFVs [fvP, fvB1, fvB2]) rnExpr (HsType a) = rnHsTypeFVs doc a `thenM` \ (t, fvT) -> @@ -357,21 +359,20 @@ rnExpr e@(ELazyPat _) = addErr (patSynErr e) `thenM_` %************************************************************************ \begin{code} -rnExpr (HsProc pat body src_loc) - = addSrcLoc src_loc $ - rnPatsAndThen ProcExpr True [pat] $ \ [pat'] -> +rnExpr (HsProc pat body) + = rnPatsAndThen ProcExpr True [pat] $ \ [pat'] -> rnCmdTop body `thenM` \ (body',fvBody) -> - returnM (HsProc pat' body' src_loc, fvBody) + returnM (HsProc pat' body', fvBody) -rnExpr (HsArrApp arrow arg _ ho rtl srcloc) - = rnExpr arrow `thenM` \ (arrow',fvArrow) -> - rnExpr arg `thenM` \ (arg',fvArg) -> - returnM (HsArrApp arrow' arg' placeHolderType ho rtl srcloc, +rnExpr (HsArrApp arrow arg _ ho rtl) + = rnLExpr arrow `thenM` \ (arrow',fvArrow) -> + rnLExpr arg `thenM` \ (arg',fvArg) -> + returnM (HsArrApp arrow' arg' placeHolderType ho rtl, fvArrow `plusFV` fvArg) -- infix form -rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc) - = rnExpr op `thenM` \ (op'@(HsVar op_name),fv_op) -> +rnExpr (HsArrForm op (Just _) [arg1, arg2]) + = rnLExpr op `thenM` \ (op'@(L _ (HsVar op_name)),fv_op) -> rnCmdTop arg1 `thenM` \ (arg1',fv_arg1) -> rnCmdTop arg2 `thenM` \ (arg2',fv_arg2) -> @@ -383,38 +384,39 @@ rnExpr (HsArrForm op (Just _) [arg1, arg2] srcloc) returnM (final_e, fv_arg1 `plusFV` fv_op `plusFV` fv_arg2) -rnExpr (HsArrForm op fixity cmds srcloc) - = rnExpr op `thenM` \ (op',fvOp) -> +rnExpr (HsArrForm op fixity cmds) + = rnLExpr op `thenM` \ (op',fvOp) -> rnCmdArgs cmds `thenM` \ (cmds',fvCmds) -> - returnM (HsArrForm op' fixity cmds' srcloc, - fvOp `plusFV` fvCmds) + returnM (HsArrForm op' fixity cmds', fvOp `plusFV` fvCmds) --------------------------- -- Deal with fixity (cf mkOpAppRn for the method) -mkOpFormRn :: RenamedHsCmdTop -- Left operand; already rearranged - -> RenamedHsExpr -> Fixity -- Operator and fixity - -> RenamedHsCmdTop -- Right operand (not an infix) - -> RnM RenamedHsCmd +mkOpFormRn :: LHsCmdTop Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsCmdTop Name -- Right operand (not an infix) + -> RnM (HsCmd Name) --------------------------- -- (e11 `op1` e12) `op2` e2 -mkOpFormRn a1@(HsCmdTop (HsArrForm op1 (Just fix1) [a11,a12] loc1) _ _ _) op2 fix2 a2 +mkOpFormRn a1@(L loc (HsCmdTop (L _ (HsArrForm op1 (Just fix1) [a11,a12])) _ _ _)) + op2 fix2 a2 | nofix_error = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` - returnM (HsArrForm op2 (Just fix2) [a1, a2] loc1) + returnM (HsArrForm op2 (Just fix2) [a1, a2]) | associate_right = mkOpFormRn a12 op2 fix2 a2 `thenM` \ new_c -> returnM (HsArrForm op1 (Just fix1) - [a11, HsCmdTop new_c [] placeHolderType []] loc1) + [a11, L loc (HsCmdTop (L loc new_c) [] placeHolderType [])]) + -- TODO: locs are wrong where (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- Default case mkOpFormRn arg1 op fix arg2 -- Default case, no rearrangment - = returnM (HsArrForm op (Just fix) [arg1, arg2] noSrcLoc) + = returnM (HsArrForm op (Just fix) [arg1, arg2]) \end{code} @@ -432,102 +434,113 @@ rnCmdArgs (arg:args) rnCmdArgs args `thenM` \ (args',fvArgs) -> returnM (arg':args', fvArg `plusFV` fvArgs) -rnCmdTop (HsCmdTop cmd _ _ _) - = rnExpr (convertOpFormsCmd cmd) `thenM` \ (cmd', fvCmd) -> - let + +rnCmdTop = wrapLocFstM rnCmdTop' + where + rnCmdTop' (HsCmdTop cmd _ _ _) + = rnLExpr (convertOpFormsLCmd cmd) `thenM` \ (cmd', fvCmd) -> + let cmd_names = [arrAName, composeAName, firstAName] ++ - nameSetToList (methodNamesCmd cmd') - in + nameSetToList (methodNamesCmd (unLoc cmd')) + in -- Generate the rebindable syntax for the monad - lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) -> + lookupSyntaxNames cmd_names `thenM` \ (cmd_names', cmd_fvs) -> - returnM (HsCmdTop cmd' [] placeHolderType cmd_names', + returnM (HsCmdTop cmd' [] placeHolderType cmd_names', fvCmd `plusFV` cmd_fvs) --------------------------------------------------- -- convert OpApp's in a command context to HsArrForm's +convertOpFormsLCmd :: LHsCmd id -> LHsCmd id +convertOpFormsLCmd = fmap convertOpFormsCmd + convertOpFormsCmd :: HsCmd id -> HsCmd id -convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsCmd c) e +convertOpFormsCmd (HsApp c e) = HsApp (convertOpFormsLCmd c) e convertOpFormsCmd (HsLam match) = HsLam (convertOpFormsMatch match) convertOpFormsCmd (OpApp c1 op fixity c2) = let - arg1 = HsCmdTop (convertOpFormsCmd c1) [] placeHolderType [] - arg2 = HsCmdTop (convertOpFormsCmd c2) [] placeHolderType [] + arg1 = L (getLoc c1) $ HsCmdTop (convertOpFormsLCmd c1) [] placeHolderType [] + arg2 = L (getLoc c2) $ HsCmdTop (convertOpFormsLCmd c2) [] placeHolderType [] in - HsArrForm op (Just fixity) [arg1, arg2] noSrcLoc + HsArrForm op (Just fixity) [arg1, arg2] -convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsCmd c) +convertOpFormsCmd (HsPar c) = HsPar (convertOpFormsLCmd c) -convertOpFormsCmd (HsCase exp matches locn) - = HsCase exp (map convertOpFormsMatch matches) locn +convertOpFormsCmd (HsCase exp matches) + = HsCase exp (map convertOpFormsMatch matches) -convertOpFormsCmd (HsIf exp c1 c2 locn) - = HsIf exp (convertOpFormsCmd c1) (convertOpFormsCmd c2) locn +convertOpFormsCmd (HsIf exp c1 c2) + = HsIf exp (convertOpFormsLCmd c1) (convertOpFormsLCmd c2) convertOpFormsCmd (HsLet binds cmd) - = HsLet binds (convertOpFormsCmd cmd) + = HsLet binds (convertOpFormsLCmd cmd) -convertOpFormsCmd (HsDo ctxt stmts ids ty locn) - = HsDo ctxt (map convertOpFormsStmt stmts) ids ty locn +convertOpFormsCmd (HsDo ctxt stmts ids ty) + = HsDo ctxt (map (fmap convertOpFormsStmt) stmts) ids ty -- Anything else is unchanged. This includes HsArrForm (already done), -- things with no sub-commands, and illegal commands (which will be -- caught by the type checker) convertOpFormsCmd c = c -convertOpFormsStmt (BindStmt pat cmd locn) - = BindStmt pat (convertOpFormsCmd cmd) locn -convertOpFormsStmt (ResultStmt cmd locn) - = ResultStmt (convertOpFormsCmd cmd) locn -convertOpFormsStmt (ExprStmt cmd ty locn) - = ExprStmt (convertOpFormsCmd cmd) ty locn +convertOpFormsStmt (BindStmt pat cmd) + = BindStmt pat (convertOpFormsLCmd cmd) +convertOpFormsStmt (ResultStmt cmd) + = ResultStmt (convertOpFormsLCmd cmd) +convertOpFormsStmt (ExprStmt cmd ty) + = ExprStmt (convertOpFormsLCmd cmd) ty convertOpFormsStmt (RecStmt stmts lvs rvs es) - = RecStmt (map convertOpFormsStmt stmts) lvs rvs es + = RecStmt (map (fmap convertOpFormsStmt) stmts) lvs rvs es convertOpFormsStmt stmt = stmt -convertOpFormsMatch (Match pat mty grhss) - = Match pat mty (convertOpFormsGRHSs grhss) +convertOpFormsMatch = fmap convert + where convert (Match pat mty grhss) + = Match pat mty (convertOpFormsGRHSs grhss) convertOpFormsGRHSs (GRHSs grhss binds ty) = GRHSs (map convertOpFormsGRHS grhss) binds ty -convertOpFormsGRHS (GRHS stmts locn) - = let - (ResultStmt cmd locn') = last stmts - in - GRHS (init stmts ++ [ResultStmt (convertOpFormsCmd cmd) locn']) locn +convertOpFormsGRHS = fmap convert + where convert (GRHS stmts) + = let + (L loc (ResultStmt cmd)) = last stmts + in + GRHS (init stmts ++ [L loc (ResultStmt (convertOpFormsLCmd cmd))]) --------------------------------------------------- type CmdNeeds = FreeVars -- Only inhabitants are -- appAName, choiceAName, loopAName -- find what methods the Cmd needs (loop, choice, apply) +methodNamesLCmd :: LHsCmd Name -> CmdNeeds +methodNamesLCmd = methodNamesCmd . unLoc + methodNamesCmd :: HsCmd Name -> CmdNeeds -methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl _srcloc) +methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsFirstOrderApp _rtl) = emptyFVs -methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl _srcloc) +methodNamesCmd cmd@(HsArrApp _arrow _arg _ HsHigherOrderApp _rtl) = unitFV appAName methodNamesCmd cmd@(HsArrForm {}) = emptyFVs -methodNamesCmd (HsPar c) = methodNamesCmd c +methodNamesCmd (HsPar c) = methodNamesLCmd c -methodNamesCmd (HsIf p c1 c2 loc) - = methodNamesCmd c1 `plusFV` methodNamesCmd c2 `addOneFV` choiceAName +methodNamesCmd (HsIf p c1 c2) + = methodNamesLCmd c1 `plusFV` methodNamesLCmd c2 `addOneFV` choiceAName -methodNamesCmd (HsLet b c) = methodNamesCmd c +methodNamesCmd (HsLet b c) = methodNamesLCmd c -methodNamesCmd (HsDo sc stmts rbs ty loc) = methodNamesStmts stmts +methodNamesCmd (HsDo sc stmts rbs ty) = methodNamesStmts stmts -methodNamesCmd (HsApp c e) = methodNamesCmd c +methodNamesCmd (HsApp c e) = methodNamesLCmd c methodNamesCmd (HsLam match) = methodNamesMatch match -methodNamesCmd (HsCase scrut matches loc) +methodNamesCmd (HsCase scrut matches) = plusFVs (map methodNamesMatch matches) `addOneFV` choiceAName methodNamesCmd other = emptyFVs @@ -536,21 +549,23 @@ methodNamesCmd other = emptyFVs -- The type checker will complain later --------------------------------------------------- -methodNamesMatch (Match pats sig_ty grhss) = methodNamesGRHSs grhss +methodNamesMatch (L _ (Match pats sig_ty grhss)) = methodNamesGRHSs grhss ------------------------------------------------- methodNamesGRHSs (GRHSs grhss binds ty) = plusFVs (map methodNamesGRHS grhss) ------------------------------------------------- -methodNamesGRHS (GRHS stmts loc) = methodNamesStmt (last stmts) +methodNamesGRHS (L _ (GRHS stmts)) = methodNamesLStmt (last stmts) --------------------------------------------------- -methodNamesStmts stmts = plusFVs (map methodNamesStmt stmts) +methodNamesStmts stmts = plusFVs (map methodNamesLStmt stmts) --------------------------------------------------- -methodNamesStmt (ResultStmt cmd loc) = methodNamesCmd cmd -methodNamesStmt (ExprStmt cmd ty loc) = methodNamesCmd cmd -methodNamesStmt (BindStmt pat cmd loc) = methodNamesCmd cmd +methodNamesLStmt = methodNamesStmt . unLoc + +methodNamesStmt (ResultStmt cmd) = methodNamesLCmd cmd +methodNamesStmt (ExprStmt cmd ty) = methodNamesLCmd cmd +methodNamesStmt (BindStmt pat cmd ) = methodNamesLCmd cmd methodNamesStmt (RecStmt stmts lvs rvs es) = methodNamesStmts stmts `addOneFV` loopAName methodNamesStmt (LetStmt b) = emptyFVs @@ -568,23 +583,23 @@ methodNamesStmt (ParStmt ss) = emptyFVs \begin{code} rnArithSeq (From expr) - = rnExpr expr `thenM` \ (expr', fvExpr) -> + = rnLExpr expr `thenM` \ (expr', fvExpr) -> returnM (From expr', fvExpr) rnArithSeq (FromThen expr1 expr2) - = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> returnM (FromThen expr1' expr2', fvExpr1 `plusFV` fvExpr2) rnArithSeq (FromTo expr1 expr2) - = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> returnM (FromTo expr1' expr2', fvExpr1 `plusFV` fvExpr2) rnArithSeq (FromThenTo expr1 expr2 expr3) - = rnExpr expr1 `thenM` \ (expr1', fvExpr1) -> - rnExpr expr2 `thenM` \ (expr2', fvExpr2) -> - rnExpr expr3 `thenM` \ (expr3', fvExpr3) -> + = rnLExpr expr1 `thenM` \ (expr1', fvExpr1) -> + rnLExpr expr2 `thenM` \ (expr2', fvExpr2) -> + rnLExpr expr3 `thenM` \ (expr3', fvExpr3) -> returnM (FromThenTo expr1' expr2' expr3', plusFVs [fvExpr1, fvExpr2, fvExpr3]) \end{code} @@ -602,14 +617,14 @@ rnRbinds str rbinds mapFvRn rn_rbind rbinds `thenM` \ (rbinds', fvRbind) -> returnM (rbinds', fvRbind) where - (_, dup_fields) = removeDups compare [ f | (f,_) <- rbinds ] + (_, dup_fields) = removeDups cmpLocated [ f | (f,_) <- rbinds ] - field_dup_err dups = addErr (dupFieldErr str dups) + field_dup_err dups = mappM_ (\f -> addLocErr f (dupFieldErr str)) dups rn_rbind (field, expr) - = lookupGlobalOccRn field `thenM` \ fieldname -> - rnExpr expr `thenM` \ (expr', fvExpr) -> - returnM ((fieldname, expr'), fvExpr `addOneFV` fieldname) + = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> + rnLExpr expr `thenM` \ (expr', fvExpr) -> + returnM ((fieldname, expr'), fvExpr `addOneFV` unLoc fieldname) \end{code} %************************************************************************ @@ -621,9 +636,9 @@ rnRbinds str rbinds \begin{code} rnBracket (VarBr n) = lookupOccRn n `thenM` \ name -> returnM (VarBr name, unitFV name) -rnBracket (ExpBr e) = rnExpr e `thenM` \ (e', fvs) -> +rnBracket (ExpBr e) = rnLExpr e `thenM` \ (e', fvs) -> returnM (ExpBr e', fvs) -rnBracket (PatBr p) = rnPat p `thenM` \ (p', fvs) -> +rnBracket (PatBr p) = rnLPat p `thenM` \ (p', fvs) -> returnM (PatBr p', fvs) rnBracket (TypBr t) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> returnM (TypBr t', fvs) @@ -655,33 +670,30 @@ rnBracket (DecBr group) %************************************************************************ \begin{code} -rnStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) +rnStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars) -rnStmts MDoExpr stmts = rnMDoStmts stmts -rnStmts ctxt stmts = rnNormalStmts ctxt stmts +rnStmts MDoExpr = rnMDoStmts +rnStmts ctxt = rnNormalStmts ctxt -rnNormalStmts :: HsStmtContext Name -> [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) +rnNormalStmts :: HsStmtContext Name -> [LStmt RdrName] -> RnM ([LStmt Name], FreeVars) -- Used for cases *other* than recursive mdo -- Implements nested scopes rnNormalStmts ctxt [] = returnM ([], emptyFVs) -- Happens at the end of the sub-lists of a ParStmts -rnNormalStmts ctxt (ExprStmt expr _ src_loc : stmts) - = addSrcLoc src_loc $ - rnExpr expr `thenM` \ (expr', fv_expr) -> +rnNormalStmts ctxt (L loc (ExprStmt expr _) : stmts) + = rnLExpr expr `thenM` \ (expr', fv_expr) -> rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> - returnM (ExprStmt expr' placeHolderType src_loc : stmts', + returnM (L loc (ExprStmt expr' placeHolderType) : stmts', fv_expr `plusFV` fvs) -rnNormalStmts ctxt [ResultStmt expr src_loc] - = addSrcLoc src_loc $ - rnExpr expr `thenM` \ (expr', fv_expr) -> - returnM ([ResultStmt expr' src_loc], fv_expr) +rnNormalStmts ctxt [L loc (ResultStmt expr)] + = rnLExpr expr `thenM` \ (expr', fv_expr) -> + returnM ([L loc (ResultStmt expr')], fv_expr) -rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts) - = addSrcLoc src_loc $ - rnExpr expr `thenM` \ (expr', fv_expr) -> +rnNormalStmts ctxt (L loc (BindStmt pat expr) : stmts) + = rnLExpr expr `thenM` \ (expr', fv_expr) -> -- The binders do not scope over the expression let @@ -692,28 +704,31 @@ rnNormalStmts ctxt (BindStmt pat expr src_loc : stmts) in rnPatsAndThen (StmtCtxt ctxt) reportUnused [pat] $ \ [pat'] -> rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> - returnM (BindStmt pat' expr' src_loc : stmts', + returnM (L loc (BindStmt pat' expr') : stmts', fv_expr `plusFV` fvs) -- fv_expr shouldn't really be filtered by -- the rnPatsAndThen, but it does not matter -rnNormalStmts ctxt (LetStmt binds : stmts) +rnNormalStmts ctxt (L loc (LetStmt binds) : stmts) = checkErr (ok ctxt binds) (badIpBinds binds) `thenM_` - rnBindsAndThen binds ( \ binds' -> + rnBindGroupsAndThen binds ( \ binds' -> rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> - returnM (LetStmt binds' : stmts', fvs)) + returnM (L loc (LetStmt binds') : stmts', fvs)) where -- We do not allow implicit-parameter bindings in a parallel -- list comprehension. I'm not sure what it might mean. - ok (ParStmtCtxt _) (IPBinds _) = False - ok _ _ = True + ok (ParStmtCtxt _) binds = not (any is_ip_bind binds) + ok _ _ = True + + is_ip_bind (HsIPBinds _) = True + is_ip_bind _ = False -rnNormalStmts ctxt (ParStmt stmtss : stmts) +rnNormalStmts ctxt (L loc (ParStmt stmtss) : stmts) = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> checkM opt_GlasgowExts parStmtErr `thenM_` mapFvRn rn_branch stmtss `thenM` \ (stmtss', fv_stmtss) -> let bndrss :: [[Name]] -- NB: Name, not RdrName - bndrss = map collectStmtsBinders stmtss' + bndrss = map (map unLoc . collectStmtsBinders) stmtss' (bndrs, dups) = removeDups cmpByOcc (concat bndrss) in mappM dupErr dups `thenM` \ _ -> @@ -730,7 +745,7 @@ rnNormalStmts ctxt (ParStmt stmtss : stmts) -- With processing of the branches and the tail of comprehension done, -- we can finally compute&report any unused ParStmt binders. warnUnusedMatches unused_bndrs `thenM_` - returnM (ParStmt (stmtss' `zip` used_bndrs_s) : stmts', + returnM (L loc (ParStmt (stmtss' `zip` used_bndrs_s)) : stmts', fv_stmtss `plusFV` fvs) where rn_branch (stmts, _) = rnNormalStmts (ParStmtCtxt ctxt) stmts @@ -739,8 +754,8 @@ rnNormalStmts ctxt (ParStmt stmtss : stmts) dupErr (v:_) = addErr (ptext SLIT("Duplicate binding in parallel list comprehension for:") <+> quotes (ppr v)) -rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts) - = bindLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ -> +rnNormalStmts ctxt (L loc (RecStmt rec_stmts _ _ _) : stmts) + = bindLocatedLocalsRn doc (collectStmtsBinders rec_stmts) $ \ _ -> rn_rec_stmts rec_stmts `thenM` \ segs -> rnNormalStmts ctxt stmts `thenM` \ (stmts', fvs) -> let @@ -750,7 +765,8 @@ rnNormalStmts ctxt (RecStmt rec_stmts _ _ _ : stmts) fwd_vars = nameSetToList (plusFVs fs) uses = plusFVs us in - returnM (RecStmt rec_stmts' later_vars fwd_vars [] : stmts', uses `plusFV` fvs) + returnM (L loc (RecStmt rec_stmts' later_vars fwd_vars []) : stmts', + uses `plusFV` fvs) where doc = text "In a recursive do statement" \end{code} @@ -773,12 +789,12 @@ type Segment stmts = (Defs, ---------------------------------------------------- -rnMDoStmts :: [RdrNameStmt] -> RnM ([RenamedStmt], FreeVars) +rnMDoStmts :: [LStmt RdrName] -> RnM ([LStmt Name], FreeVars) rnMDoStmts stmts = -- Step1: bring all the binders of the mdo into scope -- Remember that this also removes the binders from the -- finally-returned free-vars - bindLocalsRn doc (collectStmtsBinders stmts) $ \ _ -> + bindLocatedLocalsRn doc (collectStmtsBinders stmts) $ \ _ -> -- Step 2: Rename each individual stmt, making a -- singleton segment. At this stage the FwdRefs field @@ -812,45 +828,44 @@ rnMDoStmts stmts ---------------------------------------------------- -rn_rec_stmt :: RdrNameStmt -> RnM [Segment RenamedStmt] +rn_rec_stmt :: LStmt RdrName -> RnM [Segment (LStmt Name)] -- Rename a Stmt that is inside a RecStmt (or mdo) -- Assumes all binders are already in scope -- Turns each stmt into a singleton Stmt -rn_rec_stmt (ExprStmt expr _ src_loc) - = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) -> +rn_rec_stmt (L loc (ExprStmt expr _)) + = rnLExpr expr `thenM` \ (expr', fvs) -> returnM [(emptyNameSet, fvs, emptyNameSet, - ExprStmt expr' placeHolderType src_loc)] + L loc (ExprStmt expr' placeHolderType))] -rn_rec_stmt (ResultStmt expr src_loc) - = addSrcLoc src_loc (rnExpr expr) `thenM` \ (expr', fvs) -> +rn_rec_stmt (L loc (ResultStmt expr)) + = rnLExpr expr `thenM` \ (expr', fvs) -> returnM [(emptyNameSet, fvs, emptyNameSet, - ResultStmt expr' src_loc)] + L loc (ResultStmt expr'))] -rn_rec_stmt (BindStmt pat expr src_loc) - = addSrcLoc src_loc $ - rnExpr expr `thenM` \ (expr', fv_expr) -> - rnPat pat `thenM` \ (pat', fv_pat) -> +rn_rec_stmt (L loc (BindStmt pat expr)) + = rnLExpr expr `thenM` \ (expr', fv_expr) -> + rnLPat pat `thenM` \ (pat', fv_pat) -> let bndrs = mkNameSet (collectPatBinders pat') fvs = fv_expr `plusFV` fv_pat in returnM [(bndrs, fvs, bndrs `intersectNameSet` fvs, - BindStmt pat' expr' src_loc)] + L loc (BindStmt pat' expr'))] -rn_rec_stmt (LetStmt binds) - = rnBinds binds `thenM` \ (binds', du_binds) -> +rn_rec_stmt (L loc (LetStmt binds)) + = rnBindGroups binds `thenM` \ (binds', du_binds) -> returnM [(duDefs du_binds, duUses du_binds, - emptyNameSet, LetStmt binds')] + emptyNameSet, L loc (LetStmt binds'))] -rn_rec_stmt (RecStmt stmts _ _ _) -- Flatten Rec inside Rec +rn_rec_stmt (L loc (RecStmt stmts _ _ _)) -- Flatten Rec inside Rec = rn_rec_stmts stmts -rn_rec_stmt stmt@(ParStmt _) -- Syntactically illegal in mdo +rn_rec_stmt stmt@(L _ (ParStmt _)) -- Syntactically illegal in mdo = pprPanic "rn_rec_stmt" (ppr stmt) --------------------------------------------- -rn_rec_stmts :: [RdrNameStmt] -> RnM [Segment RenamedStmt] +rn_rec_stmts :: [LStmt RdrName] -> RnM [Segment (LStmt Name)] rn_rec_stmts stmts = mappM rn_rec_stmt stmts `thenM` \ segs_s -> returnM (concat segs_s) @@ -907,7 +922,7 @@ addFwdRefs pairs -- q <- x ; z <- y } ; -- r <- x } -glomSegments :: [Segment RenamedStmt] -> [Segment [RenamedStmt]] +glomSegments :: [Segment (LStmt Name)] -> [Segment [LStmt Name]] glomSegments [] = [] glomSegments ((defs,uses,fwds,stmt) : segs) @@ -936,7 +951,7 @@ glomSegments ((defs,uses,fwds,stmt) : segs) ---------------------------------------------------- -segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars) +segsToStmts :: [Segment [LStmt Name]] -> ([LStmt Name], FreeVars) segsToStmts [] = ([], emptyFVs) segsToStmts ((defs, uses, fwds, ss) : segs) @@ -944,7 +959,8 @@ segsToStmts ((defs, uses, fwds, ss) : segs) where (later_stmts, later_uses) = segsToStmts segs new_stmt | non_rec = head ss - | otherwise = RecStmt ss (nameSetToList used_later) (nameSetToList fwds) [] + | otherwise = L (getLoc (head ss)) $ + RecStmt ss (nameSetToList used_later) (nameSetToList fwds) [] where non_rec = isSingleton ss && isEmptyNameSet fwds used_later = defs `intersectNameSet` later_uses @@ -968,41 +984,43 @@ operator appications left-associatively, EXCEPT negation, which we need to handle specially. \begin{code} -mkOpAppRn :: RenamedHsExpr -- Left operand; already rearranged - -> RenamedHsExpr -> Fixity -- Operator and fixity - -> RenamedHsExpr -- Right operand (not an OpApp, but might +mkOpAppRn :: LHsExpr Name -- Left operand; already rearranged + -> LHsExpr Name -> Fixity -- Operator and fixity + -> LHsExpr Name -- Right operand (not an OpApp, but might -- be a NegApp) - -> RnM RenamedHsExpr + -> RnM (HsExpr Name) --------------------------- -- (e11 `op1` e12) `op2` e2 -mkOpAppRn e1@(OpApp e11 op1 fix1 e12) op2 fix2 e2 +mkOpAppRn e1@(L _ (OpApp e11 op1 fix1 e12)) op2 fix2 e2 | nofix_error = addErr (precParseErr (ppr_op op1,fix1) (ppr_op op2,fix2)) `thenM_` returnM (OpApp e1 op2 fix2 e2) | associate_right = mkOpAppRn e12 op2 fix2 e2 `thenM` \ new_e -> - returnM (OpApp e11 op1 fix1 new_e) + returnM (OpApp e11 op1 fix1 (L loc' new_e)) where + loc'= combineLocs e12 e2 (nofix_error, associate_right) = compareFixity fix1 fix2 --------------------------- -- (- neg_arg) `op` e2 -mkOpAppRn e1@(NegApp neg_arg neg_name) op2 fix2 e2 +mkOpAppRn e1@(L _ (NegApp neg_arg neg_name)) op2 fix2 e2 | nofix_error = addErr (precParseErr (pp_prefix_minus,negateFixity) (ppr_op op2,fix2)) `thenM_` returnM (OpApp e1 op2 fix2 e2) | associate_right = mkOpAppRn neg_arg op2 fix2 e2 `thenM` \ new_e -> - returnM (NegApp new_e neg_name) + returnM (NegApp (L loc' new_e) neg_name) where + loc' = combineLocs neg_arg e2 (nofix_error, associate_right) = compareFixity negateFixity fix2 --------------------------- -- e1 `op` - neg_arg -mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right +mkOpAppRn e1 op1 fix1 e2@(L _ (NegApp neg_arg _)) -- NegApp can occur on the right | not associate_right -- We *want* right association = addErr (precParseErr (ppr_op op1, fix1) (pp_prefix_minus, negateFixity)) `thenM_` returnM (OpApp e1 op1 fix1 e2) @@ -1012,7 +1030,7 @@ mkOpAppRn e1 op1 fix1 e2@(NegApp neg_arg _) -- NegApp can occur on the right --------------------------- -- Default case mkOpAppRn e1 op fix e2 -- Default case, no rearrangment - = ASSERT2( right_op_ok fix e2, + = ASSERT2( right_op_ok fix (unLoc e2), ppr e1 $$ text "---" $$ ppr op $$ text "---" $$ ppr fix $$ text "---" $$ ppr e2 ) returnM (OpApp e1 op fix e2) @@ -1029,8 +1047,9 @@ right_op_ok fix1 other -- Parser initially makes negation bind more tightly than any other operator -- And "deriving" code should respect this (use HsPar if not) +mkNegAppRn :: LHsExpr id -> SyntaxName -> RnM (HsExpr id) mkNegAppRn neg_arg neg_name - = ASSERT( not_op_app neg_arg ) + = ASSERT( not_op_app (unLoc neg_arg) ) returnM (NegApp neg_arg neg_name) not_op_app (OpApp _ _ _ _) = False @@ -1038,22 +1057,22 @@ not_op_app other = True \end{code} \begin{code} -checkPrecMatch :: Bool -> Name -> RenamedMatch -> RnM () +checkPrecMatch :: Bool -> Name -> LMatch Name -> RnM () checkPrecMatch False fn match = returnM () -checkPrecMatch True op (Match (p1:p2:_) _ _) +checkPrecMatch True op (L _ (Match (p1:p2:_) _ _)) -- True indicates an infix lhs = -- See comments with rnExpr (OpApp ...) about "deriving" - checkPrec op p1 False `thenM_` - checkPrec op p2 True + checkPrec op (unLoc p1) False `thenM_` + checkPrec op (unLoc p2) True checkPrecMatch True op _ = panic "checkPrecMatch" checkPrec op (ConPatIn op1 (InfixCon _ _)) right - = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> - lookupFixityRn op1 `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> + = lookupFixityRn op `thenM` \ op_fix@(Fixity op_prec op_dir) -> + lookupFixityRn (unLoc op1) `thenM` \ op1_fix@(Fixity op1_prec op1_dir) -> let inf_ok = op1_prec > op_prec || (op1_prec == op_prec && @@ -1073,13 +1092,15 @@ checkPrec op pat right -- If arg is itself an operator application, then either -- (a) its precedence must be higher than that of op -- (b) its precedency & associativity must be the same as that of op +checkSectionPrec :: FixityDirection -> HsExpr RdrName + -> LHsExpr Name -> LHsExpr Name -> RnM () checkSectionPrec direction section op arg - = case arg of + = case unLoc arg of OpApp _ op fix _ -> go_for_it (ppr_op op) fix NegApp _ _ -> go_for_it pp_prefix_minus negateFixity other -> returnM () where - HsVar op_name = op + L _ (HsVar op_name) = op go_for_it pp_arg_op arg_fix@(Fixity arg_prec assoc) = lookupFixityRn op_name `thenM` \ op_fix@(Fixity op_prec _) -> checkErr (op_prec < arg_prec @@ -1096,12 +1117,12 @@ checkSectionPrec direction section op arg %************************************************************************ \begin{code} -mkAssertErrorExpr :: RnM (RenamedHsExpr, FreeVars) +mkAssertErrorExpr :: RnM (HsExpr Name, FreeVars) -- Return an expression for (assertError "Foo.hs:27") mkAssertErrorExpr - = getSrcLocM `thenM` \ sloc -> + = getSrcSpanM `thenM` \ sloc -> let - expr = HsApp (HsVar assertErrorName) (HsLit msg) + expr = HsApp (L sloc (HsVar assertErrorName)) (L sloc (HsLit msg)) msg = HsStringPrim (mkFastString (stringToUtf8 (showSDoc (ppr sloc)))) in returnM (expr, emptyFVs) diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index c26edbe33d..5e30960c1d 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -14,38 +14,7 @@ import TysWiredIn ( tupleTyCon, listTyCon, parrTyCon, charTyCon ) import Name ( Name, getName, isTyVarName ) import NameSet import BasicTypes ( Boxity ) -import Outputable -\end{code} - - -\begin{code} -type RenamedHsDecl = HsDecl Name -type RenamedArithSeqInfo = ArithSeqInfo Name -type RenamedClassOpSig = Sig Name -type RenamedConDecl = ConDecl Name -type RenamedContext = HsContext Name -type RenamedRuleDecl = RuleDecl Name -type RenamedTyClDecl = TyClDecl Name -type RenamedDefaultDecl = DefaultDecl Name -type RenamedForeignDecl = ForeignDecl Name -type RenamedGRHS = GRHS Name -type RenamedGRHSs = GRHSs Name -type RenamedHsBinds = HsBinds Name -type RenamedHsExpr = HsExpr Name -type RenamedInstDecl = InstDecl Name -type RenamedMatchContext = HsMatchContext Name -type RenamedMatch = Match Name -type RenamedMonoBinds = MonoBinds Name -type RenamedPat = InPat Name -type RenamedHsType = HsType Name -type RenamedHsPred = HsPred Name -type RenamedRecordBinds = HsRecordBinds Name -type RenamedSig = Sig Name -type RenamedStmt = Stmt Name -type RenamedFixitySig = FixitySig Name -type RenamedDeprecation = DeprecDecl Name -type RenamedHsCmd = HsCmd Name -type RenamedHsCmdTop = HsCmdTop Name +import SrcLoc ( Located(..), unLoc ) \end{code} %************************************************************************ @@ -65,37 +34,41 @@ parrTyCon_name = getName parrTyCon tupleTyCon_name :: Boxity -> Int -> Name tupleTyCon_name boxity n = getName (tupleTyCon boxity n) -extractHsTyVars :: RenamedHsType -> NameSet +extractHsTyVars :: LHsType Name -> NameSet extractHsTyVars x = filterNameSet isTyVarName (extractHsTyNames x) extractFunDepNames :: FunDep Name -> NameSet extractFunDepNames (ns1, ns2) = mkNameSet ns1 `unionNameSets` mkNameSet ns2 -extractHsTyNames :: RenamedHsType -> NameSet +extractHsTyNames :: LHsType Name -> NameSet extractHsTyNames ty - = get ty + = getl ty where - get (HsAppTy ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` get ty - get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` get ty + getl (L _ ty) = get ty + + get (HsAppTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 + get (HsListTy ty) = unitNameSet listTyCon_name `unionNameSets` getl ty + get (HsPArrTy ty) = unitNameSet parrTyCon_name `unionNameSets` getl ty get (HsTupleTy con tys) = extractHsTyNames_s tys - get (HsFunTy ty1 ty2) = get ty1 `unionNameSets` get ty2 - get (HsPredTy p) = extractHsPredTyNames p - get (HsOpTy ty1 op ty2) = get ty1 `unionNameSets` get ty2 `unionNameSets` unitNameSet op - get (HsParTy ty) = get ty + get (HsFunTy ty1 ty2) = getl ty1 `unionNameSets` getl ty2 + get (HsPredTy p) = extractHsPredTyNames (unLoc p) + get (HsOpTy ty1 op ty2) = getl ty1 `unionNameSets` getl ty2 `unionNameSets` unitNameSet (unLoc op) + get (HsParTy ty) = getl ty get (HsNumTy n) = emptyNameSet get (HsTyVar tv) = unitNameSet tv - get (HsKindSig ty k) = get ty + get (HsKindSig ty k) = getl ty get (HsForAllTy _ tvs - ctxt ty) = (extractHsCtxtTyNames ctxt `unionNameSets` get ty) + ctxt ty) = (extractHsCtxtTyNames ctxt + `unionNameSets` getl ty) `minusNameSet` - mkNameSet (hsTyVarNames tvs) + mkNameSet (hsLTyVarNames tvs) -extractHsTyNames_s :: [RenamedHsType] -> NameSet +extractHsTyNames_s :: [LHsType Name] -> NameSet extractHsTyNames_s tys = foldr (unionNameSets . extractHsTyNames) emptyNameSet tys -extractHsCtxtTyNames :: RenamedContext -> NameSet -extractHsCtxtTyNames ctxt = foldr (unionNameSets . extractHsPredTyNames) emptyNameSet ctxt +extractHsCtxtTyNames :: LHsContext Name -> NameSet +extractHsCtxtTyNames (L _ ctxt) + = foldr (unionNameSets . extractHsPredTyNames . unLoc) emptyNameSet ctxt -- You don't import or export implicit parameters, -- so don't mention the IP names @@ -123,16 +96,17 @@ In all cases this is set up for interface-file declarations: \begin{code} ---------------- -hsSigsFVs sigs = plusFVs (map hsSigFVs sigs) +hsSigsFVs :: [LSig Name] -> FreeVars +hsSigsFVs sigs = plusFVs (map (hsSigFVs.unLoc) sigs) -hsSigFVs (Sig v ty _) = extractHsTyNames ty -hsSigFVs (SpecInstSig ty _) = extractHsTyNames ty -hsSigFVs (SpecSig v ty _) = extractHsTyNames ty +hsSigFVs (Sig v ty) = extractHsTyNames ty +hsSigFVs (SpecInstSig ty) = extractHsTyNames ty +hsSigFVs (SpecSig v ty) = extractHsTyNames ty hsSigFVs other = emptyFVs ---------------- -conDeclFVs (ConDecl _ tyvars context details _) - = delFVs (map hsTyVarName tyvars) $ +conDeclFVs (L _ (ConDecl _ tyvars context details)) + = delFVs (map hsLTyVarName tyvars) $ extractHsCtxtTyNames context `plusFV` conDetailsFVs details @@ -140,7 +114,7 @@ conDetailsFVs (PrefixCon btys) = plusFVs (map bangTyFVs btys) conDetailsFVs (InfixCon bty1 bty2) = bangTyFVs bty1 `plusFV` bangTyFVs bty2 conDetailsFVs (RecCon flds) = plusFVs [bangTyFVs bty | (_, bty) <- flds] -bangTyFVs bty = extractHsTyNames (getBangType bty) +bangTyFVs bty = extractHsTyNames (getBangType (unLoc bty)) \end{code} @@ -150,16 +124,16 @@ bangTyFVs bty = extractHsTyNames (getBangType bty) %* * %************************************************************************ -These functions on generics are defined over RenamedMatches, which is +These functions on generics are defined over Matches Name, which is why they are here and not in HsMatches. \begin{code} -maybeGenericMatch :: RenamedMatch -> Maybe (RenamedHsType, RenamedMatch) +maybeGenericMatch :: LMatch Name -> Maybe (HsType Name, LMatch Name) -- Tells whether a Match is for a generic definition -- and extract the type from a generic match and put it at the front -maybeGenericMatch (Match (TypePat ty : pats) sig_ty grhss) - = Just (ty, Match pats sig_ty grhss) +maybeGenericMatch (L loc (Match (L _ (TypePat (L _ ty)) : pats) sig_ty grhss)) + = Just (ty, L loc (Match pats sig_ty grhss)) maybeGenericMatch other_match = Nothing \end{code} diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index eb87208c41..eb3d1b07a7 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -12,11 +12,11 @@ module RnNames ( #include "HsVersions.h" import CmdLineOpts ( DynFlag(..) ) -import HsSyn ( IE(..), ieName, ImportDecl(..), +import HsSyn ( IE(..), ieName, ImportDecl(..), LImportDecl, ForeignDecl(..), HsGroup(..), - collectLocatedHsBinders, tyClDeclNames + collectGroupBinders, tyClDeclNames ) -import RdrHsSyn ( RdrNameIE, RdrNameImportDecl, main_RDR_Unqual ) +import RdrHsSyn ( main_RDR_Unqual ) import RnEnv import IfaceEnv ( lookupOrig, newGlobalBinder ) import LoadIface ( loadSrcInterface ) @@ -46,7 +46,8 @@ import RdrName ( RdrName, rdrNameOcc, setRdrNameSpace, isLocalGRE, pprNameProvenance ) import Outputable import Maybes ( isJust, isNothing, catMaybes, mapCatMaybes ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, Located(..), mkGeneralSrcSpan, srcSpanStart, + unLoc, noLoc ) import ListSetOps ( removeDups ) import Util ( sortLt, notNull ) import List ( partition, insert ) @@ -62,7 +63,7 @@ import IO ( openFile, IOMode(..) ) %************************************************************************ \begin{code} -rnImports :: [RdrNameImportDecl] +rnImports :: [LImportDecl RdrName] -> RnM (GlobalRdrEnv, ImportAvails) rnImports imports @@ -70,12 +71,11 @@ rnImports imports -- Do the non {- SOURCE -} ones first, so that we get a helpful -- warning for {- SOURCE -} ones that are unnecessary getModule `thenM` \ this_mod -> - getSrcLocM `thenM` \ loc -> doptM Opt_NoImplicitPrelude `thenM` \ opt_no_prelude -> let - all_imports = mk_prel_imports this_mod loc opt_no_prelude ++ imports + all_imports = mk_prel_imports this_mod opt_no_prelude ++ imports (source, ordinary) = partition is_source_import all_imports - is_source_import (ImportDecl _ is_boot _ _ _ _) = is_boot + is_source_import (L _ (ImportDecl _ is_boot _ _ _)) = is_boot get_imports = importsFromImportDecl this_mod in @@ -97,39 +97,43 @@ rnImports imports -- NB: opt_NoImplicitPrelude is slightly different to import Prelude (); -- because the former doesn't even look at Prelude.hi for instance -- declarations, whereas the latter does. - mk_prel_imports this_mod loc no_prelude + mk_prel_imports this_mod no_prelude | moduleName this_mod == pRELUDE_Name || explicit_prelude_import || no_prelude = [] - | otherwise = [preludeImportDecl loc] + | otherwise = [preludeImportDecl] explicit_prelude_import - = notNull [ () | (ImportDecl mod _ _ _ _ _) <- imports, - mod == pRELUDE_Name ] + = notNull [ () | L _ (ImportDecl mod _ _ _ _) <- imports, + unLoc mod == pRELUDE_Name ] -preludeImportDecl loc - = ImportDecl pRELUDE_Name +preludeImportDecl + = L loc $ + ImportDecl (L loc pRELUDE_Name) False {- Not a boot interface -} False {- Not qualified -} Nothing {- No "as" -} Nothing {- No import list -} - loc + where + loc = mkGeneralSrcSpan FSLIT("Implicit import declaration") \end{code} \begin{code} importsFromImportDecl :: Module - -> RdrNameImportDecl + -> LImportDecl RdrName -> RnM (GlobalRdrEnv, ImportAvails) importsFromImportDecl this_mod - (ImportDecl imp_mod_name want_boot qual_only as_mod imp_details iloc) - = addSrcLoc iloc $ + (L loc (ImportDecl loc_imp_mod_name want_boot qual_only as_mod imp_details)) + = + addSrcSpan loc $ -- If there's an error in loadInterface, (e.g. interface -- file not found) we get lots of spurious errors from 'filterImports' let + imp_mod_name = unLoc loc_imp_mod_name this_mod_name = moduleName this_mod doc = ppr imp_mod_name <+> ptext SLIT("is directly imported") in @@ -213,7 +217,7 @@ importsFromImportDecl this_mod -- module M ( module P ) where ... -- Then we must export whatever came from P unqualified. imp_spec = ImportSpec { is_mod = imp_mod_name, is_qual = qual_only, - is_loc = iloc , is_as = qual_mod_name } + is_loc = loc, is_as = qual_mod_name } mk_deprec = mi_dep_fn iface gres = [ GRE { gre_name = name, gre_prov = Imported [imp_spec] (name `elemNameSet` explicits), @@ -361,9 +365,8 @@ importsFromLocalDecls group %* * %********************************************************* -@getLocalDeclBinders@ returns the names for a @RdrNameHsDecl@. It's -used for both source code (from @importsFromLocalDecls@) and interface -files (@loadDecl@ calls @getTyClDeclBinders@). +@getLocalDeclBinders@ returns the names for an @HsDecl@. It's +used for source code. *** See "THE NAMING STORY" in HsDecls **** @@ -384,15 +387,15 @@ getLocalDeclBinders mod (HsGroup {hs_valds = val_decls, new_simple rdr_name = newTopSrcBinder mod Nothing rdr_name `thenM` \ name -> returnM (Avail name) - val_hs_bndrs = collectLocatedHsBinders val_decls - for_hs_bndrs = [(nm,loc) | ForeignImport nm _ _ _ loc <- foreign_decls] + val_hs_bndrs = collectGroupBinders val_decls + for_hs_bndrs = [nm | L _ (ForeignImport nm _ _ _) <- foreign_decls] new_tc tc_decl = newTopSrcBinder mod Nothing main_rdr `thenM` \ main_name -> mappM (newTopSrcBinder mod (Just main_name)) sub_rdrs `thenM` \ sub_names -> returnM (AvailTC main_name (main_name : sub_names)) where - (main_rdr : sub_rdrs) = tyClDeclNames tc_decl + (main_rdr : sub_rdrs) = tyClDeclNames (unLoc tc_decl) \end{code} @@ -408,7 +411,7 @@ available, and filters it through the import spec (if any). \begin{code} filterImports :: Module -- The module being imported -> IsBootInterface -- Tells whether it's a {-# SOURCE #-} import - -> Maybe (Bool, [RdrNameIE]) -- Import spec; True => hiding + -> Maybe (Bool, [Located (IE RdrName)]) -- Import spec; True => hiding -> [AvailInfo] -- What's available -> RnM ([AvailInfo], -- What's imported NameSet) -- What was imported explicitly @@ -419,7 +422,7 @@ filterImports mod from Nothing imports = returnM (imports, emptyNameSet) filterImports mod from (Just (want_hiding, import_items)) total_avails - = mappM get_item import_items `thenM` \ avails_w_explicits_s -> + = mappM (addLocM get_item) import_items `thenM` \ avails_w_explicits_s -> let (item_avails, explicits_s) = unzip (concat avails_w_explicits_s) explicits = foldl addListToNameSet emptyNameSet explicits_s @@ -445,7 +448,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails bale_out item = addErr (badImportItemErr mod from item) `thenM_` returnM [] - get_item :: RdrNameIE -> RnM [(AvailInfo, [Name])] + get_item :: IE RdrName -> RnM [(AvailInfo, [Name])] -- Empty list for a bad item. -- Singleton is typical case. -- Can have two when we are hiding, and mention C which might be @@ -453,13 +456,13 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails -- The [Name] is the list of explicitly-mentioned names get_item item@(IEModuleContents _) = bale_out item - get_item item@(IEThingAll _) + get_item item@(IEThingAll tc) = case check_item item of Nothing -> bale_out item Just avail@(AvailTC _ [n]) -> -- This occurs when you import T(..), but -- only export T abstractly. The single [n] -- in the AvailTC is the type or class itself - ifOptM Opt_WarnMisc (addWarn (dodgyImportWarn mod item)) `thenM_` + ifOptM Opt_WarnMisc (addWarn (dodgyImportWarn mod tc)) `thenM_` returnM [(avail, [availName avail])] Just avail -> returnM [(avail, [availName avail])] @@ -496,7 +499,7 @@ filterImports mod from (Just (want_hiding, import_items)) total_avails \end{code} \begin{code} -filterAvail :: RdrNameIE -- Wanted +filterAvail :: IE RdrName -- Wanted -> AvailInfo -- Available -> Maybe AvailInfo -- Resulting available; -- Nothing if (any of the) wanted stuff isn't there @@ -560,21 +563,21 @@ type ExportAccum -- The type of the accumulating parameter of -- so we can common-up related AvailInfos emptyExportAccum = ([], emptyFM, emptyAvailEnv) -type ExportOccMap = FiniteMap OccName (Name, RdrNameIE) +type ExportOccMap = FiniteMap OccName (Name, IE RdrName) -- Tracks what a particular exported OccName -- in an export list refers to, and which item -- it came from. It's illegal to export two distinct things -- that have the same occurrence name -exportsFromAvail :: Maybe Module -- Nothing => no 'module M(..) where' header at all - -> Maybe [RdrNameIE] -- Nothing => no explicit export list +exportsFromAvail :: Bool -- False => no 'module M(..) where' header at all + -> Maybe [Located (IE RdrName)] -- Nothing => no explicit export list -> RnM Avails -- Complains if two distinct exports have same OccName -- Warns about identical exports. -- Complains about exports items not in scope -exportsFromAvail maybe_mod exports +exportsFromAvail explicit_mod exports = do { TcGblEnv { tcg_rdr_env = rdr_env, tcg_imports = imports } <- getGblEnv ; @@ -586,13 +589,12 @@ exportsFromAvail maybe_mod exports -- in interactive mode ghci_mode <- getGhciMode ; let { real_exports - = case maybe_mod of - Just mod -> exports - Nothing | ghci_mode == Interactive -> Nothing - | otherwise -> Just [IEVar main_RDR_Unqual] } ; - + | explicit_mod = exports + | ghci_mode == Interactive = Nothing + | otherwise = Just [noLoc (IEVar main_RDR_Unqual)] } ; exports_from_avail real_exports rdr_env imports } + exports_from_avail Nothing rdr_env imports@(ImportAvails { imp_env = entity_avail_env }) = -- Export all locally-defined things @@ -610,13 +612,15 @@ exports_from_avail Nothing rdr_env exports_from_avail (Just export_items) rdr_env (ImportAvails { imp_qual = mod_avail_env, imp_env = entity_avail_env }) - = foldlM exports_from_item emptyExportAccum + = foldlM (exports_from_litem) emptyExportAccum export_items `thenM` \ (_, _, export_avail_map) -> returnM (nameEnvElts export_avail_map) where - exports_from_item :: ExportAccum -> RdrNameIE -> RnM ExportAccum + exports_from_litem :: ExportAccum -> Located (IE RdrName) -> RnM ExportAccum + exports_from_litem acc = addLocM (exports_from_item acc) + exports_from_item :: ExportAccum -> IE RdrName -> RnM ExportAccum exports_from_item acc@(mods, occs, avails) ie@(IEModuleContents mod) | mod `elem` mods -- Duplicate export of M = do { warn_dup_exports <- doptM Opt_WarnDuplicateExports ; @@ -665,7 +669,7 @@ exports_from_avail (Just export_items) rdr_env Just export_avail -> -- Phew! It's OK! Now to check the occurrence stuff! - warnIf (not (ok_item ie avail)) (dodgyExportWarn ie) `thenM_` + checkForDodgyExport ie avail `thenM_` check_occs ie occs export_avail `thenM` \ occs' -> returnM (mods, occs', addAvail avails export_avail) } @@ -688,16 +692,16 @@ in_scope :: GlobalRdrEnv -> Name -> Bool -- regardless of whether it's ambiguous or not in_scope env n = any unQualOK (lookupGRE_Name env n) - ------------------------------- -ok_item (IEThingAll _) (AvailTC _ [n]) = False +checkForDodgyExport :: IE RdrName -> AvailInfo -> RnM () +checkForDodgyExport (IEThingAll tc) (AvailTC _ [n]) = addWarn (dodgyExportWarn tc) -- This occurs when you import T(..), but -- only export T abstractly. The single [n] -- in the AvailTC is the type or class itself -ok_item _ _ = True +checkForDodgyExport _ _ = return () ------------------------------- -check_occs :: RdrNameIE -> ExportOccMap -> AvailInfo -> RnM ExportOccMap +check_occs :: IE RdrName -> ExportOccMap -> AvailInfo -> RnM ExportOccMap check_occs ie occs avail = foldlM check occs (availNames avail) where @@ -907,8 +911,8 @@ badImportItemErr mod from ie dodgyImportWarn mod item = dodgyMsg (ptext SLIT("import")) item dodgyExportWarn item = dodgyMsg (ptext SLIT("export")) item -dodgyMsg kind item@(IEThingAll tc) - = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr item), +dodgyMsg kind tc + = sep [ ptext SLIT("The") <+> kind <+> ptext SLIT("item") <+> quotes (ppr (IEThingAll tc)), ptext SLIT("suggests that") <+> quotes (ppr tc) <+> ptext SLIT("has constructor or class methods"), ptext SLIT("but it has none; it is a type synonym or abstract type or class") ] diff --git a/ghc/compiler/rename/RnSource.hi-boot-5 b/ghc/compiler/rename/RnSource.hi-boot-5 index 80941fd838..1ec4d52522 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-5 +++ b/ghc/compiler/rename/RnSource.hi-boot-5 @@ -1,15 +1,13 @@ __interface RnSource 1 0 where __export RnSource rnBindsAndThen rnBinds rnSrcDecls; -1 rnBindsAndThen :: __forall [b] => RdrHsSyn.RdrNameHsBinds - -> (RnHsSyn.RenamedHsBinds +1 rnBindsAndThen :: __forall [b] => [HsBinds.HsBindGroup RdrName.RdrName] + -> ([HsBinds.HsBindGroup Name.Name] -> TcRnTypes.RnM (b, NameSet.FreeVars)) -> TcRnTypes.RnM (b, NameSet.FreeVars) ; -1 rnBinds :: RdrHsSyn.RdrNameHsBinds - -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.DefUses) ; +1 rnBinds :: [HsBinds.HsBindGroup RdrName.RdrName] + -> TcRnTypes.RnM ([HsBinds.HsBindGroup Name.Name], NameSet.DefUses) ; 1 rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName - -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name) ; - - + -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name) diff --git a/ghc/compiler/rename/RnSource.hi-boot-6 b/ghc/compiler/rename/RnSource.hi-boot-6 index 83e8dd557a..4c0ac50a25 100644 --- a/ghc/compiler/rename/RnSource.hi-boot-6 +++ b/ghc/compiler/rename/RnSource.hi-boot-6 @@ -1,12 +1,12 @@ module RnSource where -rnBindsAndThen :: forall b . RdrHsSyn.RdrNameHsBinds - -> (RnHsSyn.RenamedHsBinds +rnBindGroupsAndThen :: forall b . [HsBinds.HsBindGroup RdrName.RdrName] + -> ([HsBinds.HsBindGroup Name.Name] -> TcRnTypes.RnM (b, NameSet.FreeVars)) -> TcRnTypes.RnM (b, NameSet.FreeVars) ; -rnBinds :: RdrHsSyn.RdrNameHsBinds - -> TcRnTypes.RnM (RnHsSyn.RenamedHsBinds, NameSet.DefUses) ; +rnBindGroups :: [HsBinds.HsBindGroup RdrName.RdrName] + -> TcRnTypes.RnM ([HsBinds.HsBindGroup Name.Name], NameSet.DefUses) ; rnSrcDecls :: HsDecls.HsGroup RdrName.RdrName -> TcRnTypes.RnM (TcRnTypes.TcGblEnv, HsDecls.HsGroup Name.Name) diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 1fb018957e..93bebe98dc 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -7,24 +7,23 @@ module RnSource ( rnSrcDecls, addTcgDUs, rnTyClDecls, checkModDeprec, - rnBinds, rnBindsAndThen + rnBindGroups, rnBindGroupsAndThen ) where #include "HsVersions.h" import HsSyn import RdrName ( RdrName, isRdrDataCon, rdrNameOcc, elemLocalRdrEnv ) -import RdrHsSyn ( RdrNameConDecl, RdrNameHsBinds, - RdrNameDeprecation, RdrNameFixitySig, - extractGenericPatTyVars ) +import RdrHsSyn ( extractGenericPatTyVars ) import RnHsSyn -import RnExpr ( rnExpr ) -import RnTypes ( rnHsType, rnHsSigType, rnHsTypeFVs, rnContext ) -import RnBinds ( rnTopMonoBinds, rnMonoBinds, rnMethodBinds, - rnMonoBindsAndThen, renameSigs, checkSigs ) +import RnExpr ( rnLExpr ) +import RnTypes ( rnLHsType, rnHsSigType, rnHsTypeFVs, rnContext ) +import RnBinds ( rnTopBinds, rnBinds, rnMethodBinds, + rnBindsAndThen, renameSigs, checkSigs ) import RnEnv ( lookupTopBndrRn, lookupTopFixSigNames, + lookupLocatedTopBndrRn, lookupLocatedOccRn, lookupOccRn, newLocalsRn, - bindLocalsFV, bindPatSigTyVarsFV, + bindLocatedLocalsFV, bindPatSigTyVarsFV, bindTyVarsRn, extendTyVarEnvFVRn, bindLocalNames, newIPNameRn, checkDupNames, mapFvRn, @@ -40,7 +39,7 @@ import Name ( Name ) import NameSet import NameEnv import Outputable -import SrcLoc ( SrcLoc ) +import SrcLoc ( Located(..), unLoc, getLoc ) import CmdLineOpts ( DynFlag(..) ) -- Warn of unused for-all'd tyvars import Maybes ( seqMaybe ) @@ -66,7 +65,7 @@ Checks the @(..)@ etc constraints in the export list. \begin{code} rnSrcDecls :: HsGroup RdrName -> RnM (TcGblEnv, HsGroup Name) -rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, +rnSrcDecls (HsGroup { hs_valds = [HsBindGroup binds sigs _], hs_tyclds = tycl_decls, hs_instds = inst_decls, hs_fixds = fix_decls, @@ -88,7 +87,7 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, -- Rename other declarations traceRn (text "Start rnmono") ; - (rn_val_decls, bind_dus) <- rnTopMonoBinds binds sigs ; + (rn_val_decls, bind_dus) <- rnTopBinds binds sigs ; traceRn (text "finish rnmono" <+> ppr rn_val_decls) ; -- You might think that we could build proper def/use information @@ -98,11 +97,16 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, -- So we content ourselves with gathering uses only; that -- means we'll only report a declaration as unused if it isn't -- mentioned at all. Ah well. - (rn_tycl_decls, src_fvs1) <- mapFvRn rnTyClDecl tycl_decls ; - (rn_inst_decls, src_fvs2) <- mapFvRn rnSrcInstDecl inst_decls ; - (rn_rule_decls, src_fvs3) <- mapFvRn rnHsRuleDecl rule_decls ; - (rn_foreign_decls, src_fvs4) <- mapFvRn rnHsForeignDecl foreign_decls ; - (rn_default_decls, src_fvs5) <- mapFvRn rnDefaultDecl default_decls ; + (rn_tycl_decls, src_fvs1) + <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls ; + (rn_inst_decls, src_fvs2) + <- mapFvRn (wrapLocFstM rnSrcInstDecl) inst_decls ; + (rn_rule_decls, src_fvs3) + <- mapFvRn (wrapLocFstM rnHsRuleDecl) rule_decls ; + (rn_foreign_decls, src_fvs4) + <- mapFvRn (wrapLocFstM rnHsForeignDecl) foreign_decls ; + (rn_default_decls, src_fvs5) + <- mapFvRn (wrapLocFstM rnDefaultDecl) default_decls ; let { rn_group = HsGroup { hs_valds = rn_val_decls, @@ -123,9 +127,11 @@ rnSrcDecls (HsGroup { hs_valds = MonoBind binds sigs _, tcg_env <- getGblEnv ; return (tcg_env `addTcgDUs` src_dus, rn_group) }}} -rnTyClDecls :: [TyClDecl RdrName] -> RnM [TyClDecl Name] -rnTyClDecls tycl_decls = do { (decls', fvs) <- mapFvRn rnTyClDecl tycl_decls - ; return decls' } + +rnTyClDecls :: [LTyClDecl RdrName] -> RnM [LTyClDecl Name] +rnTyClDecls tycl_decls = do + (decls', fvs) <- mapFvRn (wrapLocFstM rnTyClDecl) tycl_decls + return decls' addTcgDUs :: TcGblEnv -> DefUses -> TcGblEnv addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } @@ -139,7 +145,7 @@ addTcgDUs tcg_env dus = tcg_env { tcg_dus = tcg_dus tcg_env `plusDU` dus } %********************************************************* \begin{code} -rnSrcFixityDecls :: [RdrNameFixitySig] -> RnM FixityEnv +rnSrcFixityDecls :: [LFixitySig RdrName] -> RnM FixityEnv rnSrcFixityDecls fix_decls = getGblEnv `thenM` \ gbl_env -> foldlM rnFixityDecl (tcg_fix_env gbl_env) @@ -147,15 +153,16 @@ rnSrcFixityDecls fix_decls traceRn (text "fixity env" <+> pprFixEnv fix_env) `thenM_` returnM fix_env -rnFixityDecl :: FixityEnv -> RdrNameFixitySig -> RnM FixityEnv -rnFixityDecl fix_env (FixitySig rdr_name fixity loc) - = -- GHC extension: look up both the tycon and data con +rnFixityDecl :: FixityEnv -> LFixitySig RdrName -> RnM FixityEnv +rnFixityDecl fix_env (L loc (FixitySig rdr_name fixity)) + = addSrcSpan loc $ + -- GHC extension: look up both the tycon and data con -- for con-like things -- If neither are in scope, report an error; otherwise -- add both to the fixity env - lookupTopFixSigNames rdr_name `thenM` \ names -> + addLocM lookupTopFixSigNames rdr_name `thenM` \ names -> if null names then - addSrcLoc loc (addErr (unknownNameErr rdr_name)) `thenM_` + addLocErr rdr_name unknownNameErr `thenM_` returnM fix_env else foldlM add fix_env names @@ -163,21 +170,22 @@ rnFixityDecl fix_env (FixitySig rdr_name fixity loc) add fix_env name = case lookupNameEnv fix_env name of Just (FixItem _ _ loc') - -> addErr (dupFixityDecl rdr_name loc loc') `thenM_` + -> addLocErr rdr_name (dupFixityDecl loc') `thenM_` returnM fix_env Nothing -> returnM (extendNameEnv fix_env name fix_item) where - fix_item = FixItem (rdrNameOcc rdr_name) fixity loc + fix_item = FixItem (rdrNameOcc (unLoc rdr_name)) fixity + (getLoc rdr_name) pprFixEnv :: FixityEnv -> SDoc pprFixEnv env = pprWithCommas (\ (FixItem n f _) -> ppr f <+> ppr n) (nameEnvElts env) -dupFixityDecl rdr_name loc1 loc2 +dupFixityDecl loc rdr_name = vcat [ptext SLIT("Multiple fixity declarations for") <+> quotes (ppr rdr_name), - ptext SLIT("at ") <+> ppr loc1, - ptext SLIT("and") <+> ppr loc2] + ptext SLIT("also at ") <+> ppr loc + ] \end{code} @@ -192,17 +200,16 @@ It's only imported deprecations, dealt with in RnIfaces, that we gather them together. \begin{code} -rnSrcDeprecDecls :: [RdrNameDeprecation] -> RnM Deprecations +rnSrcDeprecDecls :: [LDeprecDecl RdrName] -> RnM Deprecations rnSrcDeprecDecls [] = returnM NoDeprecs rnSrcDeprecDecls decls - = mappM rn_deprec decls `thenM` \ pairs -> + = mappM (addLocM rn_deprec) decls `thenM` \ pairs -> returnM (DeprecSome (mkNameEnv (catMaybes pairs))) where - rn_deprec (Deprecation rdr_name txt loc) - = addSrcLoc loc $ - lookupTopBndrRn rdr_name `thenM` \ name -> + rn_deprec (Deprecation rdr_name txt) + = lookupTopBndrRn rdr_name `thenM` \ name -> returnM (Just (name, (rdrNameOcc rdr_name, txt))) checkModDeprec :: Maybe DeprecTxt -> Deprecations @@ -218,10 +225,9 @@ checkModDeprec (Just txt) = DeprecAll txt %********************************************************* \begin{code} -rnDefaultDecl (DefaultDecl tys src_loc) - = addSrcLoc src_loc $ - mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> - returnM (DefaultDecl tys' src_loc, fvs) +rnDefaultDecl (DefaultDecl tys) + = mapFvRn (rnHsTypeFVs doc_str) tys `thenM` \ (tys', fvs) -> + returnM (DefaultDecl tys', fvs) where doc_str = text "In a `default' declaration" \end{code} @@ -237,33 +243,45 @@ is just one hi-boot file (for RnSource). rnSrcDecls is part of the loop too, and it must be defined in this module. \begin{code} -rnBinds :: RdrNameHsBinds -> RnM (RenamedHsBinds, DefUses) +rnBindGroups :: [HsBindGroup RdrName] -> RnM ([HsBindGroup Name], DefUses) -- This version assumes that the binders are already in scope -- It's used only in 'mdo' -rnBinds EmptyBinds = returnM (EmptyBinds, emptyDUs) -rnBinds (MonoBind bind sigs _) = rnMonoBinds NotTopLevel bind sigs -rnBinds b@(IPBinds bind) = addErr (badIpBinds b) `thenM_` - returnM (EmptyBinds, emptyDUs) - -rnBindsAndThen :: RdrNameHsBinds - -> (RenamedHsBinds -> RnM (result, FreeVars)) - -> RnM (result, FreeVars) +rnBindGropus [] + = returnM ([], emptyDUs) +rnBindGroups [HsBindGroup bind sigs _] + = rnBinds NotTopLevel bind sigs +rnBindGroups b@[HsIPBinds bind] + = do addErr (badIpBinds b) + returnM ([], emptyDUs) +rnBindGroups _ + = panic "rnBindGroups" + +rnBindGroupsAndThen + :: [HsBindGroup RdrName] + -> ([HsBindGroup Name] -> RnM (result, FreeVars)) + -> RnM (result, FreeVars) -- This version (a) assumes that the binding vars are not already in scope -- (b) removes the binders from the free vars of the thing inside -- The parser doesn't produce ThenBinds -rnBindsAndThen EmptyBinds thing_inside = thing_inside EmptyBinds -rnBindsAndThen (MonoBind bind sigs _) thing_inside = rnMonoBindsAndThen bind sigs thing_inside -rnBindsAndThen (IPBinds binds) thing_inside - = rnIPBinds binds `thenM` \ (binds',fv_binds) -> - thing_inside (IPBinds binds') `thenM` \ (thing, fvs_thing) -> +rnBindGroupsAndThen [] thing_inside + = thing_inside [] +rnBindGroupsAndThen [HsBindGroup bind sigs _] thing_inside + = rnBindsAndThen bind sigs $ \ groups -> thing_inside groups +rnBindGroupsAndThen [HsIPBinds binds] thing_inside + = rnIPBinds binds `thenM` \ (binds',fv_binds) -> + thing_inside [HsIPBinds binds'] `thenM` \ (thing, fvs_thing) -> returnM (thing, fvs_thing `plusFV` fv_binds) rnIPBinds [] = returnM ([], emptyFVs) -rnIPBinds ((n, expr) : binds) - = newIPNameRn n `thenM` \ name -> - rnExpr expr `thenM` \ (expr',fvExpr) -> +rnIPBinds (bind : binds) + = wrapLocFstM rnIPBind bind `thenM` \ (bind', fvBind) -> rnIPBinds binds `thenM` \ (binds',fvBinds) -> - returnM ((name, expr') : binds', fvExpr `plusFV` fvBinds) + returnM (bind' : binds', fvBind `plusFV` fvBinds) + +rnIPBind (IPBind n expr) + = newIPNameRn n `thenM` \ name -> + rnLExpr expr `thenM` \ (expr',fvExpr) -> + return (IPBind name expr', fvExpr) badIpBinds binds = hang (ptext SLIT("Implicit-parameter bindings illegal in 'mdo':")) 4 @@ -278,17 +296,15 @@ badIpBinds binds %********************************************************* \begin{code} -rnHsForeignDecl (ForeignImport name ty spec isDeprec src_loc) - = addSrcLoc src_loc $ - lookupTopBndrRn name `thenM` \ name' -> +rnHsForeignDecl (ForeignImport name ty spec isDeprec) + = lookupLocatedTopBndrRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignImport name' ty' spec isDeprec src_loc, fvs) + returnM (ForeignImport name' ty' spec isDeprec, fvs) -rnHsForeignDecl (ForeignExport name ty spec isDeprec src_loc) - = addSrcLoc src_loc $ - lookupOccRn name `thenM` \ name' -> +rnHsForeignDecl (ForeignExport name ty spec isDeprec) + = lookupLocatedOccRn name `thenM` \ name' -> rnHsTypeFVs (fo_decl_msg name) ty `thenM` \ (ty', fvs) -> - returnM (ForeignExport name' ty' spec isDeprec src_loc, fvs ) + returnM (ForeignExport name' ty' spec isDeprec, fvs ) -- NB: a foreign export is an *occurrence site* for name, so -- we add it to the free-variable list. It might, for example, -- be imported from another module @@ -304,18 +320,17 @@ fo_decl_msg name = ptext SLIT("In the foreign declaration for") <+> ppr name %********************************************************* \begin{code} -rnSrcInstDecl (InstDecl inst_ty mbinds uprags src_loc) +rnSrcInstDecl (InstDecl inst_ty mbinds uprags) -- Used for both source and interface file decls - = addSrcLoc src_loc $ - rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> + = rnHsSigType (text "an instance decl") inst_ty `thenM` \ inst_ty' -> -- Rename the bindings -- The typechecker (not the renamer) checks that all -- the bindings are for the right class let meth_doc = text "In the bindings in an instance declaration" - meth_names = collectLocatedMonoBinders mbinds - (inst_tyvars, _, cls,_) = splitHsInstDeclTy inst_ty' + meth_names = collectHsBindLocatedBinders mbinds + (inst_tyvars, _, cls,_) = splitHsInstDeclTy (unLoc inst_ty') in checkDupNames meth_doc meth_names `thenM_` extendTyVarEnvForMethodBinds inst_tyvars ( @@ -331,13 +346,13 @@ rnSrcInstDecl (InstDecl inst_ty mbinds uprags src_loc) -- -- But the (unqualified) method names are in scope let - binders = collectMonoBinders mbinds' + binders = collectHsBindBinders mbinds' in bindLocalNames binders (renameSigs uprags) `thenM` \ uprags' -> checkSigs (okInstDclSig (mkNameSet binders)) uprags' `thenM_` - returnM (InstDecl inst_ty' mbinds' uprags' src_loc, - meth_fvs `plusFV` hsSigsFVs uprags' + returnM (InstDecl inst_ty' mbinds' uprags', + meth_fvs `plusFV` hsSigsFVs uprags' `plusFV` extractHsTyNames inst_ty') \end{code} @@ -348,7 +363,7 @@ type variable environment iff -fglasgow-exts extendTyVarEnvForMethodBinds tyvars thing_inside = doptM Opt_GlasgowExts `thenM` \ opt_GlasgowExts -> if opt_GlasgowExts then - extendTyVarEnvFVRn (map hsTyVarName tyvars) thing_inside + extendTyVarEnvFVRn (map hsLTyVarName tyvars) thing_inside else thing_inside \end{code} @@ -361,15 +376,14 @@ extendTyVarEnvForMethodBinds tyvars thing_inside %********************************************************* \begin{code} -rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) - = addSrcLoc src_loc $ - bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ +rnHsRuleDecl (HsRule rule_name act vars lhs rhs) + = bindPatSigTyVarsFV (collectRuleBndrSigTys vars) $ - bindLocalsFV doc (map get_var vars) $ \ ids -> + bindLocatedLocalsFV doc (map get_var vars) $ \ ids -> mapFvRn rn_var (vars `zip` ids) `thenM` \ (vars', fv_vars) -> - rnExpr lhs `thenM` \ (lhs', fv_lhs) -> - rnExpr rhs `thenM` \ (rhs', fv_rhs) -> + rnLExpr lhs `thenM` \ (lhs', fv_lhs) -> + rnLExpr rhs `thenM` \ (rhs', fv_rhs) -> let mb_bad = validRuleLhs ids lhs' in @@ -379,7 +393,7 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) bad_vars = [var | var <- ids, not (var `elemNameSet` fv_lhs)] in mappM (addErr . badRuleVar rule_name) bad_vars `thenM_` - returnM (HsRule rule_name act vars' lhs' rhs' src_loc, + returnM (HsRule rule_name act vars' lhs' rhs', fv_vars `plusFV` fv_lhs `plusFV` fv_rhs) where doc = text "In the transformation rule" <+> ftext rule_name @@ -387,9 +401,11 @@ rnHsRuleDecl (HsRule rule_name act vars lhs rhs src_loc) get_var (RuleBndr v) = v get_var (RuleBndrSig v _) = v - rn_var (RuleBndr v, id) = returnM (RuleBndr id, emptyFVs) - rn_var (RuleBndrSig v t, id) = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> - returnM (RuleBndrSig id t', fvs) + rn_var (RuleBndr (L loc v), id) + = returnM (RuleBndr (L loc id), emptyFVs) + rn_var (RuleBndrSig (L loc v) t, id) + = rnHsTypeFVs doc t `thenM` \ (t', fvs) -> + returnM (RuleBndrSig (L loc id) t', fvs) \end{code} Check the shape of a transformation rule LHS. Currently @@ -401,30 +417,34 @@ applications. (E.g. a case expression is not allowed: too elaborate.) NB: if you add new cases here, make sure you add new ones to TcRule.ruleLhsTvs \begin{code} -validRuleLhs :: [Name] -> RenamedHsExpr -> Maybe RenamedHsExpr +validRuleLhs :: [Name] -> LHsExpr Name -> Maybe (HsExpr Name) -- Nothing => OK -- Just e => Not ok, and e is the offending expression validRuleLhs foralls lhs - = check lhs + = checkl lhs where - check (OpApp e1 op _ e2) = check op `seqMaybe` check_e e1 `seqMaybe` check_e e2 - check (HsApp e1 e2) = check e1 `seqMaybe` check_e e2 + checkl (L loc e) = check e + + check (OpApp e1 op _ e2) = checkl op `seqMaybe` checkl_e e1 `seqMaybe` checkl_e e2 + check (HsApp e1 e2) = checkl e1 `seqMaybe` checkl_e e2 check (HsVar v) | v `notElem` foralls = Nothing check other = Just other -- Failure + checkl_e (L loc e) = check_e e + check_e (HsVar v) = Nothing - check_e (HsPar e) = check_e e + check_e (HsPar e) = checkl_e e check_e (HsLit e) = Nothing check_e (HsOverLit e) = Nothing - check_e (OpApp e1 op _ e2) = check_e e1 `seqMaybe` check_e op `seqMaybe` check_e e2 - check_e (HsApp e1 e2) = check_e e1 `seqMaybe` check_e e2 - check_e (NegApp e _) = check_e e - check_e (ExplicitList _ es) = check_es es - check_e (ExplicitTuple es _) = check_es es + check_e (OpApp e1 op _ e2) = checkl_e e1 `seqMaybe` checkl_e op `seqMaybe` checkl_e e2 + check_e (HsApp e1 e2) = checkl_e e1 `seqMaybe` checkl_e e2 + check_e (NegApp e _) = checkl_e e + check_e (ExplicitList _ es) = checkl_es es + check_e (ExplicitTuple es _) = checkl_es es check_e other = Just other -- Fails - check_es es = foldr (seqMaybe . check_e) Nothing es + checkl_es es = foldr (seqMaybe . checkl_e) Nothing es badRuleLhsErr name lhs (Just bad_e) = sep [ptext SLIT("Rule") <+> ftext name <> colon, @@ -460,53 +480,49 @@ and then go over it again to rename the tyvars! However, we can also do some scoping checks at the same time. \begin{code} -rnTyClDecl (ForeignType {tcdName = name, tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}) - = addSrcLoc loc $ - lookupTopBndrRn name `thenM` \ name' -> - returnM (ForeignType {tcdName = name', tcdFoType = fo_type, tcdExtName = ext_name, tcdLoc = loc}, +rnTyClDecl (ForeignType {tcdLName = name, tcdFoType = fo_type, tcdExtName = ext_name}) + = lookupLocatedTopBndrRn name `thenM` \ name' -> + returnM (ForeignType {tcdLName = name', tcdFoType = fo_type, tcdExtName = ext_name}, emptyFVs) -rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdName = tycon, +rnTyClDecl (TyData {tcdND = new_or_data, tcdCtxt = context, tcdLName = tycon, tcdTyVars = tyvars, tcdCons = condecls, - tcdDerivs = derivs, tcdLoc = src_loc}) - = addSrcLoc src_loc $ - lookupTopBndrRn tycon `thenM` \ tycon' -> + tcdDerivs = derivs}) + = lookupLocatedTopBndrRn tycon `thenM` \ tycon' -> bindTyVarsRn data_doc tyvars $ \ tyvars' -> rnContext data_doc context `thenM` \ context' -> rn_derivs derivs `thenM` \ (derivs', deriv_fvs) -> checkDupNames data_doc con_names `thenM_` - rnConDecls tycon' condecls `thenM` \ condecls' -> - returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdName = tycon', + rnConDecls (unLoc tycon') condecls `thenM` \ condecls' -> + returnM (TyData {tcdND = new_or_data, tcdCtxt = context', tcdLName = tycon', tcdTyVars = tyvars', tcdCons = condecls', - tcdDerivs = derivs', tcdLoc = src_loc}, - delFVs (map hsTyVarName tyvars') $ + tcdDerivs = derivs'}, + delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` plusFVs (map conDeclFVs condecls') `plusFV` deriv_fvs) where data_doc = text "In the data type declaration for" <+> quotes (ppr tycon) - con_names = map conDeclName condecls + con_names = [ n | L _ (ConDecl n _ _ _) <- condecls ] rn_derivs Nothing = returnM (Nothing, emptyFVs) rn_derivs (Just ds) = rnContext data_doc ds `thenM` \ ds' -> returnM (Just ds', extractHsCtxtTyNames ds') -rnTyClDecl (TySynonym {tcdName = name, tcdTyVars = tyvars, tcdSynRhs = ty, tcdLoc = src_loc}) - = addSrcLoc src_loc $ - lookupTopBndrRn name `thenM` \ name' -> +rnTyClDecl (TySynonym {tcdLName = name, tcdTyVars = tyvars, tcdSynRhs = ty}) + = lookupLocatedTopBndrRn name `thenM` \ name' -> bindTyVarsRn syn_doc tyvars $ \ tyvars' -> rnHsTypeFVs syn_doc ty `thenM` \ (ty', fvs) -> - returnM (TySynonym {tcdName = name', tcdTyVars = tyvars', - tcdSynRhs = ty', tcdLoc = src_loc}, - delFVs (map hsTyVarName tyvars') fvs) + returnM (TySynonym {tcdLName = name', tcdTyVars = tyvars', + tcdSynRhs = ty'}, + delFVs (map hsLTyVarName tyvars') fvs) where syn_doc = text "In the declaration for type synonym" <+> quotes (ppr name) -rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, +rnTyClDecl (ClassDecl {tcdCtxt = context, tcdLName = cname, tcdTyVars = tyvars, tcdFDs = fds, tcdSigs = sigs, - tcdMeths = mbinds, tcdLoc = src_loc}) - = addSrcLoc src_loc $ - lookupTopBndrRn cname `thenM` \ cname' -> + tcdMeths = mbinds}) + = lookupLocatedTopBndrRn cname `thenM` \ cname' -> -- Tyvars scope over superclass context and method signatures bindTyVarsRn cls_doc tyvars ( \ tyvars' -> @@ -519,7 +535,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, -- Check the signatures -- First process the class op sigs (op_sigs), then the fixity sigs (non_op_sigs). let - sig_rdr_names_w_locs = [(op,locn) | Sig op _ locn <- sigs] + sig_rdr_names_w_locs = [op | L _ (Sig op _) <- sigs] in checkDupNames sig_doc sig_rdr_names_w_locs `thenM_` checkSigs okClsDclSig sigs' `thenM_` @@ -539,21 +555,21 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, extendTyVarEnvForMethodBinds tyvars' ( getLocalRdrEnv `thenM` \ name_env -> let - meth_rdr_names_w_locs = collectLocatedMonoBinders mbinds - gen_rdr_tyvars_w_locs = [(tv,src_loc) | tv <- extractGenericPatTyVars mbinds, - not (tv `elemLocalRdrEnv` name_env)] + meth_rdr_names_w_locs = collectHsBindLocatedBinders mbinds + gen_rdr_tyvars_w_locs = + [ tv | tv <- extractGenericPatTyVars mbinds, + not (unLoc tv `elemLocalRdrEnv` name_env) ] in checkDupNames meth_doc meth_rdr_names_w_locs `thenM_` - newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> - rnMethodBinds cname' gen_tyvars mbinds - ) `thenM` \ (mbinds', meth_fvs) -> - - returnM (ClassDecl { tcdCtxt = context', tcdName = cname', tcdTyVars = tyvars', - tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds', - tcdLoc = src_loc}, - delFVs (map hsTyVarName tyvars') $ + newLocalsRn gen_rdr_tyvars_w_locs `thenM` \ gen_tyvars -> + rnMethodBinds (unLoc cname') gen_tyvars mbinds + ) `thenM` \ (mbinds', meth_fvs) -> + + returnM (ClassDecl { tcdCtxt = context', tcdLName = cname', tcdTyVars = tyvars', + tcdFDs = fds', tcdSigs = sigs', tcdMeths = mbinds'}, + delFVs (map hsLTyVarName tyvars') $ extractHsCtxtTyNames context' `plusFV` - plusFVs (map extractFunDepNames fds') `plusFV` + plusFVs (map extractFunDepNames (map unLoc fds')) `plusFV` hsSigsFVs sigs' `plusFV` meth_fvs) where @@ -569,10 +585,7 @@ rnTyClDecl (ClassDecl {tcdCtxt = context, tcdName = cname, %********************************************************* \begin{code} -conDeclName :: RdrNameConDecl -> (RdrName, SrcLoc) -conDeclName (ConDecl n _ _ _ l) = (n,l) - -rnConDecls :: Name -> [RdrNameConDecl] -> RnM [RenamedConDecl] +rnConDecls :: Name -> [LConDecl RdrName] -> RnM [LConDecl Name] rnConDecls tycon condecls = -- Check that there's at least one condecl, -- or else we're reading an interface file, or -fglasgow-exts @@ -581,44 +594,45 @@ rnConDecls tycon condecls checkErr glaExts (emptyConDeclsErr tycon) else returnM () ) `thenM_` - mappM rnConDecl condecls + mappM (wrapLocM rnConDecl) condecls -rnConDecl :: RdrNameConDecl -> RnM RenamedConDecl -rnConDecl (ConDecl name tvs cxt details locn) - = addSrcLoc locn $ - checkConName name `thenM_` - lookupTopBndrRn name `thenM` \ new_name -> +rnConDecl :: ConDecl RdrName -> RnM (ConDecl Name) +rnConDecl (ConDecl name tvs cxt details) + = addLocM checkConName name `thenM_` + lookupLocatedTopBndrRn name `thenM` \ new_name -> bindTyVarsRn doc tvs $ \ new_tyvars -> rnContext doc cxt `thenM` \ new_context -> - rnConDetails doc locn details `thenM` \ new_details -> - returnM (ConDecl new_name new_tyvars new_context new_details locn) + rnConDetails doc details `thenM` \ new_details -> + returnM (ConDecl new_name new_tyvars new_context new_details) where doc = text "In the definition of data constructor" <+> quotes (ppr name) -rnConDetails doc locn (PrefixCon tys) - = mappM (rnBangTy doc) tys `thenM` \ new_tys -> +rnConDetails doc (PrefixCon tys) + = mappM (rnLBangTy doc) tys `thenM` \ new_tys -> returnM (PrefixCon new_tys) -rnConDetails doc locn (InfixCon ty1 ty2) - = rnBangTy doc ty1 `thenM` \ new_ty1 -> - rnBangTy doc ty2 `thenM` \ new_ty2 -> +rnConDetails doc (InfixCon ty1 ty2) + = rnLBangTy doc ty1 `thenM` \ new_ty1 -> + rnLBangTy doc ty2 `thenM` \ new_ty2 -> returnM (InfixCon new_ty1 new_ty2) -rnConDetails doc locn (RecCon fields) +rnConDetails doc (RecCon fields) = checkDupNames doc field_names `thenM_` mappM (rnField doc) fields `thenM` \ new_fields -> returnM (RecCon new_fields) where - field_names = [(fld, locn) | (fld, _) <- fields] + field_names = [fld | (fld, _) <- fields] rnField doc (name, ty) - = lookupTopBndrRn name `thenM` \ new_name -> - rnBangTy doc ty `thenM` \ new_ty -> + = lookupLocatedTopBndrRn name `thenM` \ new_name -> + rnLBangTy doc ty `thenM` \ new_ty -> returnM (new_name, new_ty) +rnLBangTy doc = wrapLocM (rnBangTy doc) + rnBangTy doc (BangType s ty) - = rnHsType doc ty `thenM` \ new_ty -> + = rnLHsType doc ty `thenM` \ new_ty -> returnM (BangType s new_ty) -- This data decl will parse OK @@ -649,10 +663,10 @@ emptyConDeclsErr tycon %********************************************************* \begin{code} -rnFds :: SDoc -> [FunDep RdrName] -> RnM [FunDep Name] +rnFds :: SDoc -> [Located (FunDep RdrName)] -> RnM [Located (FunDep Name)] rnFds doc fds - = mappM rn_fds fds + = mappM (wrapLocM rn_fds) fds where rn_fds (tys1, tys2) = rnHsTyVars doc tys1 `thenM` \ tys1' -> diff --git a/ghc/compiler/rename/RnTypes.lhs b/ghc/compiler/rename/RnTypes.lhs index cc0f0f3b94..e41c7752a5 100644 --- a/ghc/compiler/rename/RnTypes.lhs +++ b/ghc/compiler/rename/RnTypes.lhs @@ -4,9 +4,9 @@ \section[RnSource]{Main pass of renamer} \begin{code} -module RnTypes ( rnHsType, rnContext, +module RnTypes ( rnHsType, rnLHsType, rnContext, rnHsSigType, rnHsTypeFVs, - rnPat, rnPatsAndThen, -- Here because it's not part + rnLPat, rnPat, rnPatsAndThen, -- Here because it's not part rnOverLit, litFVs, -- of any mutual recursion precParseErr, sectionPrecErr, dupFieldErr, patSigErr, checkTupSize ) where @@ -14,30 +14,34 @@ module RnTypes ( rnHsType, rnContext, import CmdLineOpts ( DynFlag(Opt_WarnUnusedMatches, Opt_GlasgowExts) ) import HsSyn -import RdrHsSyn ( RdrNameContext, RdrNameHsType, RdrNamePat, - extractHsRhoRdrTyVars ) -import RnHsSyn ( RenamedContext, RenamedHsType, RenamedPat, - extractHsTyNames, - parrTyCon_name, tupleTyCon_name, listTyCon_name, charTyCon_name ) -import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, lookupGlobalOccRn, - bindTyVarsRn, lookupFixityRn, mapFvRn, newIPNameRn, - bindPatSigTyVarsFV, bindLocalsFV, warnUnusedMatches ) +import RdrHsSyn ( extractHsRhoRdrTyVars ) +import RnHsSyn ( extractHsTyNames, parrTyCon_name, tupleTyCon_name, + listTyCon_name, charTyCon_name + ) +import RnEnv ( lookupOccRn, lookupBndrRn, lookupSyntaxName, + lookupLocatedOccRn, lookupLocatedBndrRn, + lookupLocatedGlobalOccRn, bindTyVarsRn, lookupFixityRn, + mapFvRn, warnUnusedMatches, + newIPNameRn, bindPatSigTyVarsFV, bindLocatedLocalsFV ) import TcRnMonad -import RdrName ( elemLocalRdrEnv ) -import PrelNames( eqStringName, eqClassName, integralClassName, - negateName, minusName, lengthPName, indexPName, plusIntegerName, fromIntegerName, - timesIntegerName, ratioDataConName, fromRationalName ) +import RdrName ( RdrName, elemLocalRdrEnv ) +import PrelNames ( eqStringName, eqClassName, integralClassName, + negateName, minusName, lengthPName, indexPName, + plusIntegerName, fromIntegerName, timesIntegerName, + ratioDataConName, fromRationalName ) import Constants ( mAX_TUPLE_SIZE ) import TysWiredIn ( intTyCon ) import TysPrim ( charPrimTyCon, addrPrimTyCon, intPrimTyCon, floatPrimTyCon, doublePrimTyCon ) -import Name ( Name, NamedThing(..) ) +import Name ( Name, NamedThing(..) ) +import SrcLoc ( Located(..), unLoc ) import NameSet import Literal ( inIntRange, inCharRange ) import BasicTypes ( compareFixity ) import ListSetOps ( removeDups ) import Outputable +import Monad ( when ) #include "HsVersions.h" \end{code} @@ -52,23 +56,26 @@ to break several loop. %********************************************************* \begin{code} -rnHsTypeFVs :: SDoc -> RdrNameHsType -> RnM (RenamedHsType, FreeVars) +rnHsTypeFVs :: SDoc -> LHsType RdrName -> RnM (LHsType Name, FreeVars) rnHsTypeFVs doc_str ty - = rnHsType doc_str ty `thenM` \ ty' -> + = rnLHsType doc_str ty `thenM` \ ty' -> returnM (ty', extractHsTyNames ty') -rnHsSigType :: SDoc -> RdrNameHsType -> RnM RenamedHsType +rnHsSigType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) -- rnHsSigType is used for source-language type signatures, -- which use *implicit* universal quantification. rnHsSigType doc_str ty - = rnHsType (text "In the type signature for" <+> doc_str) ty + = rnLHsType (text "In the type signature for" <+> doc_str) ty \end{code} rnHsType is here because we call it from loadInstDecl, and I didn't want a gratuitous knot. \begin{code} -rnHsType :: SDoc -> RdrNameHsType -> RnM RenamedHsType +rnLHsType :: SDoc -> LHsType RdrName -> RnM (LHsType Name) +rnLHsType doc = wrapLocM (rnHsType doc) + +rnHsType :: SDoc -> HsType RdrName -> RnM (HsType Name) rnHsType doc (HsForAllTy Implicit _ ctxt ty) -- Implicit quantifiction in source code (no kinds on tyvars) @@ -82,20 +89,21 @@ rnHsType doc (HsForAllTy Implicit _ ctxt ty) -- when GlasgowExts is off, there usually won't be any, except for -- class signatures: -- class C a where { op :: a -> a } - forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env)) mentioned + forall_tyvars = filter (not . (`elemLocalRdrEnv` name_env) . unLoc) mentioned + tyvar_bndrs = [ L loc (UserTyVar v) | (L loc v) <- forall_tyvars ] in - rnForAll doc Implicit (map UserTyVar forall_tyvars) ctxt ty + rnForAll doc Implicit tyvar_bndrs ctxt ty rnHsType doc (HsForAllTy Explicit forall_tyvars ctxt tau) -- Explicit quantification. -- Check that the forall'd tyvars are actually -- mentioned in the type, and produce a warning if not = let - mentioned = extractHsRhoRdrTyVars ctxt tau - forall_tyvar_names = hsTyVarNames forall_tyvars + mentioned = map unLoc (extractHsRhoRdrTyVars ctxt tau) + forall_tyvar_names = hsLTyVarLocNames forall_tyvars -- Explicitly quantified but not mentioned in ctxt or tau - warn_guys = filter (`notElem` mentioned) forall_tyvar_names + warn_guys = filter ((`notElem` mentioned) . unLoc) forall_tyvar_names in mappM_ (forAllWarn doc tau) warn_guys `thenM_` rnForAll doc Explicit forall_tyvars ctxt tau @@ -104,15 +112,17 @@ rnHsType doc (HsTyVar tyvar) = lookupOccRn tyvar `thenM` \ tyvar' -> returnM (HsTyVar tyvar') -rnHsType doc (HsOpTy ty1 op ty2) - = lookupOccRn op `thenM` \ op' -> - rnHsType doc ty1 `thenM` \ ty1' -> - rnHsType doc ty2 `thenM` \ ty2' -> - lookupTyFixityRn op' `thenM` \ fix -> - mkHsOpTyRn op' fix ty1' ty2' +rnHsType doc (HsOpTy ty1 (L loc op) ty2) + = addSrcSpan loc ( + lookupOccRn op `thenM` \ op' -> + lookupTyFixityRn (L loc op') `thenM` \ fix -> + rnLHsType doc ty1 `thenM` \ ty1' -> + rnLHsType doc ty2 `thenM` \ ty2' -> + mkHsOpTyRn (L loc op') fix ty1' ty2' + ) rnHsType doc (HsParTy ty) - = rnHsType doc ty `thenM` \ ty' -> + = rnLHsType doc ty `thenM` \ ty' -> returnM (HsParTy ty') rnHsType doc (HsNumTy i) @@ -123,46 +133,49 @@ rnHsType doc (HsNumTy i) rnHsType doc (HsFunTy ty1 ty2) - = rnHsType doc ty1 `thenM` \ ty1' -> + = rnLHsType doc ty1 `thenM` \ ty1' -> -- Might find a for-all as the arg of a function type - rnHsType doc ty2 `thenM` \ ty2' -> + rnLHsType doc ty2 `thenM` \ ty2' -> -- Or as the result. This happens when reading Prelude.hi -- when we find return :: forall m. Monad m -> forall a. a -> m a returnM (HsFunTy ty1' ty2') rnHsType doc (HsListTy ty) - = rnHsType doc ty `thenM` \ ty' -> + = rnLHsType doc ty `thenM` \ ty' -> returnM (HsListTy ty') rnHsType doc (HsKindSig ty k) - = rnHsType doc ty `thenM` \ ty' -> + = rnLHsType doc ty `thenM` \ ty' -> returnM (HsKindSig ty' k) rnHsType doc (HsPArrTy ty) - = rnHsType doc ty `thenM` \ ty' -> + = rnLHsType doc ty `thenM` \ ty' -> returnM (HsPArrTy ty') -- Unboxed tuples are allowed to have poly-typed arguments. These -- sometimes crop up as a result of CPR worker-wrappering dictionaries. rnHsType doc (HsTupleTy tup_con tys) - = mappM (rnHsType doc) tys `thenM` \ tys' -> + = mappM (rnLHsType doc) tys `thenM` \ tys' -> returnM (HsTupleTy tup_con tys') rnHsType doc (HsAppTy ty1 ty2) - = rnHsType doc ty1 `thenM` \ ty1' -> - rnHsType doc ty2 `thenM` \ ty2' -> + = rnLHsType doc ty1 `thenM` \ ty1' -> + rnLHsType doc ty2 `thenM` \ ty2' -> returnM (HsAppTy ty1' ty2') rnHsType doc (HsPredTy pred) - = rnPred doc pred `thenM` \ pred' -> + = rnLPred doc pred `thenM` \ pred' -> returnM (HsPredTy pred') -rnHsTypes doc tys = mappM (rnHsType doc) tys +rnLHsTypes doc tys = mappM (rnLHsType doc) tys \end{code} \begin{code} -rnForAll doc exp [] [] ty = rnHsType doc ty +rnForAll :: SDoc -> HsExplicitForAll -> [LHsTyVarBndr RdrName] -> LHsContext RdrName + -> LHsType RdrName -> RnM (HsType Name) + +rnForAll doc exp [] (L _ []) (L _ ty) = rnHsType doc ty -- One reason for this case is that a type like Int# -- starts of as (HsForAllTy Nothing [] Int), in case -- there is some quantification. Now that we have quantified @@ -174,7 +187,7 @@ rnForAll doc exp [] [] ty = rnHsType doc ty rnForAll doc exp forall_tyvars ctxt ty = bindTyVarsRn doc forall_tyvars $ \ new_tyvars -> rnContext doc ctxt `thenM` \ new_ctxt -> - rnHsType doc ty `thenM` \ new_ty -> + rnLHsType doc ty `thenM` \ new_ty -> returnM (HsForAllTy exp new_tyvars new_ctxt new_ty) -- Retain the same implicit/explicit flag as before -- so that we can later print it correctly @@ -197,18 +210,19 @@ have already been renamed and rearranged. It's made rather tiresome by the presence of -> \begin{code} -lookupTyFixityRn n +lookupTyFixityRn (L loc n) = doptM Opt_GlasgowExts `thenM` \ glaExts -> - warnIf (not glaExts) (infixTyConWarn n) `thenM_` + when (not glaExts) + (addSrcSpan loc $ addWarn (infixTyConWarn n)) `thenM_` lookupFixityRn n -- Building (ty1 `op1` (ty21 `op2` ty22)) -mkHsOpTyRn :: Name -> Fixity - -> RenamedHsType -> RenamedHsType - -> RnM RenamedHsType +mkHsOpTyRn :: Located Name -> Fixity + -> LHsType Name -> LHsType Name + -> RnM (HsType Name) -mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22) - = lookupTyFixityRn op2 `thenM` \ fix2 -> +mkHsOpTyRn op1 fix1 ty1 ty2@(L loc (HsOpTy ty21 op2 ty22)) + = lookupTyFixityRn op2 `thenM` \ fix2 -> let (nofix_error, associate_right) = compareFixity fix1 fix2 in @@ -220,7 +234,7 @@ mkHsOpTyRn op1 fix1 ty1 ty2@(HsOpTy ty21 op2 ty22) if not associate_right then -- Rearrange to ((ty1 `op1` ty21) `op2` ty22) mkHsOpTyRn op1 fix1 ty1 ty21 `thenM` \ new_ty -> - returnM (HsOpTy new_ty op2 ty22) + returnM (HsOpTy (L loc new_ty) op2 ty22) -- XXX loc is wrong else returnM (HsOpTy ty1 op1 ty2) @@ -235,17 +249,23 @@ mkHsOpTyRn op fix ty1 ty2 -- Default case, no rearrangment %********************************************************* \begin{code} -rnContext :: SDoc -> RdrNameContext -> RnM RenamedContext -rnContext doc ctxt = mappM (rnPred doc) ctxt +rnContext :: SDoc -> LHsContext RdrName -> RnM (LHsContext Name) +rnContext doc = wrapLocM (rnContext' doc) + +rnContext' :: SDoc -> HsContext RdrName -> RnM (HsContext Name) +rnContext' doc ctxt = mappM (rnLPred doc) ctxt + +rnLPred :: SDoc -> LHsPred RdrName -> RnM (LHsPred Name) +rnLPred doc = wrapLocM (rnPred doc) rnPred doc (HsClassP clas tys) = lookupOccRn clas `thenM` \ clas_name -> - rnHsTypes doc tys `thenM` \ tys' -> + rnLHsTypes doc tys `thenM` \ tys' -> returnM (HsClassP clas_name tys') rnPred doc (HsIParam n ty) = newIPNameRn n `thenM` \ name -> - rnHsType doc ty `thenM` \ ty' -> + rnLHsType doc ty `thenM` \ ty' -> returnM (HsIParam name ty') \end{code} @@ -259,8 +279,8 @@ rnPred doc (HsIParam n ty) \begin{code} rnPatsAndThen :: HsMatchContext Name -> Bool - -> [RdrNamePat] - -> ([RenamedPat] -> RnM (a, FreeVars)) + -> [LPat RdrName] + -> ([LPat Name] -> RnM (a, FreeVars)) -> RnM (a, FreeVars) -- Bring into scope all the binders and type variables -- bound by the patterns; then rename the patterns; then @@ -272,8 +292,8 @@ rnPatsAndThen :: HsMatchContext Name rnPatsAndThen ctxt repUnused pats thing_inside = bindPatSigTyVarsFV pat_sig_tys $ - bindLocalsFV doc_pat bndrs $ \ new_bndrs -> - rnPats pats `thenM` \ (pats', pat_fvs) -> + bindLocatedLocalsFV doc_pat bndrs $ \ new_bndrs -> + rnLPats pats `thenM` \ (pats', pat_fvs) -> thing_inside pats' `thenM` \ (res, res_fvs) -> let @@ -285,13 +305,19 @@ rnPatsAndThen ctxt repUnused pats thing_inside returnM (res, res_fvs `plusFV` pat_fvs) where pat_sig_tys = collectSigTysFromPats pats - bndrs = collectPatsBinders pats + bndrs = collectLocatedPatsBinders pats doc_pat = ptext SLIT("In") <+> pprMatchContext ctxt -rnPats :: [RdrNamePat] -> RnM ([RenamedPat], FreeVars) -rnPats ps = mapFvRn rnPat ps +rnLPats :: [LPat RdrName] -> RnM ([LPat Name], FreeVars) +rnLPats ps = mapFvRn rnLPat ps + +rnLPat :: LPat RdrName -> RnM (LPat Name, FreeVars) +rnLPat = wrapLocFstM rnPat + +-- ----------------------------------------------------------------------------- +-- rnPat -rnPat :: RdrNamePat -> RnM (RenamedPat, FreeVars) +rnPat :: Pat RdrName -> RnM (Pat Name, FreeVars) rnPat (WildPat _) = returnM (WildPat placeHolderType, emptyFVs) @@ -303,12 +329,12 @@ rnPat (SigPatIn pat ty) = doptM Opt_GlasgowExts `thenM` \ glaExts -> if glaExts - then rnPat pat `thenM` \ (pat', fvs1) -> + then rnLPat pat `thenM` \ (pat', fvs1) -> rnHsTypeFVs doc ty `thenM` \ (ty', fvs2) -> returnM (SigPatIn pat' ty', fvs1 `plusFV` fvs2) else addErr (patSigErr ty) `thenM_` - rnPat pat + rnPat (unLoc pat) -- XXX shouldn't throw away the loc where doc = text "In a pattern type-signature" @@ -332,34 +358,34 @@ rnPat (NPatIn lit mb_neg) rnPat (NPlusKPatIn name lit _) = rnOverLit lit `thenM` \ (lit', fvs1) -> - lookupBndrRn name `thenM` \ name' -> + lookupLocatedBndrRn name `thenM` \ name' -> lookupSyntaxName minusName `thenM` \ (minus, fvs2) -> returnM (NPlusKPatIn name' lit' minus, fvs1 `plusFV` fvs2 `addOneFV` integralClassName) -- The Report says that n+k patterns must be in Integral rnPat (LazyPat pat) - = rnPat pat `thenM` \ (pat', fvs) -> + = rnLPat pat `thenM` \ (pat', fvs) -> returnM (LazyPat pat', fvs) rnPat (AsPat name pat) - = rnPat pat `thenM` \ (pat', fvs) -> - lookupBndrRn name `thenM` \ vname -> + = rnLPat pat `thenM` \ (pat', fvs) -> + lookupLocatedBndrRn name `thenM` \ vname -> returnM (AsPat vname pat', fvs) rnPat (ConPatIn con stuff) = rnConPat con stuff rnPat (ParPat pat) - = rnPat pat `thenM` \ (pat', fvs) -> + = rnLPat pat `thenM` \ (pat', fvs) -> returnM (ParPat pat', fvs) rnPat (ListPat pats _) - = rnPats pats `thenM` \ (patslist, fvs) -> + = rnLPats pats `thenM` \ (patslist, fvs) -> returnM (ListPat patslist placeHolderType, fvs `addOneFV` listTyCon_name) rnPat (PArrPat pats _) - = rnPats pats `thenM` \ (patslist, fvs) -> + = rnLPats pats `thenM` \ (patslist, fvs) -> returnM (PArrPat patslist placeHolderType, fvs `plusFV` implicit_fvs `addOneFV` parrTyCon_name) where @@ -367,7 +393,7 @@ rnPat (PArrPat pats _) rnPat (TuplePat pats boxed) = checkTupSize tup_size `thenM_` - rnPats pats `thenM` \ (patslist, fvs) -> + rnLPats pats `thenM` \ (patslist, fvs) -> returnM (TuplePat patslist boxed, fvs `addOneFV` tycon_name) where tup_size = length pats @@ -377,47 +403,54 @@ rnPat (TypePat name) = rnHsTypeFVs (text "In a type pattern") name `thenM` \ (name', fvs) -> returnM (TypePat name', fvs) ------------------------------- +-- ----------------------------------------------------------------------------- +-- rnConPat + rnConPat con (PrefixCon pats) - = lookupOccRn con `thenM` \ con' -> - rnPats pats `thenM` \ (pats', fvs) -> - returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` con') + = lookupLocatedOccRn con `thenM` \ con' -> + rnLPats pats `thenM` \ (pats', fvs) -> + returnM (ConPatIn con' (PrefixCon pats'), fvs `addOneFV` unLoc con') rnConPat con (RecCon rpats) - = lookupOccRn con `thenM` \ con' -> - rnRpats rpats `thenM` \ (rpats', fvs) -> - returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` con') + = lookupLocatedOccRn con `thenM` \ con' -> + rnRpats rpats `thenM` \ (rpats', fvs) -> + returnM (ConPatIn con' (RecCon rpats'), fvs `addOneFV` unLoc con') rnConPat con (InfixCon pat1 pat2) - = lookupOccRn con `thenM` \ con' -> - rnPat pat1 `thenM` \ (pat1', fvs1) -> - rnPat pat2 `thenM` \ (pat2', fvs2) -> - lookupFixityRn con' `thenM` \ fixity -> + = lookupLocatedOccRn con `thenM` \ con' -> + rnLPat pat1 `thenM` \ (pat1', fvs1) -> + rnLPat pat2 `thenM` \ (pat2', fvs2) -> + lookupFixityRn (unLoc con') `thenM` \ fixity -> mkConOpPatRn con' fixity pat1' pat2' `thenM` \ pat' -> - returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` con') + returnM (pat', fvs1 `plusFV` fvs2 `addOneFV` unLoc con') + +-- ----------------------------------------------------------------------------- +-- rnRpats ------------------------- +rnRpats :: [(Located RdrName, LPat RdrName)] + -> RnM ([(Located Name, LPat Name)], FreeVars) rnRpats rpats = mappM_ field_dup_err dup_fields `thenM_` mapFvRn rn_rpat rpats `thenM` \ (rpats', fvs) -> returnM (rpats', fvs) where - (_, dup_fields) = removeDups compare [ f | (f,_) <- rpats ] + (_, dup_fields) = removeDups compare [ unLoc f | (f,_) <- rpats ] field_dup_err dups = addErr (dupFieldErr "pattern" dups) rn_rpat (field, pat) - = lookupGlobalOccRn field `thenM` \ fieldname -> - rnPat pat `thenM` \ (pat', fvs) -> - returnM ((fieldname, pat'), fvs `addOneFV` fieldname) -\end{code} + = lookupLocatedGlobalOccRn field `thenM` \ fieldname -> + rnLPat pat `thenM` \ (pat', fvs) -> + returnM ((fieldname, pat'), fvs `addOneFV` unLoc fieldname) -\begin{code} -mkConOpPatRn :: Name -> Fixity -> RenamedPat -> RenamedPat - -> RnM RenamedPat +-- ----------------------------------------------------------------------------- +-- mkConOpPatRn + +mkConOpPatRn :: Located Name -> Fixity -> LPat Name -> LPat Name + -> RnM (Pat Name) -mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2 - = lookupFixityRn op1 `thenM` \ fix1 -> +mkConOpPatRn op2 fix2 p1@(L loc (ConPatIn op1 (InfixCon p11 p12))) p2 + = lookupFixityRn (unLoc op1) `thenM` \ fix1 -> let (nofix_error, associate_right) = compareFixity fix1 fix2 in @@ -427,12 +460,12 @@ mkConOpPatRn op2 fix2 p1@(ConPatIn op1 (InfixCon p11 p12)) p2 else if associate_right then mkConOpPatRn op2 fix2 p12 p2 `thenM` \ new_p -> - returnM (ConPatIn op1 (InfixCon p11 new_p)) + returnM (ConPatIn op1 (InfixCon p11 (L loc new_p))) -- XXX loc right? else returnM (ConPatIn op2 (InfixCon p1 p2)) mkConOpPatRn op fix p1 p2 -- Default case, no rearrangment - = ASSERT( not_op_pat p2 ) + = ASSERT( not_op_pat (unLoc p2) ) returnM (ConPatIn op (InfixCon p1 p2)) not_op_pat (ConPatIn _ (InfixCon _ _)) = False @@ -462,10 +495,11 @@ litFVs (HsInt i) = returnM (unitFV (getName intTyCon)) litFVs (HsIntPrim i) = returnM (unitFV (getName intPrimTyCon)) litFVs (HsFloatPrim f) = returnM (unitFV (getName floatPrimTyCon)) litFVs (HsDoublePrim d) = returnM (unitFV (getName doublePrimTyCon)) -litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) -- HsInteger and HsRat only appear - -- in post-typechecker translations +litFVs lit = pprPanic "RnExpr.litFVs" (ppr lit) + -- HsInteger and HsRat only appear + -- in post-typechecker translations bogusCharError c - = ptext SLIT("character literal out of range: '\\") <> int c <> char '\'' + = ptext SLIT("character literal out of range: '\\") <> char c <> char '\'' rnOverLit (HsIntegral i _) = lookupSyntaxName fromIntegerName `thenM` \ (from_integer_name, fvs) -> @@ -514,8 +548,9 @@ checkTupSize tup_size nest 2 (parens (ptext SLIT("max size is") <+> int mAX_TUPLE_SIZE)), nest 2 (ptext SLIT("Workaround: use nested tuples or define a data type"))]) -forAllWarn doc ty tyvar +forAllWarn doc ty (L loc tyvar) = ifOptM Opt_WarnUnusedMatches $ + addSrcSpan loc $ addWarn (sep [ptext SLIT("The universally quantified type variable") <+> quotes (ppr tyvar), nest 4 (ptext SLIT("does not appear in the type") <+> quotes (ppr ty))] $$ @@ -540,7 +575,7 @@ patSigErr ty = (ptext SLIT("Illegal signature in pattern:") <+> ppr ty) $$ nest 4 (ptext SLIT("Use -fglasgow-exts to permit it")) -dupFieldErr str (dup:rest) +dupFieldErr str dup = hsep [ptext SLIT("duplicate field name"), quotes (ppr dup), ptext SLIT("in record"), text str] diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 31cc98afce..0d1b7b5921 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -19,12 +19,13 @@ import PrimOp ( primOpType ) import Literal ( literalType ) import Maybes ( catMaybes ) import Name ( getSrcLoc ) -import ErrUtils ( Message, addErrLocHdrLine ) +import ErrUtils ( Message, mkLocMessage ) import Type ( mkFunTys, splitFunTys, splitTyConApp_maybe, isUnLiftedType, isTyVarTy, dropForAlls, Type ) import TyCon ( isAlgTyCon, isNewTyCon, tyConDataCons ) import Util ( zipEqual, equalLength ) +import SrcLoc ( srcLocSpan ) import Outputable infixr 9 `thenL`, `thenL_`, `thenMaybeL` @@ -300,12 +301,12 @@ data LintLocInfo | BodyOfLetRec [Id] -- One of the binders dumpLoc (RhsOf v) = - (getSrcLoc v, ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' ) + (srcLocSpan (getSrcLoc v), ptext SLIT(" [RHS of ") <> pp_binders [v] <> char ']' ) dumpLoc (LambdaBodyOf bs) = - (getSrcLoc (head bs), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' ) + (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of lambda with binders ") <> pp_binders bs <> char ']' ) dumpLoc (BodyOfLetRec bs) = - (getSrcLoc (head bs), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' ) + (srcLocSpan (getSrcLoc (head bs)), ptext SLIT(" [in body of letrec with binders ") <> pp_binders bs <> char ']' ) pp_binders :: [Id] -> SDoc @@ -375,7 +376,7 @@ addErr errs_so_far msg locs = errs_so_far `snocBag` mk_msg locs where mk_msg (loc:_) = let (l,hdr) = dumpLoc loc - in addErrLocHdrLine l hdr msg + in mkLocMessage l (hdr $$ msg) mk_msg [] = msg addLoc :: LintLocInfo -> LintM a -> LintM a diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 615d157f9f..2eaac28851 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -39,9 +39,9 @@ module Inst ( import {-# SOURCE #-} TcExpr( tcCheckSigma ) -import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..) ) -import TcHsSyn ( TcExpr, TcId, TcIdSet, - mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId, +import HsSyn ( HsLit(..), HsOverLit(..), HsExpr(..), LHsExpr, nlHsVar, mkHsApp ) +import TcHsSyn ( TcId, TcIdSet, + mkHsTyApp, mkHsDictApp, mkHsConApp, zonkId, mkCoercion, ExprCoFn ) import TcRnMonad @@ -80,6 +80,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon ) import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName ) import BasicTypes( IPName(..), mapIPName, ipNameName ) import UniqSupply( uniqsFromSupply ) +import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) ) import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt ) import Maybes ( isJust ) import Outputable @@ -243,11 +244,12 @@ newDictsAtLoc inst_loc theta newIPDict :: InstOrigin -> IPName Name -> Type -> TcM (IPName Id, Inst) newIPDict orig ip_name ty - = getInstLoc orig `thenM` \ inst_loc@(InstLoc _ loc _) -> + = getInstLoc orig `thenM` \ inst_loc -> newUnique `thenM` \ uniq -> let pred = IParam ip_name ty - id = mkLocalId (mkPredName uniq loc pred) (mkPredTy pred) + name = mkPredName uniq (instLocSrcLoc inst_loc) pred + id = mkLocalId name (mkPredTy pred) in returnM (mapIPName (\n -> id) ip_name, Dict id pred inst_loc) \end{code} @@ -268,7 +270,7 @@ tcInstCall orig fun_ty -- fun_ty is usually a sigma-type newDicts orig theta `thenM` \ dicts -> extendLIEs dicts `thenM_` let - inst_fn e = mkHsDictApp (mkHsTyApp e (mkTyVarTys tyvars)) (map instToId dicts) + inst_fn e = DictApp (mkHsTyApp (noLoc e) (mkTyVarTys tyvars)) (map instToId dicts) in returnM (mkCoercion inst_fn, tau) @@ -357,14 +359,15 @@ cases (the rest are caught in lookupInst). newOverloadedLit :: InstOrigin -> HsOverLit -> TcType - -> TcM TcExpr + -> TcM (LHsExpr TcId) newOverloadedLit orig lit@(HsIntegral i fi) expected_ty - | fi /= fromIntegerName -- Do not generate a LitInst for rebindable - -- syntax. Reason: tcSyntaxName does unification + | fi /= fromIntegerName -- Do not generate a LitInst for rebindable syntax. + -- Reason: tcSyntaxName does unification -- which is very inconvenient in tcSimplify - = tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) -> - mkIntegerLit i `thenM` \ integer_lit -> - returnM (HsApp expr integer_lit) + -- ToDo: noLoc sadness + = tcSyntaxName orig expected_ty (fromIntegerName, noLoc (HsVar fi)) `thenM` \ (_,expr) -> + mkIntegerLit i `thenM` \ integer_lit -> + returnM (mkHsApp expr integer_lit) | Just expr <- shortCutIntLit i expected_ty = returnM expr @@ -374,9 +377,9 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty newOverloadedLit orig lit@(HsFractional r fr) expected_ty | fr /= fromRationalName -- c.f. HsIntegral case - = tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) -> - mkRatLit r `thenM` \ rat_lit -> - returnM (HsApp expr rat_lit) + = tcSyntaxName orig expected_ty (fromRationalName, noLoc (HsVar fr)) `thenM` \ (_,expr) -> + mkRatLit r `thenM` \ rat_lit -> + returnM (mkHsApp expr rat_lit) | Just expr <- shortCutFracLit r expected_ty = returnM expr @@ -384,6 +387,7 @@ newOverloadedLit orig lit@(HsFractional r fr) expected_ty | otherwise = newLitInst orig lit expected_ty +newLitInst :: InstOrigin -> HsOverLit -> TcType -> TcM (LHsExpr TcId) newLitInst orig lit expected_ty = getInstLoc orig `thenM` \ loc -> newUnique `thenM` \ new_uniq -> @@ -392,17 +396,17 @@ newLitInst orig lit expected_ty lit_id = mkSysLocal FSLIT("lit") new_uniq expected_ty in extendLIE lit_inst `thenM_` - returnM (HsVar (instToId lit_inst)) + returnM (L (instLocSrcSpan loc) (HsVar (instToId lit_inst))) -shortCutIntLit :: Integer -> TcType -> Maybe TcExpr +shortCutIntLit :: Integer -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-) shortCutIntLit i ty | isIntTy ty && inIntRange i -- Short cut for Int - = Just (HsLit (HsInt i)) + = Just (noLoc (HsLit (HsInt i))) | isIntegerTy ty -- Short cut for Integer - = Just (HsLit (HsInteger i ty)) + = Just (noLoc (HsLit (HsInteger i ty))) | otherwise = Nothing -shortCutFracLit :: Rational -> TcType -> Maybe TcExpr +shortCutFracLit :: Rational -> TcType -> Maybe (LHsExpr TcId) -- Returns noLoc'd result :-) shortCutFracLit f ty | isFloatTy ty = Just (mkHsConApp floatDataCon [] [HsLit (HsFloatPrim f)]) @@ -410,15 +414,17 @@ shortCutFracLit f ty = Just (mkHsConApp doubleDataCon [] [HsLit (HsDoublePrim f)]) | otherwise = Nothing -mkIntegerLit :: Integer -> TcM TcExpr +mkIntegerLit :: Integer -> TcM (LHsExpr TcId) mkIntegerLit i = tcMetaTy integerTyConName `thenM` \ integer_ty -> - returnM (HsLit (HsInteger i integer_ty)) + getSrcSpanM `thenM` \ span -> + returnM (L span $ HsLit (HsInteger i integer_ty)) -mkRatLit :: Rational -> TcM TcExpr +mkRatLit :: Rational -> TcM (LHsExpr TcId) mkRatLit r = tcMetaTy rationalTyConName `thenM` \ rat_ty -> - returnM (HsLit (HsRat r rat_ty)) + getSrcSpanM `thenM` \ span -> + returnM (L span $ HsLit (HsRat r rat_ty)) \end{code} @@ -579,13 +585,18 @@ traceDFuns dfuns pp dfun = ppr dfun <+> dcolon <+> ppr (idType dfun) funDepErr dfun dfuns - = addSrcLoc (getSrcLoc dfun) $ + = addDictLoc dfun $ addErr (hang (ptext SLIT("Functional dependencies conflict between instance declarations:")) 2 (pprDFuns (dfun:dfuns))) dupInstErr dfun dup_dfun - = addSrcLoc (getSrcLoc dfun) $ + = addDictLoc dfun $ addErr (hang (ptext SLIT("Duplicate instance declarations:")) 2 (pprDFuns [dfun, dup_dfun])) + +addDictLoc dfun thing_inside + = addSrcSpan (mkSrcSpan loc loc) thing_inside + where + loc = getSrcLoc dfun \end{code} %************************************************************************ @@ -597,8 +608,8 @@ dupInstErr dfun dup_dfun \begin{code} data LookupInstResult s = NoInstance - | SimpleInst TcExpr -- Just a variable, type application, or literal - | GenInst [Inst] TcExpr -- The expression and its needed insts + | SimpleInst (LHsExpr TcId) -- Just a variable, type application, or literal + | GenInst [Inst] (LHsExpr TcId) -- The expression and its needed insts lookupInst :: Inst -> TcM (LookupInstResult s) -- It's important that lookupInst does not put any new stuff into @@ -610,7 +621,9 @@ lookupInst :: Inst -> TcM (LookupInstResult s) lookupInst inst@(Method _ id tys theta _ loc) = newDictsAtLoc loc theta `thenM` \ dicts -> - returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (HsVar id) tys) (map instToId dicts))) + returnM (GenInst dicts (mkHsDictApp (mkHsTyApp (L span (HsVar id)) tys) (map instToId dicts))) + where + span = instLocSrcSpan loc -- Literals @@ -631,7 +644,8 @@ lookupInst inst@(LitInst u (HsIntegral i from_integer_name) ty loc) tcInstClassOp loc from_integer [ty] `thenM` \ method_inst -> mkIntegerLit i `thenM` \ integer_lit -> returnM (GenInst [method_inst] - (HsApp (HsVar (instToId method_inst)) integer_lit)) + (mkHsApp (L (instLocSrcSpan loc) + (HsVar (instToId method_inst))) integer_lit)) lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) | Just expr <- shortCutFracLit f ty @@ -642,7 +656,8 @@ lookupInst inst@(LitInst u (HsFractional f from_rat_name) ty loc) tcLookupId fromRationalName `thenM` \ from_rational -> tcInstClassOp loc from_rational [ty] `thenM` \ method_inst -> mkRatLit f `thenM` \ rat_lit -> - returnM (GenInst [method_inst] (HsApp (HsVar (instToId method_inst)) rat_lit)) + returnM (GenInst [method_inst] (mkHsApp (L (instLocSrcSpan loc) + (HsVar (instToId method_inst))) rat_lit)) -- Dictionaries lookupInst dict@(Dict _ pred@(ClassP clas tys) loc) @@ -699,7 +714,7 @@ instantiate_dfun tenv dfun_id pred loc let dfun_rho = substTy (mkTyVarSubst tyvars ty_args) rho (theta, _) = tcSplitPhiTy dfun_rho - ty_app = mkHsTyApp (HsVar dfun_id) ty_args + ty_app = mkHsTyApp (L (instLocSrcSpan loc) (HsVar dfun_id)) ty_args in if null theta then returnM (SimpleInst ty_app) @@ -760,15 +775,15 @@ just use the expression inline. \begin{code} tcSyntaxName :: InstOrigin -> TcType -- Type to instantiate it at - -> (Name, HsExpr Name) -- (Standard name, user name) - -> TcM (Name, TcExpr) -- (Standard name, suitable expression) + -> (Name, LHsExpr Name) -- (Standard name, user name) + -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression) -- NB: tcSyntaxName calls tcExpr, and hence can do unification. -- So we do not call it from lookupInst, which is called from tcSimplify -tcSyntaxName orig ty (std_nm, HsVar user_nm) +tcSyntaxName orig ty (std_nm, L span (HsVar user_nm)) | std_nm == user_nm - = tcStdSyntaxName orig ty std_nm + = addSrcSpan span (tcStdSyntaxName orig ty std_nm) tcSyntaxName orig ty (std_nm, user_nm_expr) = tcLookupId std_nm `thenM` \ std_id -> @@ -783,17 +798,18 @@ tcSyntaxName orig ty (std_nm, user_nm_expr) -- Check that the user-supplied thing has the -- same type as the standard one - tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> + tcCheckSigma user_nm_expr tau1 `thenM` \ expr -> returnM (std_nm, expr) tcStdSyntaxName :: InstOrigin - -> TcType -- Type to instantiate it at - -> Name -- Standard name - -> TcM (Name, TcExpr) -- (Standard name, suitable expression) + -> TcType -- Type to instantiate it at + -> Name -- Standard name + -> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression) tcStdSyntaxName orig ty std_nm = newMethodFromName orig ty std_nm `thenM` \ id -> - returnM (std_nm, HsVar id) + getSrcSpanM `thenM` \ span -> + returnM (std_nm, L span (HsVar id)) syntaxNameCtxt name orig ty tidy_env = getInstLoc orig `thenM` \ inst_loc -> diff --git a/ghc/compiler/typecheck/TcArrows.lhs b/ghc/compiler/typecheck/TcArrows.lhs index eda193a095..5c8c3b5dd5 100644 --- a/ghc/compiler/typecheck/TcArrows.lhs +++ b/ghc/compiler/typecheck/TcArrows.lhs @@ -11,7 +11,7 @@ module TcArrows ( tcProc ) where import {-# SOURCE #-} TcExpr( tcCheckRho ) import HsSyn -import TcHsSyn ( TcCmdTop, TcExpr, TcPat, mkHsLet ) +import TcHsSyn ( mkHsLet ) import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts, TcMatchCtxt(..), tcMatchesCase ) @@ -24,12 +24,12 @@ import TcSimplify ( tcSimplifyCheck ) import TcUnify ( Expected(..), checkSigTyVarsWrt, zapExpectedTo ) import TcRnMonad import Inst ( tcSyntaxName ) +import Name ( Name ) import TysWiredIn ( boolTy, pairTyCon ) import VarSet -import Type ( Kind, - mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes ) -import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedHsCmdTop ) +import Type ( Kind, mkArrowKinds, liftedTypeKind, openTypeKind, tyVarsOfTypes ) +import SrcLoc ( Located(..) ) import Outputable import Util ( lengthAtLeast ) @@ -42,9 +42,9 @@ import Util ( lengthAtLeast ) %************************************************************************ \begin{code} -tcProc :: RenamedPat -> RenamedHsCmdTop -- proc pat -> expr +tcProc :: InPat Name -> LHsCmdTop Name -- proc pat -> expr -> Expected TcRhoType -- Expected type of whole proc expression - -> TcM (TcPat, TcCmdTop) + -> TcM (OutPat TcId, LHsCmdTop TcId) tcProc pat cmd exp_ty = do { arr_ty <- newTyVarTy arrowTyConKind @@ -75,60 +75,65 @@ mkCmdArrTy env t1 t2 = mkAppTys (cmd_arr env) [t1, t2] --------------------------------------- tcCmdTop :: CmdEnv - -> RenamedHsCmdTop - -> (CmdStack, TcTauType) -- Expected result type; always a monotype + -> LHsCmdTop Name + -> (CmdStack, TcTauType) -- Expected result type; always a monotype -- We know exactly how many cmd args are expected, -- albeit perhaps not their types; so we can pass -- in a CmdStack - -> TcM TcCmdTop + -> TcM (LHsCmdTop TcId) -tcCmdTop env (HsCmdTop cmd _ _ names) (cmd_stk, res_ty) - = do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) +tcCmdTop env (L loc (HsCmdTop cmd _ _ names)) (cmd_stk, res_ty) + = addSrcSpan loc $ + do { cmd' <- tcCmd env cmd (cmd_stk, res_ty) ; names' <- mapM (tcSyntaxName ProcOrigin (cmd_arr env)) names - ; return (HsCmdTop cmd' cmd_stk res_ty names') } + ; return (L loc $ HsCmdTop cmd' cmd_stk res_ty names') } ---------------------------------------- -tcCmd :: CmdEnv -> RenamedHsExpr -> (CmdStack, TcTauType) -> TcM TcExpr +tcCmd :: CmdEnv -> LHsExpr Name -> (CmdStack, TcTauType) -> TcM (LHsExpr TcId) -- The main recursive function +tcCmd env (L loc expr) res_ty + = addSrcSpan loc $ do + { expr' <- tc_cmd env expr res_ty + ; return (L loc expr') } -tcCmd env (HsPar cmd) res_ty +tc_cmd env (HsPar cmd) res_ty = do { cmd' <- tcCmd env cmd res_ty ; return (HsPar cmd') } -tcCmd env (HsLet binds body) res_ty - = tcBindsAndThen HsLet binds $ - tcCmd env body res_ty +tc_cmd env (HsLet binds (L body_loc body)) res_ty + = tcBindsAndThen glue binds $ + addSrcSpan body_loc $ + tc_cmd env body res_ty + where + glue binds expr = HsLet [binds] (L body_loc expr) -tcCmd env in_cmd@(HsCase scrut matches src_loc) (stk, res_ty) - = addSrcLoc src_loc $ - addErrCtxt (cmdCtxt in_cmd) $ +tc_cmd env in_cmd@(HsCase scrut matches) (stk, res_ty) + = addErrCtxt (cmdCtxt in_cmd) $ tcMatchesCase match_ctxt matches (Check res_ty) `thenM` \ (scrut_ty, matches') -> addErrCtxt (caseScrutCtxt scrut) ( tcCheckRho scrut scrut_ty ) `thenM` \ scrut' -> - returnM (HsCase scrut' matches' src_loc) + returnM (HsCase scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, mc_body = mc_body } mc_body body (Check res_ty') = tcCmd env body (stk, res_ty') -tcCmd env (HsIf pred b1 b2 src_loc) res_ty - = addSrcLoc src_loc $ - do { pred' <- tcCheckRho pred boolTy +tc_cmd env (HsIf pred b1 b2) res_ty + = do { pred' <- tcCheckRho pred boolTy ; b1' <- tcCmd env b1 res_ty ; b2' <- tcCmd env b2 res_ty - ; return (HsIf pred' b1' b2' src_loc) + ; return (HsIf pred' b1' b2') } ------------------------------------------- -- Arrow application -- (f -< a) or (f =< a) -tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty) - = addSrcLoc src_loc $ - addErrCtxt (cmdCtxt cmd) $ +tc_cmd env cmd@(HsArrApp fun arg _ ho_app lr) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newTyVarTy openTypeKind ; let fun_ty = mkCmdArrTy env arg_ty res_ty @@ -138,7 +143,7 @@ tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty) ; arg' <- tcCheckRho arg arg_ty - ; return (HsArrApp fun' arg' fun_ty ho_app lr src_loc) } + ; return (HsArrApp fun' arg' fun_ty ho_app lr) } where -- Before type-checking f, remove the "arrow binders" from the -- environment in the (-<) case. @@ -151,7 +156,7 @@ tcCmd env cmd@(HsArrApp fun arg _ ho_app lr src_loc) (cmd_stk, res_ty) ------------------------------------------- -- Command application -tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) +tc_cmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) = addErrCtxt (cmdCtxt cmd) $ do { arg_ty <- newTyVarTy openTypeKind @@ -164,9 +169,8 @@ tcCmd env cmd@(HsApp fun arg) (cmd_stk, res_ty) ------------------------------------------- -- Lambda -tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty) - = addSrcLoc (getMatchLoc match) $ - addErrCtxt (matchCtxt match_ctxt match) $ +tc_cmd env cmd@(HsLam (L mtch_loc match@(Match pats maybe_rhs_sig grhss))) (cmd_stk, res_ty) + = addErrCtxt (matchCtxt match_ctxt match) $ do { -- Check the cmd stack is big enough ; checkTc (lengthAtLeast cmd_stk n_pats) @@ -174,10 +178,11 @@ tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty) ; let pats_w_tys = zip pats (map Check cmd_stk) -- Check the patterns, and the GRHSs inside - ; (pats', grhss', ex_binds) <- tcMatchPats pats_w_tys (Check res_ty) $ + ; (pats', grhss', ex_binds) <- addSrcSpan mtch_loc $ + tcMatchPats pats_w_tys (Check res_ty) $ tc_grhss grhss - ; return (HsLam (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss'))) + ; return (HsLam (L mtch_loc (Match pats' Nothing (glueBindsOnGRHSs ex_binds grhss')))) } where @@ -187,25 +192,24 @@ tcCmd env cmd@(HsLam match@(Match pats maybe_rhs_sig grhss)) (cmd_stk, res_ty) tc_grhss (GRHSs grhss binds _) = tcBindsAndThen glueBindsOnGRHSs binds $ - do { grhss' <- mappM tc_grhs grhss - ; return (GRHSs grhss' EmptyBinds res_ty) } + do { grhss' <- mappM (wrapLocM tc_grhs) grhss + ; return (GRHSs grhss' [] res_ty) } stmt_ctxt = SC { sc_what = PatGuard match_ctxt, sc_rhs = tcCheckRho, sc_body = \ body -> tcCmd env body (stk', res_ty), sc_ty = res_ty } -- ToDo: Is this right? - tc_grhs (GRHS guarded locn) - = addSrcLoc locn $ - do { guarded' <- tcStmts stmt_ctxt guarded - ; return (GRHS guarded' locn) } + tc_grhs (GRHS guarded) + = do { guarded' <- tcStmts stmt_ctxt guarded + ; return (GRHS guarded') } ------------------------------------------- -- Do notation -tcCmd env cmd@(HsDo do_or_lc stmts _ ty src_loc) (cmd_stk, res_ty) +tc_cmd env cmd@(HsDo do_or_lc stmts _ ty) (cmd_stk, res_ty) = do { checkTc (null cmd_stk) (nonEmptyCmdStkErr cmd) ; stmts' <- tcStmts stmt_ctxt stmts - ; return (HsDo do_or_lc stmts' [] res_ty src_loc) } + ; return (HsDo do_or_lc stmts' [] res_ty) } -- The 'methods' needed for the HsDo are in the enclosing HsCmd -- hence the empty list here where @@ -228,9 +232,8 @@ tcCmd env cmd@(HsDo do_or_lc stmts _ ty src_loc) (cmd_stk, res_ty) -- ---------------------------------------------- -- G |-a (| e |) c : [t1 .. tn] t -tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty) - = addSrcLoc src_loc $ - addErrCtxt (cmdCtxt cmd) $ +tc_cmd env cmd@(HsArrForm expr fixity cmd_args) (cmd_stk, res_ty) + = addErrCtxt (cmdCtxt cmd) $ do { cmds_w_tys <- mapM new_cmd_ty (cmd_args `zip` [1..]) ; w_tv <- newSigTyVar liftedTypeKind ; let w_ty = mkTyVarTy w_tv @@ -256,13 +259,13 @@ tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty) -- the s1..sm and check each cmd ; cmds' <- mapM (tc_cmd w_tv') cmds_w_tys - ; returnM (HsArrForm (TyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds' src_loc) + ; returnM (HsArrForm (mkHsTyLam [w_tv'] (mkHsLet inst_binds expr')) fixity cmds') } where -- Make the types -- b, ((e,s1) .. sm), s - new_cmd_ty :: (RenamedHsCmdTop, Int) - -> TcM (RenamedHsCmdTop, Int, TcType, TcType, TcType) + new_cmd_ty :: (LHsCmdTop Name, Int) + -> TcM (LHsCmdTop Name, Int, TcType, TcType, TcType) new_cmd_ty (cmd,i) = do { b_ty <- newTyVarTy arrowTyConKind ; tup_ty <- newTyVarTy liftedTypeKind @@ -302,7 +305,7 @@ tcCmd env cmd@(HsArrForm expr fixity cmd_args src_loc) (cmd_stk, res_ty) -- Base case for illegal commands -- This is where expressions that aren't commands get rejected -tcCmd env cmd _ +tc_cmd env cmd _ = failWithTc (vcat [ptext SLIT("The expression"), nest 2 (ppr cmd), ptext SLIT("was found where an arrow command was expected")]) \end{code} @@ -316,8 +319,8 @@ tcCmd env cmd _ \begin{code} -glueBindsOnCmd EmptyBinds cmd = cmd -glueBindsOnCmd binds (HsCmdTop cmd stk res_ty names) = HsCmdTop (HsLet binds cmd) stk res_ty names +glueBindsOnCmd binds (L loc (HsCmdTop cmd stk res_ty names)) + = L loc (HsCmdTop (L loc (HsLet [binds] cmd)) stk res_ty names) -- Existential bindings become local bindings in the command diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 07a0a942f3..bfa394b288 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -12,13 +12,11 @@ import {-# SOURCE #-} TcMatches ( tcGRHSsPat, tcMatchesFun ) import {-# SOURCE #-} TcExpr ( tcCheckSigma, tcCheckRho ) import CmdLineOpts ( DynFlag(Opt_NoMonomorphismRestriction) ) -import HsSyn ( HsExpr(..), HsBinds(..), MonoBinds(..), Sig(..), - Match(..), mkMonoBind, - collectMonoBinders, andMonoBinds, - collectSigTysFromMonoBinds +import HsSyn ( HsExpr(..), HsBind(..), LHsBind, LHsBinds, Sig(..), + LSig, Match(..), HsBindGroup(..), IPBind(..), + collectSigTysFromHsBinds, collectHsBindBinders, ) -import RnHsSyn ( RenamedHsBinds, RenamedSig, RenamedMonoBinds ) -import TcHsSyn ( TcHsBinds, TcMonoBinds, TcId, zonkId, mkHsLet ) +import TcHsSyn ( TcId, zonkId, mkHsLet ) import TcRnMonad import Inst ( InstOrigin(..), newDicts, newIPDict, instToId ) @@ -27,7 +25,7 @@ import TcUnify ( Expected(..), newHole, unifyTauTyLists, checkSigTyVarsWrt, sig import TcSimplify ( tcSimplifyInfer, tcSimplifyInferCheck, tcSimplifyRestricted, tcSimplifyToDicts, tcSimplifyIPs ) import TcHsType ( tcHsSigType, UserTypeCtxt(..), TcSigInfo(..), - tcTySig, maybeSig, tcSigPolyId, tcSigMonoId, tcAddScopedTyVars + tcTySig, maybeSig, tcAddScopedTyVars ) import TcPat ( tcPat, tcSubPat, tcMonoPatBndr ) import TcSimplify ( bindInstsOfLocalFuns ) @@ -44,6 +42,7 @@ import Name ( Name, getSrcLoc ) import NameSet import Var ( tyVarKind ) import VarSet +import SrcLoc ( Located(..), srcLocSpan, unLoc, noLoc ) import Bag import Util ( isIn, equalLength ) import BasicTypes ( TopLevelFlag(..), RecFlag(..), isNonRec, isRec, @@ -85,72 +84,121 @@ At the top-level the LIE is sure to contain nothing but constant dictionaries, which we resolve at the module level. \begin{code} -tcTopBinds :: RenamedHsBinds -> TcM (TcMonoBinds, TcLclEnv) +tcTopBinds :: [HsBindGroup Name] -> TcM (LHsBinds TcId, TcLclEnv) -- Note: returning the TcLclEnv is more than we really -- want. The bit we care about is the local bindings -- and the free type variables thereof tcTopBinds binds = tc_binds_and_then TopLevel glue binds $ getLclEnv `thenM` \ env -> - returnM (EmptyMonoBinds, env) + returnM (emptyBag, env) where -- The top level bindings are flattened into a giant -- implicitly-mutually-recursive MonoBinds - glue binds1 (binds2, env) = (flatten binds1 `AndMonoBinds` binds2, env) - flatten EmptyBinds = EmptyMonoBinds - flatten (b1 `ThenBinds` b2) = flatten b1 `AndMonoBinds` flatten b2 - flatten (MonoBind b _ _) = b - -- Can't have a IPBinds at top level + glue (HsBindGroup binds1 _ _) (binds2, env) = (binds1 `unionBags` binds2, env) + -- Can't have a HsIPBinds at top level tcBindsAndThen - :: (TcHsBinds -> thing -> thing) -- Combinator - -> RenamedHsBinds + :: (HsBindGroup TcId -> thing -> thing) -- Combinator + -> [HsBindGroup Name] -> TcM thing -> TcM thing tcBindsAndThen = tc_binds_and_then NotTopLevel -tc_binds_and_then top_lvl combiner EmptyBinds do_next +tc_binds_and_then top_lvl combiner [] do_next = do_next -tc_binds_and_then top_lvl combiner (MonoBind EmptyMonoBinds sigs is_rec) do_next - = do_next - -tc_binds_and_then top_lvl combiner (ThenBinds b1 b2) do_next - = tc_binds_and_then top_lvl combiner b1 $ - tc_binds_and_then top_lvl combiner b2 $ - do_next +tc_binds_and_then top_lvl combiner (group : groups) do_next + = tc_bind_and_then top_lvl combiner group $ + tc_binds_and_then top_lvl combiner groups do_next -tc_binds_and_then top_lvl combiner (IPBinds binds) do_next - = getLIE do_next `thenM` \ (result, expr_lie) -> - mapAndUnzipM tc_ip_bind binds `thenM` \ (avail_ips, binds') -> +tc_bind_and_then top_lvl combiner (HsIPBinds binds) do_next + = getLIE do_next `thenM` \ (result, expr_lie) -> + mapAndUnzipM (wrapLocSndM tc_ip_bind) binds `thenM` \ (avail_ips, binds') -> -- If the binding binds ?x = E, we must now -- discharge any ?x constraints in expr_lie tcSimplifyIPs avail_ips expr_lie `thenM` \ dict_binds -> - returnM (combiner (IPBinds binds') $ - combiner (mkMonoBind Recursive dict_binds) result) + returnM (combiner (HsIPBinds binds') $ + combiner (HsBindGroup dict_binds [] Recursive) result) where -- I wonder if we should do these one at at time -- Consider ?x = 4 -- ?y = ?x + 1 - tc_ip_bind (ip, expr) - = newTyVarTy openTypeKind `thenM` \ ty -> - getSrcLocM `thenM` \ loc -> - newIPDict (IPBind ip) ip ty `thenM` \ (ip', ip_inst) -> - tcCheckRho expr ty `thenM` \ expr' -> - returnM (ip_inst, (ip', expr')) - -tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next - = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE + tc_ip_bind (IPBind ip expr) + = newTyVarTy openTypeKind `thenM` \ ty -> + newIPDict (IPBindOrigin ip) ip ty `thenM` \ (ip', ip_inst) -> + tcCheckRho expr ty `thenM` \ expr' -> + returnM (ip_inst, (IPBind ip' expr')) + +tc_bind_and_then top_lvl combiner (HsBindGroup binds sigs is_rec) do_next + | isEmptyBag binds + = do_next + | otherwise + = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE + -- Notice that they scope over + -- a) the type signatures in the binding group + -- b) the bindings in the group + -- c) the scope of the binding group (the "in" part) + tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $ + tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> + + case top_lvl of + TopLevel -- For the top level don't bother will all this + -- bindInstsOfLocalFuns stuff. All the top level + -- things are rec'd together anyway, so it's fine to + -- leave them to the tcSimplifyTop, and quite a bit faster too + -- + -- Subtle (and ugly) point: furthermore at top level we + -- return the TcLclEnv, which contains the LIE var; we + -- don't want to return the wrong one! + -> tc_body poly_ids `thenM` \ (prag_binds, thing) -> + returnM (combiner (HsBindGroup + (poly_binds `unionBags` prag_binds) + [] -- no sigs + Recursive) + thing) + + NotTopLevel -- For nested bindings we must do the + -- bindInstsOfLocalFuns thing. We must include + -- the LIE from the RHSs too -- polymorphic recursion! + -> getLIE (tc_body poly_ids) `thenM` \ ((prag_binds, thing), lie) -> + + -- Create specialisations of functions bound here + bindInstsOfLocalFuns lie poly_ids `thenM` \ lie_binds -> + + -- We want to keep non-recursive things non-recursive + -- so that we desugar unlifted bindings correctly + if isRec is_rec then + returnM ( + combiner (HsBindGroup + (poly_binds `unionBags` + lie_binds `unionBags` + prag_binds) + [] Recursive) thing + ) + else + returnM ( + combiner (HsBindGroup poly_binds [] NonRecursive) $ + combiner (HsBindGroup prag_binds [] NonRecursive) $ + combiner (HsBindGroup lie_binds [] Recursive) $ + -- NB: the binds returned by tcSimplify and + -- bindInstsOfLocalFuns aren't guaranteed in + -- dependency order (though we could change + -- that); hence the Recursive marker. + thing) + +{- + = -- BRING ANY SCOPED TYPE VARIABLES INTO SCOPE -- Notice that they scope over -- a) the type signatures in the binding group -- b) the bindings in the group -- c) the scope of the binding group (the "in" part) - tcAddScopedTyVars (collectSigTysFromMonoBinds bind) $ + tcAddScopedTyVars (collectSigTysFromHsBinds (bagToList binds)) $ - tcBindWithSigs top_lvl bind sigs is_rec `thenM` \ (poly_binds, poly_ids) -> + tcBindWithSigs top_lvl binds sigs is_rec `thenM` \ (poly_binds, poly_ids) -> case top_lvl of TopLevel -- For the top level don't bother will all this @@ -162,7 +210,10 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next -- return the TcLclEnv, which contains the LIE var; we -- don't want to return the wrong one! -> tc_body poly_ids `thenM` \ (prag_binds, thing) -> - returnM (combiner (mkMonoBind Recursive (poly_binds `andMonoBinds` prag_binds)) + returnM (combiner (HsBindGroup + (poly_binds `unionBags` prag_binds) + [] -- no sigs + Recursive) thing) NotTopLevel -- For nested bindings we must do teh bindInstsOfLocalFuns thing @@ -175,20 +226,22 @@ tc_binds_and_then top_lvl combiner (MonoBind bind sigs is_rec) do_next -- so that we desugar unlifted bindings correctly if isRec is_rec then returnM ( - combiner (mkMonoBind Recursive ( - poly_binds `andMonoBinds` - lie_binds `andMonoBinds` - prag_binds)) thing + combiner (HsBindGroup ( + poly_binds `unionBags` + lie_binds `unionBags` + prag_binds) + [] Recursive) thing ) else returnM ( - combiner (mkMonoBind NonRecursive poly_binds) $ - combiner (mkMonoBind NonRecursive prag_binds) $ - combiner (mkMonoBind Recursive lie_binds) $ + combiner (HsBindGroup poly_binds [] NonRecursive) $ + combiner (HsBindGroup prag_binds [] NonRecursive) $ + combiner (HsBindGroup lie_binds [] Recursive) $ -- NB: the binds returned by tcSimplify and bindInstsOfLocalFuns -- aren't guaranteed in dependency order (though we could change -- that); hence the Recursive marker. thing) +-} where tc_body poly_ids -- Type check the pragmas and "thing inside" = -- Extend the environment to bind the new polymorphic Ids @@ -222,15 +275,15 @@ so all the clever stuff is in here. \begin{code} tcBindWithSigs :: TopLevelFlag - -> RenamedMonoBinds - -> [RenamedSig] + -> LHsBinds Name + -> [LSig Name] -> RecFlag - -> TcM (TcMonoBinds, [TcId]) + -> TcM (LHsBinds TcId, [TcId]) tcBindWithSigs top_lvl mbind sigs is_rec = -- TYPECHECK THE SIGNATURES recoverM (returnM []) ( - mappM tcTySig [sig | sig@(Sig name _ _) <- sigs] + mappM tcTySig [sig | sig@(L _(Sig name _)) <- sigs] ) `thenM` \ tc_ty_sigs -> -- SET UP THE MAIN RECOVERY; take advantage of any type sigs @@ -241,19 +294,19 @@ tcBindWithSigs top_lvl mbind sigs is_rec newTyVar liftedTypeKind `thenM` \ alpha_tv -> let forall_a_a = mkForAllTy alpha_tv (mkTyVarTy alpha_tv) - binder_names = collectMonoBinders mbind + binder_names = collectHsBindBinders mbind poly_ids = map mk_dummy binder_names mk_dummy name = case maybeSig tc_ty_sigs name of - Just sig -> tcSigPolyId sig -- Signature + Just sig -> sig_poly_id sig -- Signature Nothing -> mkLocalId name forall_a_a -- No signature in traceTc (text "tcBindsWithSigs: error recovery" <+> ppr binder_names) `thenM_` - returnM (EmptyMonoBinds, poly_ids) + returnM (emptyBag, poly_ids) ) $ -- TYPECHECK THE BINDINGS traceTc (ptext SLIT("--------------------------------------------------------")) `thenM_` - traceTc (ptext SLIT("Bindings for") <+> ppr (collectMonoBinders mbind)) `thenM_` + traceTc (ptext SLIT("Bindings for") <+> ppr (collectHsBindBinders mbind)) `thenM_` getLIE (tcMonoBinds mbind tc_ty_sigs is_rec) `thenM` \ ((mbind', bndr_names_w_ids), lie_req) -> let (binder_names, mono_ids) = unzip (bagToList bndr_names_w_ids) @@ -263,7 +316,9 @@ tcBindWithSigs top_lvl mbind sigs is_rec -- GENERALISE -- (it seems a bit crude to have to do getLIE twice, -- but I can't see a better way just now) - addSrcLoc (minimum (map getSrcLoc binder_names)) $ + addSrcSpan (srcLocSpan (minimum (map getSrcLoc binder_names))) $ + -- TODO: location wrong + addErrCtxt (genCtxt binder_names) $ getLIE (generalise binder_names mbind tau_tvs lie_req tc_ty_sigs) `thenM` \ ((tc_tyvars_to_gen, dict_binds, dict_ids), lie_free) -> @@ -292,11 +347,14 @@ tcBindWithSigs top_lvl mbind sigs is_rec poly_ids = [poly_id | (_, poly_id, _) <- exports] dict_tys = map idType zonked_dict_ids - inlines = mkNameSet [name | InlineSig True name _ loc <- sigs] + inlines = mkNameSet [ name + | L _ (InlineSig True (L _ name) _) <- sigs] -- Any INLINE sig (regardless of phase control) -- makes the RHS look small - inline_phases = listToFM [(name, phase) | InlineSig _ name phase _ <- sigs, - not (isAlwaysActive phase)] + + inline_phases = listToFM [ (name, phase) + | L _ (InlineSig _ (L _ name) phase) <- sigs, + not (isAlwaysActive phase)] -- Set the IdInfo field to control the inline phase -- AlwaysActive is the default, so don't bother with them @@ -307,9 +365,8 @@ tcBindWithSigs top_lvl mbind sigs is_rec where (tyvars, poly_id) = case maybeSig tc_ty_sigs binder_name of - Just (TySigInfo sig_poly_id sig_tyvars _ _ _ _ _) -> - (sig_tyvars, sig_poly_id) - Nothing -> (real_tyvars_to_gen, new_poly_id) + Just sig -> (sig_tvs sig, sig_poly_id sig) + Nothing -> (real_tyvars_to_gen, new_poly_id) new_poly_id = mkLocalId binder_name poly_ty poly_ty = mkForAllTys real_tyvars_to_gen @@ -333,21 +390,23 @@ tcBindWithSigs top_lvl mbind sigs is_rec extendLIEs lie_req `thenM_` returnM ( + unitBag $ noLoc $ AbsBinds [] [] exports inlines mbind', -- Do not generate even any x=y bindings poly_ids ) else -- The normal case - extendLIEs lie_free `thenM_` - returnM ( - AbsBinds real_tyvars_to_gen + extendLIEs lie_free `thenM_` + returnM ( + unitBag $ noLoc $ + AbsBinds real_tyvars_to_gen zonked_dict_ids exports inlines - (dict_binds `andMonoBinds` mbind'), - poly_ids - ) + (dict_binds `unionBags` mbind'), + poly_ids + ) attachInlinePhase inline_phases bndr = case lookupFM inline_phases (idName bndr) of @@ -373,15 +432,10 @@ checkUnliftedBinds top_lvl is_rec real_tyvars_to_gen mbind (unliftedBindErr "Top-level" mbind) `thenM_` checkTc (isNonRec is_rec) (unliftedBindErr "Recursive" mbind) `thenM_` - checkTc (single_bind mbind) + checkTc (isSingletonBag mbind) (unliftedBindErr "Multiple" mbind) `thenM_` checkTc (null real_tyvars_to_gen) (unliftedBindErr "Polymorphic" mbind) - - where - single_bind (PatMonoBind _ _ _) = True - single_bind (FunMonoBind _ _ _ _) = True - single_bind other = False \end{code} @@ -488,8 +542,8 @@ generalise binder_names mbind tau_tvs lie_req sigs = returnM (final_qtvs, dict_binds, sig_dicts) where - tysig_names = map (idName . tcSigPolyId) sigs - is_mono_sig (TySigInfo _ _ theta _ _ _ _) = null theta + tysig_names = map (idName . sig_poly_id) sigs + is_mono_sig sig = null (sig_theta sig) doc = ptext SLIT("type signature(s) for") <+> pprBinders binder_names @@ -501,8 +555,9 @@ generalise binder_names mbind tau_tvs lie_req sigs = -- We unify them because, with polymorphic recursion, their types -- might not otherwise be related. This is a rather subtle issue. -- ToDo: amplify -checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs) - = addSrcLoc src_loc $ +checkSigsCtxts sigs@(TySigInfo { sig_poly_id = id1, sig_tvs = sig_tvs, sig_theta = theta1, sig_loc = span} + : other_sigs) + = addSrcSpan span $ mappM_ check_one other_sigs `thenM_` if null theta1 then returnM ([], []) -- Non-overloaded type signatures @@ -517,9 +572,9 @@ checkSigsCtxts sigs@(TySigInfo id1 sig_tvs theta1 _ _ _ src_loc : other_sigs) returnM (sig_avails, map instToId sig_dicts) where sig1_dict_tys = map mkPredTy theta1 - sig_meths = concat [insts | TySigInfo _ _ _ _ _ insts _ <- sigs] + sig_meths = concatMap sig_insts sigs - check_one sig@(TySigInfo id _ theta _ _ _ _) + check_one (TySigInfo {sig_poly_id = id, sig_theta = theta}) = addErrCtxt (sigContextsCtxt id1 id) $ checkTc (equalLength theta theta1) sigContextsErr `thenM_` unifyTauTyLists sig1_dict_tys (map mkPredTy theta) @@ -542,12 +597,11 @@ checkSigsTyVars qtvs sigs in returnM (varSetElems all_tvs) where - check_one (TySigInfo id sig_tyvars sig_theta sig_tau _ _ src_loc) - = addSrcLoc src_loc $ - addErrCtxt (ptext SLIT("In the type signature for") - <+> quotes (ppr id)) $ - addErrCtxtM (sigCtxt id sig_tyvars sig_theta sig_tau) $ - checkSigTyVarsWrt (idFreeTyVars id) sig_tyvars + check_one (TySigInfo {sig_poly_id = id, sig_tvs = tvs, sig_theta = theta, sig_tau = tau}) + = addErrCtxt (ptext SLIT("In the type signature for") + <+> quotes (ppr id)) $ + addErrCtxtM (sigCtxt id tvs theta tau) $ + checkSigTyVarsWrt (idFreeTyVars id) tvs \end{code} @getTyVarsToGen@ decides what type variables to generalise over. @@ -591,21 +645,21 @@ find which tyvars are constrained. \begin{code} isUnRestrictedGroup :: [Name] -- Signatures given for these - -> RenamedMonoBinds + -> LHsBinds Name -> Bool +isUnRestrictedGroup sigs binds = all (unrestricted . unLoc) (bagToList binds) + where + unrestricted (PatBind other _) = False + unrestricted (VarBind v _) = v `is_elem` sigs + unrestricted (FunBind v _ matches) = unrestricted_match matches + || unLoc v `is_elem` sigs + + unrestricted_match (L _ (Match [] _ _) : _) = False + -- No args => like a pattern binding + unrestricted_match other = True + -- Some args => a function binding is_elem v vs = isIn "isUnResMono" v vs - -isUnRestrictedGroup sigs (PatMonoBind other _ _) = False -isUnRestrictedGroup sigs (VarMonoBind v _) = v `is_elem` sigs -isUnRestrictedGroup sigs (FunMonoBind v _ matches _) = isUnRestrictedMatch matches || - v `is_elem` sigs -isUnRestrictedGroup sigs (AndMonoBinds mb1 mb2) = isUnRestrictedGroup sigs mb1 && - isUnRestrictedGroup sigs mb2 -isUnRestrictedGroup sigs EmptyMonoBinds = True - -isUnRestrictedMatch (Match [] _ _ : _) = False -- No args => like a pattern binding -isUnRestrictedMatch other = True -- Some args => a function binding \end{code} @@ -619,9 +673,9 @@ isUnRestrictedMatch other = True -- Some args => a function binding The signatures have been dealt with already. \begin{code} -tcMonoBinds :: RenamedMonoBinds +tcMonoBinds :: LHsBinds Name -> [TcSigInfo] -> RecFlag - -> TcM (TcMonoBinds, + -> TcM (LHsBinds TcId, Bag (Name, -- Bound names TcId)) -- Corresponding monomorphic bound things @@ -631,23 +685,39 @@ tcMonoBinds mbinds tc_ty_sigs is_rec -- the variables in this group (in the recursive case) -- 2. Extend the environment -- 3. Check the RHSs - = tc_mb_pats mbinds `thenM` \ (complete_it, xve) -> + = mapBagM tc_lbind_pats mbinds `thenM` \ bag_of_pairs -> + let + (complete_it, xve) + = foldrBag combine + (returnM (emptyBag, emptyBag), emptyBag) + bag_of_pairs + combine (complete_it1, xve1) (complete_it2, xve2) + = (complete_it, xve1 `unionBags` xve2) + where + complete_it = complete_it1 `thenM` \ (b1, bs1) -> + complete_it2 `thenM` \ (b2, bs2) -> + returnM (b1 `consBag` b2, bs1 `unionBags` bs2) + in tcExtendLocalValEnv2 (bagToList xve) complete_it where - tc_mb_pats EmptyMonoBinds - = returnM (returnM (EmptyMonoBinds, emptyBag), emptyBag) - - tc_mb_pats (AndMonoBinds mb1 mb2) - = tc_mb_pats mb1 `thenM` \ (complete_it1, xve1) -> - tc_mb_pats mb2 `thenM` \ (complete_it2, xve2) -> - let - complete_it = complete_it1 `thenM` \ (mb1', bs1) -> - complete_it2 `thenM` \ (mb2', bs2) -> - returnM (AndMonoBinds mb1' mb2', bs1 `unionBags` bs2) - in - returnM (complete_it, xve1 `unionBags` xve2) - - tc_mb_pats (FunMonoBind name inf matches locn) + tc_lbind_pats :: LHsBind Name + -> TcM (TcM (LHsBind TcId, Bag (Name,TcId)), -- Completer + Bag (Name,TcId)) + -- wrapper for tc_bind_pats to deal with the location stuff + tc_lbind_pats (L loc bind) + = addSrcSpan loc $ do + (tc, bag) <- tc_bind_pats bind + return (wrap tc, bag) + where + wrap tc = addSrcSpan loc $ do + (bind, stuff) <- tc + return (L loc bind, stuff) + + + tc_bind_pats :: HsBind Name + -> TcM (TcM (HsBind TcId, Bag (Name,TcId)), -- Completer + Bag (Name,TcId)) + tc_bind_pats (FunBind (L nm_loc name) inf matches) -- Three cases: -- a) Type sig supplied -- b) No type sig and recursive @@ -657,14 +727,13 @@ tcMonoBinds mbinds tc_ty_sigs is_rec = let -- (a) There is a type signature -- Use it for the environment extension, and check -- the RHS has the appropriate type (with outer for-alls stripped off) - mono_id = tcSigMonoId sig + mono_id = sig_mono_id sig mono_ty = idType mono_id - complete_it = addSrcLoc locn $ - tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> - returnM (FunMonoBind mono_id inf matches' locn, + complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> + returnM (FunBind (L nm_loc mono_id) inf matches', unitBag (name, mono_id)) in - returnM (complete_it, if isRec is_rec then unitBag (name,tcSigPolyId sig) + returnM (complete_it, if isRec is_rec then unitBag (name, sig_poly_id sig) else emptyBag) | isRec is_rec @@ -675,9 +744,8 @@ tcMonoBinds mbinds tc_ty_sigs is_rec newTyVarTy openTypeKind `thenM` \ mono_ty -> let mono_id = mkLocalId mono_name mono_ty - complete_it = addSrcLoc locn $ - tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> - returnM (FunMonoBind mono_id inf matches' locn, + complete_it = tcMatchesFun name matches (Check mono_ty) `thenM` \ matches' -> + returnM (FunBind (L nm_loc mono_id) inf matches', unitBag (name, mono_id)) in returnM (complete_it, unitBag (name, mono_id)) @@ -685,30 +753,26 @@ tcMonoBinds mbinds tc_ty_sigs is_rec | otherwise -- (c) No type signature, and non-recursive = let -- So we can use a 'hole' type to infer a higher-rank type complete_it - = addSrcLoc locn $ - newHole `thenM` \ hole -> + = newHole `thenM` \ hole -> tcMatchesFun name matches (Infer hole) `thenM` \ matches' -> readMutVar hole `thenM` \ fun_ty -> newLocalName name `thenM` \ mono_name -> let mono_id = mkLocalId mono_name fun_ty in - returnM (FunMonoBind mono_id inf matches' locn, + returnM (FunBind (L nm_loc mono_id) inf matches', unitBag (name, mono_id)) in returnM (complete_it, emptyBag) - tc_mb_pats bind@(PatMonoBind pat grhss locn) - = addSrcLoc locn $ - - -- Now typecheck the pattern + tc_bind_pats bind@(PatBind pat grhss) + = -- Now typecheck the pattern -- We do now support binding fresh (not-already-in-scope) scoped -- type variables in the pattern of a pattern binding. -- For example, this is now legal: -- (x::a, y::b) = e -- The type variables are brought into scope in tc_binds_and_then, -- so we don't have to do anything here. - newHole `thenM` \ hole -> tcPat tc_pat_bndr pat (Infer hole) `thenM` \ (pat', tvs, ids, lie_avail) -> readMutVar hole `thenM` \ pat_ty -> @@ -718,10 +782,9 @@ tcMonoBinds mbinds tc_ty_sigs is_rec (existentialExplode bind) `thenM_` let - complete_it = addSrcLoc locn $ - addErrCtxt (patMonoBindsCtxt bind) $ + complete_it = addErrCtxt (patMonoBindsCtxt bind) $ tcGRHSsPat grhss (Check pat_ty) `thenM` \ grhss' -> - returnM (PatMonoBind pat' grhss' locn, ids) + returnM (PatBind pat' grhss', ids) in returnM (complete_it, if isRec is_rec then ids else emptyBag) @@ -730,7 +793,7 @@ tcMonoBinds mbinds tc_ty_sigs is_rec -- as if that type signature had been on the binder as a SigPatIn. -- We check for a type signature; if there is one, we use the mono_id -- from the signature. This is how we make sure the tau part of the - -- signature actually matches the type of the LHS; then tc_mb_pats + -- signature actually matches the type of the LHS; then tc_bind_pats -- ensures the LHS and RHS have the same type tc_pat_bndr name pat_ty @@ -738,11 +801,12 @@ tcMonoBinds mbinds tc_ty_sigs is_rec Nothing -> newLocalName name `thenM` \ bndr_name -> tcMonoPatBndr bndr_name pat_ty - Just sig -> addSrcLoc (getSrcLoc name) $ + Just sig -> addSrcSpan (srcLocSpan (getSrcLoc name)) $ + -- TODO: location wrong tcSubPat (idType mono_id) pat_ty `thenM` \ co_fn -> returnM (co_fn, mono_id) where - mono_id = tcSigMonoId sig + mono_id = sig_mono_id sig \end{code} @@ -788,10 +852,10 @@ a RULE now: {-# SPECIALISE (f::<type) = g #-} \begin{code} -tcSpecSigs :: [RenamedSig] -> TcM TcMonoBinds -tcSpecSigs (SpecSig name poly_ty src_loc : sigs) +tcSpecSigs :: [LSig Name] -> TcM (LHsBinds TcId) +tcSpecSigs (L loc (SpecSig (L nm_loc name) poly_ty) : sigs) = -- SPECIALISE f :: forall b. theta => tau = g - addSrcLoc src_loc $ + addSrcSpan loc $ addErrCtxt (valSpecSigCtxt name poly_ty) $ -- Get and instantiate its alleged specialised type @@ -799,7 +863,7 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) -- Check that f has a more general type, and build a RHS for -- the spec-pragma-id at the same time - getLIE (tcCheckSigma (HsVar name) sig_ty) `thenM` \ (spec_expr, spec_lie) -> + getLIE (tcCheckSigma (L nm_loc (HsVar name)) sig_ty) `thenM` \ (spec_expr, spec_lie) -> -- Squeeze out any Methods (see comments with tcSimplifyToDicts) tcSimplifyToDicts spec_lie `thenM` \ spec_binds -> @@ -809,16 +873,16 @@ tcSpecSigs (SpecSig name poly_ty src_loc : sigs) -- dead-code-eliminate the binding we are really interested in. newLocalName name `thenM` \ spec_name -> let - spec_bind = VarMonoBind (mkSpecPragmaId spec_name sig_ty) + spec_bind = VarBind (mkSpecPragmaId spec_name sig_ty) (mkHsLet spec_binds spec_expr) in -- Do the rest and combine tcSpecSigs sigs `thenM` \ binds_rest -> - returnM (binds_rest `andMonoBinds` spec_bind) + returnM (binds_rest `snocBag` L loc spec_bind) tcSpecSigs (other_sig : sigs) = tcSpecSigs sigs -tcSpecSigs [] = returnM EmptyMonoBinds +tcSpecSigs [] = returnM emptyBag \end{code} %************************************************************************ diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index 6a3af2e4aa..251dc8a249 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -12,22 +12,15 @@ module TcClassDcl ( tcClassSigs, tcClassDecl2, #include "HsVersions.h" -import HsSyn ( TyClDecl(..), Sig(..), MonoBinds(..), HsType(..), - HsExpr(..), HsLit(..), Pat(WildPat), HsTyVarBndr(..), - mkSimpleMatch, andMonoBinds, andMonoBindList, - isPragSig, placeHolderType, mkExplicitHsForAllTy - ) +import HsSyn import BasicTypes ( RecFlag(..), NewOrData(..) ) -import RnHsSyn ( RenamedTyClDecl, RenamedSig, - RenamedClassOpSig, RenamedMonoBinds, - maybeGenericMatch, extractHsTyVars - ) -import RnExpr ( rnExpr ) +import RnHsSyn ( maybeGenericMatch, extractHsTyVars ) +import RnExpr ( rnLExpr ) import RnEnv ( lookupTopBndrRn, lookupImportedName ) -import TcHsSyn ( TcMonoBinds ) import Inst ( Inst, InstOrigin(..), instToId, newDicts, newMethod ) -import TcEnv ( tcLookupClass, tcExtendLocalValEnv2, tcExtendTyVarEnv2, +import TcEnv ( tcLookupLocatedClass, tcExtendLocalValEnv2, + tcExtendTyVarEnv2, InstInfo(..), pprInstInfoDetails, simpleInstInfoTyCon, simpleInstInfoTy, InstBindings(..), newDFunName @@ -52,7 +45,8 @@ import Subst ( substTyWith ) import MkId ( mkDefaultMethodId, mkDictFunId ) import Id ( Id, idType, idName, mkUserLocal, setInlinePragma ) import Name ( Name, NamedThing(..) ) -import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, plusNameEnv ) +import NameEnv ( NameEnv, lookupNameEnv, emptyNameEnv, unitNameEnv, + plusNameEnv, mkNameEnv ) import NameSet ( emptyNameSet, unitNameSet, nameSetToList ) import OccName ( reportIfUnused, mkDefaultMethodOcc ) import RdrName ( RdrName, mkDerivedRdrName ) @@ -65,9 +59,10 @@ import ErrUtils ( dumpIfSet_dyn ) import Util ( count, lengthIs, isSingleton, lengthExceeds ) import Unique ( Uniquable(..) ) import ListSetOps ( equivClassesByUniq, minusList ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, Located(..), srcSpanStart, unLoc, noLoc ) import Maybes ( seqMaybe, isJust, mapCatMaybes ) import List ( partition ) +import Bag import FastString \end{code} @@ -114,8 +109,8 @@ Death to "ExpandingDicts". \begin{code} tcClassSigs :: Name -- Name of the class - -> [RenamedClassOpSig] - -> RenamedMonoBinds + -> [LSig Name] + -> LHsBinds Name -> TcM [TcMethInfo] type TcMethInfo = (Name, DefMeth, Type) -- A temporary intermediate, to communicate @@ -124,35 +119,28 @@ tcClassSigs clas sigs def_methods = do { dm_env <- checkDefaultBinds clas op_names def_methods ; mappM (tcClassSig dm_env) op_sigs } where - op_sigs = [sig | sig@(Sig n _ _) <- sigs] - op_names = [n | sig@(Sig n _ _) <- op_sigs] + op_sigs = [sig | sig@(L _ (Sig _ _)) <- sigs] + op_names = [n | sig@(L _ (Sig (L _ n) _)) <- op_sigs] - -checkDefaultBinds :: Name -> [Name] -> RenamedMonoBinds - -> TcM (NameEnv Bool) + +checkDefaultBinds :: Name -> [Name] -> LHsBinds Name -> TcM (NameEnv Bool) -- Check default bindings -- a) must be for a class op for this class -- b) must be all generic or all non-generic -- and return a mapping from class-op to Bool -- where True <=> it's a generic default method +checkDefaultBinds clas ops binds + = do dm_infos <- mapM (addLocM (checkDefaultBind clas ops)) (bagToList binds) + return (mkNameEnv dm_infos) -checkDefaultBinds clas ops EmptyMonoBinds - = returnM emptyNameEnv - -checkDefaultBinds clas ops (AndMonoBinds b1 b2) - = do { dm_info1 <- checkDefaultBinds clas ops b1 - ; dm_info2 <- checkDefaultBinds clas ops b2 - ; returnM (dm_info1 `plusNameEnv` dm_info2) } - -checkDefaultBinds clas ops (FunMonoBind op _ matches loc) - = addSrcLoc loc $ do - { -- Check that the op is from this class +checkDefaultBind clas ops (FunBind (L _ op) _ matches) + = do { -- Check that the op is from this class checkTc (op `elem` ops) (badMethodErr clas op) -- Check that all the defns ar generic, or none are ; checkTc (all_generic || none_generic) (mixedGenericErr op) - ; returnM (unitNameEnv op all_generic) + ; returnM (op, all_generic) } where n_generic = count (isJust . maybeGenericMatch) matches @@ -161,11 +149,11 @@ checkDefaultBinds clas ops (FunMonoBind op _ matches loc) tcClassSig :: NameEnv Bool -- Info about default methods; - -> RenamedClassOpSig + -> LSig Name -> TcM TcMethInfo -tcClassSig dm_env (Sig op_name op_hs_ty src_loc) - = addSrcLoc src_loc $ do +tcClassSig dm_env (L loc (Sig (L _ op_name) op_hs_ty)) + = addSrcSpan loc $ do { op_ty <- tcHsKindedType op_hs_ty -- Class tyvars already in scope ; let dm = case lookupNameEnv dm_env op_name of Nothing -> NoDefMeth @@ -240,14 +228,14 @@ dfun.Foo.List (generic default methods have by now turned into instance declarations) \begin{code} -tcClassDecl2 :: RenamedTyClDecl -- The class declaration - -> TcM (TcMonoBinds, [Id]) +tcClassDecl2 :: LTyClDecl Name -- The class declaration + -> TcM (LHsBinds Id, [Id]) -tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, - tcdMeths = default_binds, tcdLoc = src_loc}) - = recoverM (returnM (EmptyMonoBinds, [])) $ - addSrcLoc src_loc $ - tcLookupClass class_name `thenM` \ clas -> +tcClassDecl2 (L loc (ClassDecl {tcdLName = class_name, tcdSigs = sigs, + tcdMeths = default_binds})) + = recoverM (returnM (emptyBag, [])) $ + addSrcSpan loc $ + tcLookupLocatedClass class_name `thenM` \ clas -> -- We make a separate binding for each default method. -- At one time I used a single AbsBinds for all of them, thus @@ -259,7 +247,7 @@ tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, -- default methods. Better to make separate AbsBinds for each let (tyvars, _, _, op_items) = classBigSig clas - prags = filter isPragSig sigs + prags = filter (isPragSig.unLoc) sigs tc_dm = tcDefMeth clas tyvars default_binds prags dm_sel_ids = [sel_id | (sel_id, DefMeth) <- op_items] @@ -271,7 +259,7 @@ tcClassDecl2 (ClassDecl {tcdName = class_name, tcdSigs = sigs, -- (If necessary we can fix that, but we don't have a convenient Id to hand.) in mapAndUnzipM tc_dm dm_sel_ids `thenM` \ (defm_binds, dm_ids_s) -> - returnM (andMonoBindList defm_binds, concat dm_ids_s) + returnM (listToBag defm_binds, concat dm_ids_s) tcDefMeth clas tyvars binds_in prags sel_id = lookupTopBndrRn (mkDefMethRdrName sel_id) `thenM` \ dm_name -> @@ -308,9 +296,9 @@ tcDefMeth clas tyvars binds_in prags sel_id [instToId this_dict] [(clas_tyvars', local_dm_id, dm_inst_id)] emptyNameSet -- No inlines (yet) - (dict_binds `andMonoBinds` defm_bind) + (dict_binds `unionBags` defm_bind) in - returnM (full_bind, [local_dm_id]) + returnM (noLoc full_bind, [local_dm_id]) mkDefMethRdrName :: Id -> RdrName mkDefMethRdrName sel_id = mkDerivedRdrName (idName sel_id) mkDefaultMethodOcc @@ -331,7 +319,7 @@ tyvar sets. \begin{code} type MethodSpec = (Id, -- Global selector Id Id, -- Local Id (class tyvars instantiated) - RenamedMonoBinds) -- Binding for the method + LHsBind Name) -- Binding for the method tcMethodBind :: [(TyVar,TcTyVar)] -- Bindings for type environment @@ -343,9 +331,9 @@ tcMethodBind -> TcThetaType -- Available theta; it's just used for the error message -> [Inst] -- Available from context, used to simplify constraints -- from the method body - -> [RenamedSig] -- Pragmas (e.g. inline pragmas) + -> [LSig Name] -- Pragmas (e.g. inline pragmas) -> MethodSpec -- Details of this method - -> TcM TcMonoBinds + -> TcM (LHsBinds Id) tcMethodBind xtve inst_tyvars inst_theta avail_insts prags (sel_id, meth_id, meth_bind) @@ -356,7 +344,7 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags tcExtendTyVarEnv2 xtve ( addErrCtxt (methodCtxt sel_id) $ getLIE $ - tcMonoBinds meth_bind [meth_sig] NonRecursive + tcMonoBinds (unitBag meth_bind) [meth_sig] NonRecursive ) `thenM` \ ((meth_bind,_), meth_lie) -> -- Now do context reduction. We simplify wrt both the local tyvars @@ -368,7 +356,8 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags -- We do this for each method independently to localise error messages let - TySigInfo meth_id meth_tvs meth_theta _ local_meth_id _ _ = meth_sig + TySigInfo { sig_poly_id = meth_id, sig_tvs = meth_tvs, + sig_theta = meth_theta, sig_mono_id = local_meth_id } = meth_sig in addErrCtxtM (sigCtxt sel_id inst_tyvars inst_theta (idType meth_id)) $ newDicts SignatureOrigin meth_theta `thenM` \ meth_dicts -> @@ -385,10 +374,10 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags let sel_name = idName sel_id inline_prags = [ (is_inl, phase) - | InlineSig is_inl name phase _ <- prags, + | L _ (InlineSig is_inl (L _ name) phase) <- prags, name == sel_name ] spec_prags = [ prag - | prag@(SpecSig name _ _) <- prags, + | prag@(L _ (SpecSig (L _ name) _)) <- prags, name == sel_name] -- Attach inline pragmas as appropriate @@ -400,11 +389,11 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags = (meth_id, emptyNameSet) meth_tvs' = take (length meth_tvs) all_tyvars' - poly_meth_bind = AbsBinds meth_tvs' + poly_meth_bind = noLoc $ AbsBinds meth_tvs' (map instToId meth_dicts) [(meth_tvs', final_meth_id, local_meth_id)] inlines - (lie_binds `andMonoBinds` meth_bind) + (lie_binds `unionBags` meth_bind) in -- Deal with specialisation pragmas @@ -415,15 +404,15 @@ tcMethodBind xtve inst_tyvars inst_theta avail_insts prags -- The prag_lie for a SPECIALISE pragma will mention the function itself, -- so we have to simplify them away right now lest they float outwards! bindInstsOfLocalFuns prag_lie [final_meth_id] `thenM` \ spec_binds2 -> - returnM (spec_binds1 `andMonoBinds` spec_binds2) + returnM (spec_binds1 `unionBags` spec_binds2) ) `thenM` \ spec_binds -> - returnM (poly_meth_bind `andMonoBinds` spec_binds) + returnM (poly_meth_bind `consBag` spec_binds) mkMethodBind :: InstOrigin -> Class -> [TcType] -- Class and instance types - -> RenamedMonoBinds -- Method binding (pick the right one from in here) + -> LHsBinds Name -- Method binding (pick the right one from in here) -> ClassOpItem -> TcM (Maybe Inst, -- Method inst MethodSpec) @@ -437,13 +426,15 @@ mkMethodBind origin clas inst_tys meth_binds (sel_id, dm_info) in -- Figure out what method binding to use -- If the user suppplied one, use it, else construct a default one - getSrcLocM `thenM` \ loc -> + getSrcSpanM `thenM` \ loc -> (case find_bind (idName sel_id) meth_name meth_binds of Just user_bind -> returnM user_bind - Nothing -> mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs -> - returnM (FunMonoBind meth_name False -- Not infix decl - [mkSimpleMatch [] rhs placeHolderType loc] loc) - ) `thenM` \ meth_bind -> + Nothing -> + mkDefMethRhs origin clas inst_tys sel_id loc dm_info `thenM` \ rhs -> + -- Not infix decl + returnM (noLoc $ FunBind (noLoc meth_name) False + [mkSimpleMatch [] rhs placeHolderType]) + ) `thenM` \ meth_bind -> returnM (mb_inst, (sel_id, meth_id, meth_bind)) @@ -482,10 +473,11 @@ mkMethId origin clas sel_id inst_tys -- BUT: it can't be a Method any more, because it breaks -- INVARIANT 2 of methods. (See the data decl for Inst.) newUnique `thenM` \ uniq -> - getSrcLocM `thenM` \ loc -> + getSrcSpanM `thenM` \ loc -> let real_tau = mkPhiTy (tail preds) tau - meth_id = mkUserLocal (getOccName sel_id) uniq real_tau loc + meth_id = mkUserLocal (getOccName sel_id) uniq real_tau + (srcSpanStart loc) --TODO in returnM (Nothing, meth_id) @@ -497,7 +489,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc DefMeth lookupImportedName (mkDefMethRdrName sel_id) `thenM` \ dm_name -> -- Might not be imported, but will be an OrigName traceRn (text "mkDefMeth" <+> ppr dm_name) `thenM_` - returnM (HsVar dm_name) + returnM (nlHsVar dm_name) mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth = -- No default method @@ -509,9 +501,9 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth (omittedMethodWarn sel_id) `thenM_` returnM error_rhs where - error_rhs = HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType loc) - simple_rhs = HsApp (HsVar (getName nO_METHOD_BINDING_ERROR_ID)) - (HsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg)))) + error_rhs = noLoc $ HsLam (mkSimpleMatch wild_pats simple_rhs placeHolderType) + simple_rhs = nlHsApp (nlHsVar (getName nO_METHOD_BINDING_ERROR_ID)) + (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 error_msg)))) error_msg = showSDoc (hcat [ppr loc, text "|", ppr sel_id ]) -- When the type is of form t1 -> t2 -> t3 @@ -532,7 +524,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc NoDefMeth -- Need two splits because the selector can have a type like -- forall a. Foo a => forall b. Eq b => ... (arg_tys, _) = tcSplitFunTys tau2 - wild_pats = [WildPat placeHolderType | ty <- arg_tys] + wild_pats = [wildPat | ty <- arg_tys] mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth = -- A generic default method @@ -552,7 +544,7 @@ mkDefMethRhs origin clas inst_tys sel_id loc GenDefMeth nest 2 (ppr sel_id <+> equals <+> ppr rhs)])) -- Rename it before returning it - ; (rn_rhs, _) <- rnExpr rhs + ; (rn_rhs, _) <- rnLExpr rhs ; returnM rn_rhs } where rhs = mkGenericRhs sel_id clas_tyvar tycon @@ -577,11 +569,12 @@ isInstDecl ClassDeclOrigin = False \begin{code} -- The renamer just puts the selector ID as the binder in the method binding -- but we must use the method name; so we substitute it here. Crude but simple. -find_bind sel_name meth_name (FunMonoBind op_name fix matches loc) - | op_name == sel_name = Just (FunMonoBind meth_name fix matches loc) -find_bind sel_name meth_name (AndMonoBinds b1 b2) - = find_bind sel_name meth_name b1 `seqMaybe` find_bind sel_name meth_name b2 -find_bind sel_name meth_name other = Nothing -- Default case +find_bind sel_name meth_name binds + = foldlBag seqMaybe Nothing (mapBag f binds) + where + f (L loc1 (FunBind (L loc2 op_name) fix matches)) | op_name == sel_name + = Just (L loc1 (FunBind (L loc2 meth_name) fix matches)) + f _other = Nothing \end{code} @@ -616,7 +609,7 @@ gives rise to the instance declarations \begin{code} -getGenericInstances :: [RenamedTyClDecl] -> TcM [InstInfo] +getGenericInstances :: [LTyClDecl Name] -> TcM [InstInfo] getGenericInstances class_decls = do { gen_inst_infos <- mappM get_generics class_decls ; let { gen_inst_info = concat gen_inst_infos } @@ -631,21 +624,22 @@ getGenericInstances class_decls (vcat (map pprInstInfoDetails gen_inst_info))) ; returnM gen_inst_info }} -get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdLoc = loc}) +get_generics decl@(L loc (ClassDecl {tcdLName = class_name, tcdMeths = def_methods})) | null generic_binds = returnM [] -- The comon case: no generic default methods | otherwise -- A source class decl with generic default methods = recoverM (returnM []) $ tcAddDeclCtxt decl $ - tcLookupClass class_name `thenM` \ clas -> + tcLookupLocatedClass class_name `thenM` \ clas -> -- Group by type, and -- make an InstInfo out of each group let - groups = groupWith andMonoBindList generic_binds + groups = groupWith listToBag generic_binds in - mappM (mkGenericInstance clas loc) groups `thenM` \ inst_infos -> + mappM (mkGenericInstance clas (srcSpanStart loc)) groups + `thenM` \ inst_infos -> -- Check that there is only one InstInfo for each type constructor -- The main way this can fail is if you write @@ -670,22 +664,22 @@ get_generics decl@(ClassDecl {tcdName = class_name, tcdMeths = def_methods, tcdL returnM inst_infos where - generic_binds :: [(HsType Name, RenamedMonoBinds)] + generic_binds :: [(HsType Name, LHsBind Name)] generic_binds = getGenericBinds def_methods --------------------------------- -getGenericBinds :: RenamedMonoBinds -> [(HsType Name, RenamedMonoBinds)] +getGenericBinds :: LHsBinds Name -> [(HsType Name, LHsBind Name)] -- Takes a group of method bindings, finds the generic ones, and returns -- them in finite map indexed by the type parameter in the definition. +getGenericBinds binds = concat (map getGenericBind (bagToList binds)) -getGenericBinds EmptyMonoBinds = [] -getGenericBinds (AndMonoBinds m1 m2) = getGenericBinds m1 ++ getGenericBinds m2 - -getGenericBinds (FunMonoBind id infixop matches loc) +getGenericBind (L loc (FunBind id infixop matches)) = groupWith wrap (mapCatMaybes maybeGenericMatch matches) where - wrap ms = FunMonoBind id infixop ms loc + wrap ms = L loc (FunBind id infixop ms) +getGenericBind _ + = [] groupWith :: ([a] -> b) -> [(HsType Name, a)] -> [(HsType Name, b)] groupWith op [] = [] @@ -695,20 +689,23 @@ groupWith op ((t,v):prs) = (t, op (v:vs)) : groupWith op rest (this,rest) = partition same_t prs same_t (t',v) = t `eqPatType` t' +eqPatLType :: LHsType Name -> LHsType Name -> Bool +eqPatLType t1 t2 = unLoc t1 `eqPatType` unLoc t2 + eqPatType :: HsType Name -> HsType Name -> Bool -- A very simple equality function, only for -- type patterns in generic function definitions. eqPatType (HsTyVar v1) (HsTyVar v2) = v1==v2 -eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 -eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatType` s2 && t2 `eqPatType` t2 && op1 == op2 +eqPatType (HsAppTy s1 t1) (HsAppTy s2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 +eqPatType (HsOpTy s1 op1 t1) (HsOpTy s2 op2 t2) = s1 `eqPatLType` s2 && t2 `eqPatLType` t2 && unLoc op1 == unLoc op2 eqPatType (HsNumTy n1) (HsNumTy n2) = n1 == n2 -eqPatType (HsParTy t1) t2 = t1 `eqPatType` t2 -eqPatType t1 (HsParTy t2) = t1 `eqPatType` t2 +eqPatType (HsParTy t1) t2 = unLoc t1 `eqPatType` t2 +eqPatType t1 (HsParTy t2) = t1 `eqPatType` unLoc t2 eqPatType _ _ = False --------------------------------- mkGenericInstance :: Class -> SrcLoc - -> (HsType Name, RenamedMonoBinds) + -> (HsType Name, LHsBinds Name) -> TcM InstInfo mkGenericInstance clas loc (hs_ty, binds) @@ -719,8 +716,8 @@ mkGenericInstance clas loc (hs_ty, binds) -- and wrap them as forall'd tyvars, so that kind inference -- works in the standard way let - sig_tvs = map UserTyVar (nameSetToList (extractHsTyVars hs_ty)) - hs_forall_ty = mkExplicitHsForAllTy sig_tvs [] hs_ty + sig_tvs = map (noLoc.UserTyVar) (nameSetToList (extractHsTyVars (noLoc hs_ty))) + hs_forall_ty = noLoc $ mkExplicitHsForAllTy sig_tvs (noLoc []) (noLoc hs_ty) in -- Type-check the instance type, and check its form tcHsSigType GenPatCtxt hs_forall_ty `thenM` \ forall_inst_ty -> @@ -748,8 +745,8 @@ mkGenericInstance clas loc (hs_ty, binds) %************************************************************************ \begin{code} -tcAddDeclCtxt decl thing_inside - = addSrcLoc (tcdLoc decl) $ +tcAddDeclCtxt (L loc decl) thing_inside + = addSrcSpan loc $ addErrCtxt ctxt $ thing_inside where diff --git a/ghc/compiler/typecheck/TcDefaults.lhs b/ghc/compiler/typecheck/TcDefaults.lhs index 5db1537687..78c92b06e8 100644 --- a/ghc/compiler/typecheck/TcDefaults.lhs +++ b/ghc/compiler/typecheck/TcDefaults.lhs @@ -8,7 +8,7 @@ module TcDefaults ( tcDefaults ) where #include "HsVersions.h" -import HsSyn ( DefaultDecl(..) ) +import HsSyn ( DefaultDecl(..), LDefaultDecl ) import Name ( Name ) import TcRnMonad import TcEnv ( tcLookupClass ) @@ -16,11 +16,12 @@ import TcHsType ( tcHsSigType, UserTypeCtxt( DefaultDeclCtxt ) ) import TcSimplify ( tcSimplifyDefault ) import TcType ( Type, mkClassPred, isTauTy ) import PrelNames ( numClassName ) +import SrcLoc ( Located(..) ) import Outputable \end{code} \begin{code} -tcDefaults :: [DefaultDecl Name] +tcDefaults :: [LDefaultDecl Name] -> TcM (Maybe [Type]) -- Defaulting types to heave -- into Tc monad for later use -- in Disambig. @@ -37,11 +38,11 @@ tcDefaults [] -- one group, only for the next group to ignore them and install -- defaultDefaultTys -tcDefaults [DefaultDecl [] locn] +tcDefaults [L locn (DefaultDecl [])] = returnM (Just []) -- Default declaration specifying no types -tcDefaults [DefaultDecl mono_tys locn] - = addSrcLoc locn $ +tcDefaults [L locn (DefaultDecl mono_tys)] + = addSrcSpan locn $ addErrCtxt defaultDeclCtxt $ tcLookupClass numClassName `thenM` \ num_class -> mappM tc_default_ty mono_tys `thenM` \ tau_tys -> @@ -52,8 +53,8 @@ tcDefaults [DefaultDecl mono_tys locn] returnM (Just tau_tys) -tcDefaults decls@(DefaultDecl _ loc : _) = - addSrcLoc loc $ +tcDefaults decls@(L locn (DefaultDecl _) : _) = + addSrcSpan locn $ failWithTc (dupDefaultDeclErr decls) @@ -66,11 +67,11 @@ defaultDeclCtxt = ptext SLIT("when checking that each type in a default declara $$ ptext SLIT("is an instance of class Num") -dupDefaultDeclErr (DefaultDecl _ locn1 : dup_things) +dupDefaultDeclErr (L _ (DefaultDecl _) : dup_things) = hang (ptext SLIT("Multiple default declarations")) 4 (vcat (map pp dup_things)) where - pp (DefaultDecl _ locn) = ptext SLIT("here was another default declaration") <+> ppr locn + pp (L locn (DefaultDecl _)) = ptext SLIT("here was another default declaration") <+> ppr locn polyDefErr ty = hang (ptext SLIT("Illegal polymorphic type in default declaration") <> colon) 4 (ppr ty) diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 1d23c7bd95..85f0688b95 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -10,10 +10,7 @@ module TcDeriv ( tcDeriving ) where #include "HsVersions.h" -import HsSyn ( HsBinds(..), TyClDecl(..), MonoBinds(..), - andMonoBindList ) -import RdrHsSyn ( RdrNameMonoBinds ) -import RnHsSyn ( RenamedHsBinds, RenamedTyClDecl, RenamedHsPred ) +import HsSyn import CmdLineOpts ( DynFlag(..) ) import Generics ( mkTyConGenericBinds ) @@ -27,10 +24,10 @@ import InstEnv ( simpleDFunClassTyCon, extendInstEnv ) import TcHsType ( tcHsPred ) import TcSimplify ( tcSimplifyDeriv ) -import RnBinds ( rnMethodBinds, rnTopMonoBinds ) +import RnBinds ( rnMethodBinds, rnTopBinds ) import RnEnv ( bindLocalNames ) import TcRnMonad ( thenM, returnM, mapAndUnzipM ) -import HscTypes ( DFunId, FixityEnv, typeEnvTyCons ) +import HscTypes ( DFunId, FixityEnv ) import BasicTypes ( NewOrData(..) ) import Class ( className, classArity, classKey, classTyVars, classSCTheta, Class ) @@ -39,6 +36,7 @@ import ErrUtils ( dumpIfSet_dyn ) import MkId ( mkDictFunId ) import DataCon ( dataConOrigArgTys, isNullaryDataCon, isExistentialDataCon ) import Maybes ( catMaybes ) +import RdrName ( RdrName ) import Name ( Name, getSrcLoc ) import NameSet ( NameSet, emptyNameSet, duDefs ) import Unique ( Unique, getUnique ) @@ -54,9 +52,11 @@ import TcType ( TcType, ThetaType, mkTyVarTy, mkTyVarTys, mkTyConApp, import Var ( TyVar, tyVarKind, idType, varName ) import VarSet ( mkVarSet, subVarSet ) import PrelNames +import SrcLoc ( srcLocSpan, Located(..) ) import Util ( zipWithEqual, sortLt, notNull ) import ListSetOps ( removeDups, assoc ) import Outputable +import Bag \end{code} %************************************************************************ @@ -193,13 +193,13 @@ version. So now all classes are "offending". %************************************************************************ \begin{code} -tcDeriving :: [RenamedTyClDecl] -- All type constructors +tcDeriving :: [LTyClDecl Name] -- All type constructors -> TcM ([InstInfo], -- The generated "instance decls" - RenamedHsBinds, -- Extra generated top-level bindings + [HsBindGroup Name], -- Extra generated top-level bindings NameSet) -- Binders to keep alive tcDeriving tycl_decls - = recoverM (returnM ([], EmptyBinds, emptyNameSet)) $ + = recoverM (returnM ([], [], emptyNameSet)) $ do { -- Fish the "deriving"-related information out of the TcEnv -- and make the necessary "equations". ; (ordinary_eqns, newtype_inst_info) <- makeDerivEqns tycl_decls @@ -219,9 +219,9 @@ tcDeriving tycl_decls -- which is used in the generic binds ; (rn_binds, gen_bndrs) <- discardWarnings $ setOptM Opt_GlasgowExts $ do - { (rn_deriv, _dus1) <- rnTopMonoBinds deriv_binds [] - ; (rn_gen, dus_gen) <- rnTopMonoBinds gen_binds [] - ; return (rn_deriv `ThenBinds` rn_gen, duDefs dus_gen) } + { (rn_deriv, _dus1) <- rnTopBinds deriv_binds [] + ; (rn_gen, dus_gen) <- rnTopBinds gen_binds [] + ; return (rn_deriv ++ rn_gen, duDefs dus_gen) } ; dflags <- getDOpts @@ -231,13 +231,13 @@ tcDeriving tycl_decls ; returnM (inst_info, rn_binds, gen_bndrs) } where - ddump_deriving :: [InstInfo] -> RenamedHsBinds -> SDoc + ddump_deriving :: [InstInfo] -> [HsBindGroup Name] -> SDoc ddump_deriving inst_infos extra_binds - = vcat (map pprInstInfoDetails inst_infos) $$ ppr extra_binds + = vcat (map pprInstInfoDetails inst_infos) $$ vcat (map ppr extra_binds) ----------------------------------------- deriveOrdinaryStuff [] -- Short cut - = returnM ([], EmptyMonoBinds) + = returnM ([], emptyBag) deriveOrdinaryStuff eqns = do { -- Take the equation list and solve it, to deliver a list of @@ -254,13 +254,17 @@ deriveOrdinaryStuff eqns ; extra_binds <- genTaggeryBinds new_dfuns -- Done - ; returnM (inst_infos, andMonoBindList (extra_binds : aux_binds_s)) } + ; returnM (inst_infos, unionManyBags (extra_binds : aux_binds_s)) + } ----------------------------------------- mkGenericBinds tycl_decls - = do { tcs <- mapM tcLookupTyCon [tc_name | TyData { tcdName = tc_name } <- tycl_decls] + = do { tcs <- mapM tcLookupTyCon + [ tc_name | + L _ (TyData { tcdLName = L _ tc_name }) <- tycl_decls] -- We are only interested in the data type declarations - ; return (andMonoBindList [mkTyConGenericBinds tc | tc <- tcs, tyConHasGenerics tc]) } + ; return (unionManyBags [ mkTyConGenericBinds tc | + tc <- tcs, tyConHasGenerics tc ]) } -- And then only in the ones whose 'has-generics' flag is on \end{code} @@ -287,7 +291,7 @@ or} has just one data constructor (e.g., tuples). all those. \begin{code} -makeDerivEqns :: [RenamedTyClDecl] +makeDerivEqns :: [LTyClDecl Name] -> TcM ([DerivEqn], -- Ordinary derivings [InstInfo]) -- Special newtype derivings @@ -296,21 +300,22 @@ makeDerivEqns tycl_decls returnM (catMaybes maybe_ordinaries, catMaybes maybe_newtypes) where ------------------------------------------------------------------ - derive_these :: [(NewOrData, Name, RenamedHsPred)] + derive_these :: [(NewOrData, Name, LHsPred Name)] -- Find the (nd, TyCon, Pred) pairs that must be `derived' -- NB: only source-language decls have deriving, no imported ones do derive_these = [ (nd, tycon, pred) - | TyData {tcdND = nd, tcdName = tycon, tcdDerivs = Just preds} <- tycl_decls, + | L _ (TyData { tcdND = nd, tcdLName = L _ tycon, + tcdDerivs = Just (L _ preds) }) <- tycl_decls, pred <- preds ] ------------------------------------------------------------------ - mk_eqn :: (NewOrData, Name, RenamedHsPred) -> TcM (Maybe DerivEqn, Maybe InstInfo) + mk_eqn :: (NewOrData, Name, LHsPred Name) -> TcM (Maybe DerivEqn, Maybe InstInfo) -- We swizzle the tyvars and datacons out of the tycon -- to make the rest of the equation mk_eqn (new_or_data, tycon_name, pred) = tcLookupTyCon tycon_name `thenM` \ tycon -> - addSrcLoc (getSrcLoc tycon) $ + addSrcSpan (srcLocSpan (getSrcLoc tycon)) $ addErrCtxt (derivCtxt Nothing tycon) $ tcExtendTyVarEnv (tyConTyVars tycon) $ -- Deriving preds may (now) mention -- the type variables for the type constructor @@ -665,7 +670,7 @@ solveDerivEqns orig_eqns ------------------------------------------------------------------ gen_soln (_, clas, tc,tyvars,deriv_rhs) - = addSrcLoc (getSrcLoc tc) $ + = addSrcSpan (srcLocSpan (getSrcLoc tc)) $ addErrCtxt (derivCtxt (Just clas) tc) $ tcSimplifyDeriv tyvars deriv_rhs `thenM` \ theta -> returnM (sortLt (<) theta) -- Canonicalise before returning the soluction @@ -739,17 +744,17 @@ Much less often (really just for deriving @Ix@), we use a \item We use the renamer!!! Reason: we're supposed to be -producing @RenamedMonoBinds@ for the methods, but that means +producing @LHsBinds Name@ for the methods, but that means producing correctly-uniquified code on the fly. This is entirely possible (the @TcM@ monad has a @UniqueSupply@), but it is painful. -So, instead, we produce @RdrNameMonoBinds@ then heave 'em through +So, instead, we produce @MonoBinds RdrName@ then heave 'em through the renamer. What a great hack! \end{itemize} \begin{code} -- Generate the InstInfo for the required instance, -- plus any auxiliary bindings required -genInst :: DFunId -> TcM (InstInfo, RdrNameMonoBinds) +genInst :: DFunId -> TcM (InstInfo, LHsBinds RdrName) genInst dfun = getFixityEnv `thenM` \ fix_env -> let @@ -768,7 +773,7 @@ genInst dfun returnM (InstInfo { iDFunId = dfun, iBinds = VanillaInst rn_meth_binds [] }, aux_binds) -gen_list :: [(Unique, FixityEnv -> TyCon -> (RdrNameMonoBinds, RdrNameMonoBinds))] +gen_list :: [(Unique, FixityEnv -> TyCon -> (LHsBinds RdrName, LHsBinds RdrName))] gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds)) ,(ordClassKey, no_aux_binds (ignore_fix_env gen_Ord_binds)) ,(enumClassKey, no_aux_binds (ignore_fix_env gen_Enum_binds)) @@ -782,7 +787,7 @@ gen_list = [(eqClassKey, no_aux_binds (ignore_fix_env gen_Eq_binds)) -- no_aux_binds is used for generators that don't -- need to produce any auxiliary bindings -no_aux_binds f fix_env tc = (f fix_env tc, EmptyMonoBinds) +no_aux_binds f fix_env tc = (f fix_env tc, emptyBag) ignore_fix_env f fix_env tc = f tc \end{code} @@ -820,11 +825,11 @@ We're deriving @Enum@, or @Ix@ (enum type only???) If we have a @tag2con@ function, we also generate a @maxtag@ constant. \begin{code} -genTaggeryBinds :: [DFunId] -> TcM RdrNameMonoBinds +genTaggeryBinds :: [DFunId] -> TcM (LHsBinds RdrName) genTaggeryBinds dfuns = do { names_so_far <- foldlM do_con2tag [] tycons_of_interest ; nm_alist_etc <- foldlM do_tag2con names_so_far tycons_of_interest - ; return (andMonoBindList (map gen_tag_n_con_monobind nm_alist_etc)) } + ; return (listToBag (map gen_tag_n_con_monobind nm_alist_etc)) } where all_CTs = map simpleDFunClassTyCon dfuns all_tycons = map snd all_CTs diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 466819929a..5b760ac77c 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -10,8 +10,10 @@ module TcEnv( -- Global environment tcExtendGlobalEnv, tcExtendGlobalValEnv, - tcLookupGlobal, + tcLookupLocatedGlobal, tcLookupGlobal, tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon, + tcLookupLocatedGlobalId, tcLookupLocatedTyCon, + tcLookupLocatedClass, tcLookupLocatedDataCon, getInGlobalScope, @@ -19,7 +21,7 @@ module TcEnv( tcExtendTyVarKindEnv, tcExtendTyVarEnv, tcExtendTyVarEnv2, tcExtendLocalValEnv, tcExtendLocalValEnv2, - tcLookup, tcLookupLocalIds, + tcLookup, tcLookupLocated, tcLookupLocalIds, tcLookupId, tcLookupTyVar, lclEnvElts, getInLocalScope, findGlobals, @@ -44,8 +46,8 @@ module TcEnv( #include "HsVersions.h" -import RnHsSyn ( RenamedMonoBinds, RenamedSig ) -import HsSyn ( RuleDecl(..), , HsTyVarBndr(..) ) +import HsSyn ( LRuleDecl, , HsTyVarBndr(..), LHsTyVarBndr, LHsBinds, + LSig ) import TcIface ( tcImportDecl ) import TcRnMonad import TcMType ( zonkTcType, zonkTcTyVar, zonkTcTyVarsAndFV ) @@ -63,16 +65,14 @@ import RdrName ( extendLocalRdrEnv ) import DataCon ( DataCon ) import TyCon ( TyCon ) import Class ( Class ) -import Name ( Name, NamedThing(..), - getSrcLoc, mkInternalName, nameIsLocalOrFrom - ) +import Name ( Name, NamedThing(..), getSrcLoc, mkInternalName, nameIsLocalOrFrom ) import NameEnv import OccName ( mkDFunOcc, occNameString ) import HscTypes ( DFunId, extendTypeEnvList, lookupType, TyThing(..), tyThingId, tyThingTyCon, tyThingClass, tyThingDataCon, ExternalPackageState(..) ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcLoc, Located(..) ) import Outputable import Maybe ( isJust ) \end{code} @@ -84,9 +84,17 @@ import Maybe ( isJust ) %* * %************************************************************************ +Using the Located versions (eg. tcLookupLocatedGlobal) is preferred, +unless you know that the SrcSpan in the monad is already set to the +span of the Name. + \begin{code} -tcLookupGlobal :: Name -> TcM TyThing +tcLookupLocatedGlobal :: Located Name -> TcM TyThing -- c.f. IfaceEnvEnv.tcIfaceGlobal +tcLookupLocatedGlobal name + = addLocM tcLookupGlobal name + +tcLookupGlobal :: Name -> TcM TyThing tcLookupGlobal name = do { env <- getGblEnv ; if nameIsLocalOrFrom (tcg_mod env) name @@ -120,13 +128,25 @@ tcLookupDataCon con_name tcLookupClass :: Name -> TcM Class tcLookupClass name - = tcLookupGlobal name `thenM` \ thing -> + = tcLookupGlobal name `thenM` \ thing -> return (tyThingClass thing) tcLookupTyCon :: Name -> TcM TyCon tcLookupTyCon name - = tcLookupGlobal name `thenM` \ thing -> + = tcLookupGlobal name `thenM` \ thing -> return (tyThingTyCon thing) + +tcLookupLocatedGlobalId :: Located Name -> TcM Id +tcLookupLocatedGlobalId = addLocM tcLookupId + +tcLookupLocatedDataCon :: Located Name -> TcM DataCon +tcLookupLocatedDataCon = addLocM tcLookupDataCon + +tcLookupLocatedClass :: Located Name -> TcM Class +tcLookupLocatedClass = addLocM tcLookupClass + +tcLookupLocatedTyCon :: Located Name -> TcM TyCon +tcLookupLocatedTyCon = addLocM tcLookupTyCon \end{code} %************************************************************************ @@ -188,6 +208,9 @@ tcExtendRecEnv gbl_stuff lcl_stuff thing_inside %************************************************************************ \begin{code} +tcLookupLocated :: Located Name -> TcM TcTyThing +tcLookupLocated = addLocM tcLookup + tcLookup :: Name -> TcM TcTyThing tcLookup name = getLclEnv `thenM` \ local_env -> @@ -238,14 +261,14 @@ getInLocalScope = getLclEnv `thenM` \ env -> \end{code} \begin{code} -tcExtendTyVarKindEnv :: [HsTyVarBndr Name] -> TcM r -> TcM r +tcExtendTyVarKindEnv :: [LHsTyVarBndr Name] -> TcM r -> TcM r -- The tyvars are all kinded tcExtendTyVarKindEnv tvs thing_inside = updLclEnv upd thing_inside where upd lcl_env = lcl_env { tcl_env = extend (tcl_env lcl_env) } extend env = extendNameEnvList env [(n, ATyVar (mkTyVar n k)) - | KindedTyVar n k <- tvs] + | L _ (KindedTyVar n k) <- tvs] -- No need to extend global tyvars for kind checking tcExtendTyVarEnv :: [TyVar] -> TcM r -> TcM r @@ -400,7 +423,7 @@ tcGetGlobalTyVars %************************************************************************ \begin{code} -tcExtendRules :: [RuleDecl Id] -> TcM a -> TcM a +tcExtendRules :: [LRuleDecl Id] -> TcM a -> TcM a -- Just pop the new rules into the EPS and envt resp -- All the rules come from an interface file, not soruce -- Nevertheless, some may be for this module, if we read @@ -566,8 +589,8 @@ data InstInfo data InstBindings = VanillaInst -- The normal case - RenamedMonoBinds -- Bindings - [RenamedSig] -- User pragmas recorded for generating + (LHsBinds Name) -- Bindings + [LSig Name] -- User pragmas recorded for generating -- specialised instances | NewTypeDerived -- Used for deriving instances of newtypes, where the diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot-5 b/ghc/compiler/typecheck/TcExpr.hi-boot-5 index 017d27d4c8..14714cd2f6 100644 --- a/ghc/compiler/typecheck/TcExpr.hi-boot-5 +++ b/ghc/compiler/typecheck/TcExpr.hi-boot-5 @@ -1,14 +1,16 @@ __interface TcExpr 1 0 where __export TcExpr tcCheckSigma tcCheckRho tcMonoExpr ; 1 tcCheckSigma :: - RnHsSyn.RenamedHsExpr + HsExpr.LHsExpr Name.Name -> TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr ; + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) ; + 1 tcCheckRho :: - RnHsSyn.RenamedHsExpr + HsExpr.LHsExpr Name.Name -> TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr ; + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) ; + 1 tcMonoExpr :: - RnHsSyn.RenamedHsExpr + HsExpr.LHsExpr Name.Name -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr ; + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) ; diff --git a/ghc/compiler/typecheck/TcExpr.hi-boot-6 b/ghc/compiler/typecheck/TcExpr.hi-boot-6 index 8be65cd527..f5d0d50e51 100644 --- a/ghc/compiler/typecheck/TcExpr.hi-boot-6 +++ b/ghc/compiler/typecheck/TcExpr.hi-boot-6 @@ -1,16 +1,16 @@ module TcExpr where tcCheckSigma :: - RnHsSyn.RenamedHsExpr + HsExpr.LHsExpr Name.Name -> TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) tcCheckRho :: - RnHsSyn.RenamedHsExpr + HsExpr.LHsExpr Name.Name -> TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) tcMonoExpr :: - RnHsSyn.RenamedHsExpr + HsExpr.LHsExpr Name.Name -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index 6ea75a27d6..60226de6e7 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -12,14 +12,14 @@ module TcExpr ( tcCheckSigma, tcCheckRho, tcInferRho, tcMonoExpr ) where import {-# SOURCE #-} TcSplice( tcSpliceExpr, tcBracket ) import Id ( Id ) import TcType ( isTauTy ) -import TcEnv ( tcMetaTy, checkWellStaged ) +import TcEnv ( checkWellStaged ) import qualified DsMeta #endif -import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), recBindFields, - HsMatchContext(..) ) -import RnHsSyn ( RenamedHsExpr, RenamedRecordBinds ) -import TcHsSyn ( TcExpr, TcRecordBinds, hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) +import HsSyn ( HsExpr(..), LHsExpr, HsLit(..), ArithSeqInfo(..), recBindFields, + HsMatchContext(..), HsRecordBinds, mkHsApp, nlHsVar, + nlHsApp ) +import TcHsSyn ( hsLitType, mkHsDictApp, mkHsTyApp, (<$>) ) import TcRnMonad import TcUnify ( Expected(..), newHole, zapExpectedType, zapExpectedTo, tcSubExp, tcGen, unifyFunTy, zapToListTy, zapToPArrTy, zapToTupleTy ) @@ -30,8 +30,8 @@ import Inst ( InstOrigin(..), instToId, tcInstCall, tcInstDataCon ) import TcBinds ( tcBindsAndThen ) -import TcEnv ( tcLookup, tcLookupGlobalId, - tcLookupDataCon, tcLookupId, checkProcLevel +import TcEnv ( tcLookup, tcLookupId, checkProcLevel, + tcLookupDataCon, tcLookupGlobalId ) import TcArrows ( tcProc ) import TcMatches ( tcMatchesCase, tcMatchLambda, tcDoStmts, tcThingWithSig, TcMatchCtxt(..) ) @@ -49,7 +49,7 @@ import FieldLabel ( FieldLabel, fieldLabelName, fieldLabelType, fieldLabelTyCon import Id ( idType, recordSelectorFieldLabel, isRecordSelector ) import DataCon ( DataCon, dataConFieldLabels, dataConStrictMarks, dataConWrapId ) import Name ( Name ) -import TyCon ( TyCon, tyConTyVars, tyConTheta, isAlgTyCon, tyConDataCons ) +import TyCon ( TyCon, tyConTyVars, tyConTheta, tyConDataCons ) import Subst ( mkTopTyVarSubst, substTheta, substTy ) import VarSet ( emptyVarSet, elemVarSet ) import TysWiredIn ( boolTy ) @@ -60,10 +60,14 @@ import PrelNames ( enumFromName, enumFromThenName, import ListSetOps ( minusList ) import CmdLineOpts import HscTypes ( TyThing(..) ) - +import SrcLoc ( Located(..), unLoc, getLoc ) import Util import Outputable import FastString + +#ifdef DEBUG +import TyCon ( isAlgTyCon ) +#endif \end{code} %************************************************************************ @@ -74,9 +78,9 @@ import FastString \begin{code} -- tcCheckSigma does type *checking*; it's passed the expected type of the result -tcCheckSigma :: RenamedHsExpr -- Expession to type check +tcCheckSigma :: LHsExpr Name -- Expession to type check -> TcSigmaType -- Expected type (could be a polytpye) - -> TcM TcExpr -- Generalised expr with expected type + -> TcM (LHsExpr TcId) -- Generalised expr with expected type tcCheckSigma expr expected_ty = traceTc (text "tcExpr" <+> (ppr expected_ty $$ ppr expr)) `thenM_` @@ -87,7 +91,7 @@ tc_expr' expr sigma_ty = tcGen sigma_ty emptyVarSet ( \ rho_ty -> tcCheckRho expr rho_ty ) `thenM` \ (gen_fn, expr') -> - returnM (gen_fn <$> expr') + returnM (L (getLoc expr') (gen_fn <$> unLoc expr')) tc_expr' expr rho_ty -- Monomorphic case = tcCheckRho expr rho_ty @@ -99,44 +103,50 @@ The expression can return a higher-ranked type, such as so we must create a hole to pass in as the expected tyvar. \begin{code} -tcCheckRho :: RenamedHsExpr -> TcRhoType -> TcM TcExpr +tcCheckRho :: LHsExpr Name -> TcRhoType -> TcM (LHsExpr TcId) tcCheckRho expr rho_ty = tcMonoExpr expr (Check rho_ty) -tcInferRho :: RenamedHsExpr -> TcM (TcExpr, TcRhoType) -tcInferRho (HsVar name) = tcId name -tcInferRho expr = newHole `thenM` \ hole -> - tcMonoExpr expr (Infer hole) `thenM` \ expr' -> - readMutVar hole `thenM` \ rho_ty -> - returnM (expr', rho_ty) +tcInferRho :: LHsExpr Name -> TcM (LHsExpr TcId, TcRhoType) +tcInferRho (L loc (HsVar name)) = addSrcSpan loc $ + do { (e,ty) <- tcId name; return (L loc e, ty)} +tcInferRho expr = newHole `thenM` \ hole -> + tcMonoExpr expr (Infer hole) `thenM` \ expr' -> + readMutVar hole `thenM` \ rho_ty -> + returnM (expr', rho_ty) \end{code} %************************************************************************ %* * -\subsection{The TAUT rules for variables} +\subsection{The TAUT rules for variables}TcExpr %* * %************************************************************************ \begin{code} -tcMonoExpr :: RenamedHsExpr -- Expession to type check +tcMonoExpr :: LHsExpr Name -- Expession to type check -> Expected TcRhoType -- Expected type (could be a type variable) -- Definitely no foralls at the top -- Can be a 'hole'. - -> TcM TcExpr + -> TcM (LHsExpr TcId) + +tcMonoExpr (L loc expr) res_ty + = addSrcSpan loc (do { expr' <- tc_expr expr res_ty + ; return (L loc expr') }) -tcMonoExpr (HsVar name) res_ty +tc_expr :: HsExpr Name -> Expected TcRhoType -> TcM (HsExpr TcId) +tc_expr (HsVar name) res_ty = tcId name `thenM` \ (expr', id_ty) -> tcSubExp res_ty id_ty `thenM` \ co_fn -> returnM (co_fn <$> expr') -tcMonoExpr (HsIPVar ip) res_ty +tc_expr (HsIPVar ip) res_ty = -- Implicit parameters must have a *tau-type* not a -- type scheme. We enforce this by creating a fresh -- type variable as its type. (Because res_ty may not -- be a tau-type.) newTyVarTy openTypeKind `thenM` \ ip_ty -> - newIPDict (IPOcc ip) ip ip_ty `thenM` \ (ip', inst) -> + newIPDict (IPOccOrigin ip) ip ip_ty `thenM` \ (ip', inst) -> extendLIE inst `thenM_` tcSubExp res_ty ip_ty `thenM` \ co_fn -> returnM (co_fn <$> HsIPVar ip') @@ -150,13 +160,14 @@ tcMonoExpr (HsIPVar ip) res_ty %************************************************************************ \begin{code} -tcMonoExpr in_expr@(ExprWithTySig expr poly_ty) res_ty +tc_expr in_expr@(ExprWithTySig expr poly_ty) res_ty = addErrCtxt (exprSigCtxt in_expr) $ tcHsSigType ExprSigCtxt poly_ty `thenM` \ sig_tc_ty -> tcThingWithSig sig_tc_ty (tcCheckRho expr) res_ty `thenM` \ (co_fn, expr') -> - returnM (co_fn <$> expr') + returnM (co_fn <$> unLoc expr') + -- ToDo: nasty unLoc -tcMonoExpr (HsType ty) res_ty +tc_expr (HsType ty) res_ty = failWithTc (text "Can't handle type argument:" <+> ppr ty) -- This is the syntax for type applications that I was planning -- but there are difficulties (e.g. what order for type args) @@ -173,25 +184,29 @@ tcMonoExpr (HsType ty) res_ty %************************************************************************ \begin{code} -tcMonoExpr (HsLit lit) res_ty = tcLit lit res_ty -tcMonoExpr (HsOverLit lit) res_ty = zapExpectedType res_ty `thenM` \ res_ty' -> - newOverloadedLit (LiteralOrigin lit) lit res_ty' -tcMonoExpr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> - returnM (HsPar expr') -tcMonoExpr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> - returnM (HsSCC lbl expr') - -tcMonoExpr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation +tc_expr (HsPar expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> + returnM (HsPar expr') +tc_expr (HsSCC lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> + returnM (HsSCC lbl expr') +tc_expr (HsCoreAnn lbl expr) res_ty = tcMonoExpr expr res_ty `thenM` \ expr' -> -- hdaume: core annotation returnM (HsCoreAnn lbl expr') -tcMonoExpr (NegApp expr neg_name) res_ty - = tcMonoExpr (HsApp (HsVar neg_name) expr) res_ty + +tc_expr (HsLit lit) res_ty = tcLit lit res_ty + +tc_expr (HsOverLit lit) res_ty + = zapExpectedType res_ty `thenM` \ res_ty' -> + newOverloadedLit (LiteralOrigin lit) lit res_ty' `thenM` \ lit_expr -> + returnM (unLoc lit_expr) -- ToDo: nasty unLoc + +tc_expr (NegApp expr neg_name) res_ty + = tc_expr (HsApp (nlHsVar neg_name) expr) res_ty -- ToDo: use tcSyntaxName -tcMonoExpr (HsLam match) res_ty +tc_expr (HsLam match) res_ty = tcMatchLambda match res_ty `thenM` \ match' -> returnM (HsLam match') -tcMonoExpr (HsApp e1 e2) res_ty +tc_expr (HsApp e1 e2) res_ty = tcApp e1 [e2] res_ty \end{code} @@ -206,7 +221,7 @@ a type error will occur if they aren't. -- or just -- op e -tcMonoExpr in_expr@(SectionL arg1 op) res_ty +tc_expr in_expr@(SectionL arg1 op) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> @@ -217,7 +232,7 @@ tcMonoExpr in_expr@(SectionL arg1 op) res_ty -- Right sections, equivalent to \ x -> x op expr, or -- \ x -> op x expr -tcMonoExpr in_expr@(SectionR op arg2) res_ty +tc_expr in_expr@(SectionR op arg2) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg2, arg2_ty, 2) `thenM` \ arg2' -> @@ -227,7 +242,7 @@ tcMonoExpr in_expr@(SectionR op arg2) res_ty -- equivalent to (op e1) e2: -tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty +tc_expr in_expr@(OpApp arg1 op fix arg2) res_ty = tcInferRho op `thenM` \ (op', op_ty) -> split_fun_ty op_ty 2 {- two args -} `thenM` \ ([arg1_ty, arg2_ty], op_res_ty) -> tcArg op (arg1, arg1_ty, 1) `thenM` \ arg1' -> @@ -238,15 +253,16 @@ tcMonoExpr in_expr@(OpApp arg1 op fix arg2) res_ty \end{code} \begin{code} -tcMonoExpr (HsLet binds expr) res_ty +tc_expr (HsLet binds (L loc expr)) res_ty = tcBindsAndThen - HsLet + glue binds -- Bindings to check - (tcMonoExpr expr res_ty) + (tc_expr expr res_ty) + where + glue bind expr = HsLet [bind] (L loc expr) -tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty - = addSrcLoc src_loc $ - addErrCtxt (caseCtxt in_expr) $ +tc_expr in_expr@(HsCase scrut matches) res_ty + = addErrCtxt (caseCtxt in_expr) $ -- Typecheck the case alternatives first. -- The case patterns tend to give good type info to use @@ -261,14 +277,13 @@ tcMonoExpr in_expr@(HsCase scrut matches src_loc) res_ty tcCheckRho scrut scrut_ty ) `thenM` \ scrut' -> - returnM (HsCase scrut' matches' src_loc) + returnM (HsCase scrut' matches') where match_ctxt = MC { mc_what = CaseAlt, mc_body = tcMonoExpr } -tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty - = addSrcLoc src_loc $ - addErrCtxt (predCtxt pred) ( +tc_expr (HsIf pred b1 b2) res_ty + = addErrCtxt (predCtxt pred) ( tcCheckRho pred boolTy ) `thenM` \ pred' -> zapExpectedType res_ty `thenM` \ res_ty' -> @@ -276,16 +291,15 @@ tcMonoExpr (HsIf pred b1 b2 src_loc) res_ty tcCheckRho b1 res_ty' `thenM` \ b1' -> tcCheckRho b2 res_ty' `thenM` \ b2' -> - returnM (HsIf pred' b1' b2' src_loc) + returnM (HsIf pred' b1' b2') -tcMonoExpr (HsDo do_or_lc stmts method_names _ src_loc) res_ty - = addSrcLoc src_loc $ - zapExpectedType res_ty `thenM` \ res_ty' -> +tc_expr (HsDo do_or_lc stmts method_names _) res_ty + = zapExpectedType res_ty `thenM` \ res_ty' -> -- All comprehensions yield a monotype tcDoStmts do_or_lc stmts method_names res_ty' `thenM` \ (stmts', methods') -> - returnM (HsDo do_or_lc stmts' methods' res_ty' src_loc) + returnM (HsDo do_or_lc stmts' methods' res_ty') -tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list +tc_expr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = zapToListTy res_ty `thenM` \ elt_ty -> mappM (tc_elt elt_ty) exprs `thenM` \ exprs' -> returnM (ExplicitList elt_ty exprs') @@ -294,7 +308,7 @@ tcMonoExpr in_expr@(ExplicitList _ exprs) res_ty -- Non-empty list = addErrCtxt (listCtxt expr) $ tcCheckRho expr elt_ty -tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty +tc_expr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty = zapToPArrTy res_ty `thenM` \ elt_ty -> mappM (tc_elt elt_ty) exprs `thenM` \ exprs' -> returnM (ExplicitPArr elt_ty exprs') @@ -303,15 +317,14 @@ tcMonoExpr in_expr@(ExplicitPArr _ exprs) res_ty -- maybe empty = addErrCtxt (parrCtxt expr) $ tcCheckRho expr elt_ty -tcMonoExpr (ExplicitTuple exprs boxity) res_ty +tc_expr (ExplicitTuple exprs boxity) res_ty = zapToTupleTy boxity (length exprs) res_ty `thenM` \ arg_tys -> tcCheckRhos exprs arg_tys `thenM` \ exprs' -> returnM (ExplicitTuple exprs' boxity) -tcMonoExpr (HsProc pat cmd loc) res_ty - = addSrcLoc loc $ - tcProc pat cmd res_ty `thenM` \ (pat', cmd') -> - returnM (HsProc pat' cmd' loc) +tc_expr (HsProc pat cmd) res_ty + = tcProc pat cmd res_ty `thenM` \ (pat', cmd') -> + returnM (HsProc pat' cmd') \end{code} %************************************************************************ @@ -321,9 +334,9 @@ tcMonoExpr (HsProc pat cmd loc) res_ty %************************************************************************ \begin{code} -tcMonoExpr expr@(RecordCon con_name rbinds) res_ty +tc_expr expr@(RecordCon con@(L _ con_name) rbinds) res_ty = addErrCtxt (recordConCtxt expr) $ - tcId con_name `thenM` \ (con_expr, con_tau) -> + addLocM tcId con `thenM` \ (con_expr, con_tau) -> let (_, record_ty) = tcSplitFunTys con_tau (tycon, ty_args) = tcSplitTyConApp record_ty @@ -348,7 +361,8 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty -- Check for missing fields checkMissingFields data_con rbinds `thenM_` - returnM (RecordConOut data_con con_expr rbinds') + getSrcSpanM `thenM` \ loc -> + returnM (RecordConOut data_con (L loc con_expr) rbinds') -- The main complication with RecordUpd is that we need to explicitly -- handle the *non-updated* fields. Consider: @@ -376,21 +390,21 @@ tcMonoExpr expr@(RecordCon con_name rbinds) res_ty -- -- All this is done in STEP 4 below. -tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty +tc_expr expr@(RecordUpd record_expr rbinds) res_ty = addErrCtxt (recordUpdCtxt expr) $ -- STEP 0 -- Check that the field names are really field names ASSERT( notNull rbinds ) let - field_names = recBindFields rbinds + field_names = map fst rbinds in - mappM tcLookupGlobalId field_names `thenM` \ sel_ids -> + mappM (tcLookupGlobalId.unLoc) field_names `thenM` \ sel_ids -> -- The renamer has already checked that they -- are all in scope let - bad_guys = [ addErrTc (notSelector field_name) - | (field_name, sel_id) <- field_names `zip` sel_ids, + bad_guys = [ addSrcSpan loc $ addErrTc (notSelector field_name) + | (L loc field_name, sel_id) <- field_names `zip` sel_ids, not (isRecordSelector sel_id) -- Excludes class ops ] in @@ -482,16 +496,16 @@ tcMonoExpr expr@(RecordUpd record_expr rbinds) res_ty %************************************************************************ \begin{code} -tcMonoExpr (ArithSeqIn seq@(From expr)) res_ty +tc_expr (ArithSeqIn seq@(From expr)) res_ty = zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr elt_ty `thenM` \ expr' -> newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromName `thenM` \ enum_from -> - returnM (ArithSeqOut (HsVar enum_from) (From expr')) + returnM (ArithSeqOut (nlHsVar enum_from) (From expr')) -tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty +tc_expr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -499,10 +513,10 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThen expr1 expr2)) res_ty newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenName `thenM` \ enum_from_then -> - returnM (ArithSeqOut (HsVar enum_from_then) (FromThen expr1' expr2')) + returnM (ArithSeqOut (nlHsVar enum_from_then) (FromThen expr1' expr2')) -tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty +tc_expr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -510,9 +524,9 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromTo expr1 expr2)) res_ty newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromToName `thenM` \ enum_from_to -> - returnM (ArithSeqOut (HsVar enum_from_to) (FromTo expr1' expr2')) + returnM (ArithSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2')) -tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty +tc_expr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty = addErrCtxt (arithSeqCtxt in_expr) $ zapToListTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -521,9 +535,9 @@ tcMonoExpr in_expr@(ArithSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty newMethodFromName (ArithSeqOrigin seq) elt_ty enumFromThenToName `thenM` \ eft -> - returnM (ArithSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3')) + returnM (ArithSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3')) -tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty +tc_expr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ zapToPArrTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -531,9 +545,9 @@ tcMonoExpr in_expr@(PArrSeqIn seq@(FromTo expr1 expr2)) res_ty newMethodFromName (PArrSeqOrigin seq) elt_ty enumFromToPName `thenM` \ enum_from_to -> - returnM (PArrSeqOut (HsVar enum_from_to) (FromTo expr1' expr2')) + returnM (PArrSeqOut (nlHsVar enum_from_to) (FromTo expr1' expr2')) -tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty +tc_expr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty = addErrCtxt (parrSeqCtxt in_expr) $ zapToPArrTy res_ty `thenM` \ elt_ty -> tcCheckRho expr1 elt_ty `thenM` \ expr1' -> @@ -542,9 +556,9 @@ tcMonoExpr in_expr@(PArrSeqIn seq@(FromThenTo expr1 expr2 expr3)) res_ty newMethodFromName (PArrSeqOrigin seq) elt_ty enumFromThenToPName `thenM` \ eft -> - returnM (PArrSeqOut (HsVar eft) (FromThenTo expr1' expr2' expr3')) + returnM (PArrSeqOut (nlHsVar eft) (FromThenTo expr1' expr2' expr3')) -tcMonoExpr (PArrSeqIn _) _ +tc_expr (PArrSeqIn _) _ = panic "TcExpr.tcMonoExpr: Infinite parallel array!" -- the parser shouldn't have generated it and the renamer shouldn't have -- let it through @@ -561,8 +575,10 @@ tcMonoExpr (PArrSeqIn _) _ #ifdef GHCI /* Only if bootstrapped */ -- Rename excludes these cases otherwise -tcMonoExpr (HsSplice n expr loc) res_ty = addSrcLoc loc (tcSpliceExpr n expr res_ty) -tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty) +tc_expr (HsSplice n expr) res_ty = tcSpliceExpr n expr res_ty +tc_expr (HsBracket brack) res_ty = do + e <- tcBracket brack res_ty + return (unLoc e) #endif /* GHCI */ \end{code} @@ -574,7 +590,7 @@ tcMonoExpr (HsBracket brack loc) res_ty = addSrcLoc loc (tcBracket brack res_ty) %************************************************************************ \begin{code} -tcMonoExpr other _ = pprPanic "tcMonoExpr" (ppr other) +tc_expr other _ = pprPanic "tcMonoExpr" (ppr other) \end{code} @@ -586,11 +602,11 @@ tcMonoExpr other _ = pprPanic "tcMonoExpr" (ppr other) \begin{code} -tcApp :: RenamedHsExpr -> [RenamedHsExpr] -- Function and args +tcApp :: LHsExpr Name -> [LHsExpr Name] -- Function and args -> Expected TcRhoType -- Expected result type of application - -> TcM TcExpr -- Translated fun and args + -> TcM (HsExpr TcId) -- Translated fun and args -tcApp (HsApp e1 e2) args res_ty +tcApp (L _ (HsApp e1 e2)) args res_ty = tcApp e1 (e2:args) res_ty -- Accumulate the arguments tcApp fun args res_ty @@ -630,7 +646,7 @@ tcApp fun args res_ty mappM (tcArg fun) (zip3 args expected_arg_tys [1..]) `thenM` \ args' -> - returnM (co_fn <$> foldl HsApp fun' args') + returnM (co_fn <$> unLoc (foldl mkHsApp fun' args')) -- If an error happens we try to figure out whether the @@ -673,9 +689,9 @@ split_fun_ty fun_ty n \end{code} \begin{code} -tcArg :: RenamedHsExpr -- The function (for error messages) - -> (RenamedHsExpr, TcSigmaType, Int) -- Actual argument and expected arg type - -> TcM TcExpr -- Resulting argument and LIE +tcArg :: LHsExpr Name -- The function (for error messages) + -> (LHsExpr Name, TcSigmaType, Int) -- Actual argument and expected arg type + -> TcM (LHsExpr TcId) -- Resulting argument tcArg the_fun (arg, expected_arg_ty, arg_no) = addErrCtxt (funAppCtxt the_fun arg arg_no) $ @@ -712,7 +728,7 @@ This gets a bit less sharing, but b) perhaps fewer separated lambdas \begin{code} -tcId :: Name -> TcM (TcExpr, TcRhoType) +tcId :: Name -> TcM (HsExpr TcId, TcRhoType) tcId name -- Look up the Id and instantiate its type = -- First check whether it's a DataCon -- Reason: we must not forget to chuck in the @@ -768,7 +784,7 @@ tcId name -- Look up the Id and instantiate its type -- Update the pending splices readMutVar ps_var `thenM` \ ps -> - writeMutVar ps_var ((name, HsApp (HsVar lift) (HsVar id)) : ps) `thenM_` + writeMutVar ps_var ((name, nlHsApp (nlHsVar lift) (nlHsVar id)) : ps) `thenM_` returnM (HsVar id, id_ty)) @@ -814,9 +830,11 @@ tcId name -- Look up the Id and instantiate its type inst_data_con data_con = tcInstDataCon orig data_con `thenM` \ (ty_args, ex_dicts, arg_tys, result_ty, _) -> extendLIEs ex_dicts `thenM_` - returnM (mkHsDictApp (mkHsTyApp (HsVar (dataConWrapId data_con)) ty_args) - (map instToId ex_dicts), + getSrcSpanM `thenM` \ loc -> + returnM (unLoc (mkHsDictApp (mkHsTyApp (L loc (HsVar (dataConWrapId data_con))) ty_args) + (map instToId ex_dicts)), mkFunTys arg_tys result_ty) + -- ToDo: nasty loc/unloc stuff here orig = OccurrenceOf name \end{code} @@ -848,17 +866,17 @@ This extends OK when the field types are universally quantified. tcRecordBinds :: TyCon -- Type constructor for the record -> [TcType] -- Args of this type constructor - -> RenamedRecordBinds - -> TcM TcRecordBinds + -> HsRecordBinds Name + -> TcM (HsRecordBinds TcId) tcRecordBinds tycon ty_args rbinds = mappM do_bind rbinds where tenv = mkTopTyVarSubst (tyConTyVars tycon) ty_args - do_bind (field_lbl_name, rhs) + do_bind (L loc field_lbl_name, rhs) = addErrCtxt (fieldCtxt field_lbl_name) $ - tcLookupId field_lbl_name `thenM` \ sel_id -> + tcLookupId field_lbl_name `thenM` \ sel_id -> let field_lbl = recordSelectorFieldLabel sel_id field_ty = substTy tenv (fieldLabelType field_lbl) @@ -873,14 +891,14 @@ tcRecordBinds tycon ty_args rbinds tcCheckSigma rhs field_ty `thenM` \ rhs' -> - returnM (sel_id, rhs') + returnM (L loc sel_id, rhs') badFields rbinds data_con = filter (not . (`elem` field_names)) (recBindFields rbinds) where field_names = map fieldLabelName (dataConFieldLabels data_con) -checkMissingFields :: DataCon -> RenamedRecordBinds -> TcM () +checkMissingFields :: DataCon -> HsRecordBinds Name -> TcM () checkMissingFields data_con rbinds | null field_labels -- Not declared as a record; -- But C{} is still valid if no strict fields @@ -927,7 +945,7 @@ checkMissingFields data_con rbinds %************************************************************************ \begin{code} -tcCheckRhos :: [RenamedHsExpr] -> [TcType] -> TcM [TcExpr] +tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId] tcCheckRhos [] [] = returnM [] tcCheckRhos (expr:exprs) (ty:tys) @@ -946,7 +964,7 @@ tcCheckRhos (expr:exprs) (ty:tys) Overloaded literals. \begin{code} -tcLit :: HsLit -> Expected TcRhoType -> TcM TcExpr +tcLit :: HsLit -> Expected TcRhoType -> TcM (HsExpr TcId) tcLit lit res_ty = zapExpectedTo res_ty (hsLitType lit) `thenM_` returnM (HsLit lit) @@ -1000,7 +1018,7 @@ predCtxt expr appCtxt fun args = ptext SLIT("In the application") <+> quotes (ppr the_app) where - the_app = foldl HsApp fun args -- Used in error messages + the_app = foldl mkHsApp fun args -- Used in error messages badFieldsUpd rbinds = hang (ptext SLIT("No constructor has all these fields:")) @@ -1034,7 +1052,7 @@ wrongArgsCtxt too_many_or_few fun args <+> ptext SLIT("arguments in the call")) 4 (parens (ppr the_app)) where - the_app = foldl HsApp fun args -- Used in error messages + the_app = foldl mkHsApp fun args -- Used in error messages #ifdef GHCI polySpliceErr :: Id -> SDoc diff --git a/ghc/compiler/typecheck/TcForeign.lhs b/ghc/compiler/typecheck/TcForeign.lhs index 3b880c0c61..b5b08f357d 100644 --- a/ghc/compiler/typecheck/TcForeign.lhs +++ b/ghc/compiler/typecheck/TcForeign.lhs @@ -20,21 +20,14 @@ module TcForeign #include "config.h" #include "HsVersions.h" -import HsSyn ( ForeignDecl(..), HsExpr(..), - MonoBinds(..), ForeignImport(..), ForeignExport(..), - CImportSpec(..) - ) -import RnHsSyn ( RenamedForeignDecl ) +import HsSyn import TcRnMonad import TcHsType ( tcHsSigType, UserTypeCtxt(..) ) -import TcHsSyn ( TcMonoBinds, TypecheckedForeignDecl, TcForeignDecl ) import TcExpr ( tcCheckSigma ) import ErrUtils ( Message ) import Id ( Id, mkLocalId, setIdLocalExported ) -import PrimRep ( getPrimRepSize, isFloatingRep ) -import Type ( typePrimRep ) import OccName ( mkForeignExportOcc ) import Name ( Name, NamedThing(..), mkExternalName ) import TcType ( Type, tcSplitFunTys, tcSplitTyConApp_maybe, @@ -51,19 +44,21 @@ import CStrings ( CLabelString, isCLabelString ) import PrelNames ( hasKey, ioTyConKey ) import CmdLineOpts ( dopt_HscLang, HscLang(..) ) import Outputable +import SrcLoc ( Located(..), srcSpanStart ) +import Bag ( emptyBag, consBag ) \end{code} \begin{code} -- Defines a binding -isForeignImport :: ForeignDecl name -> Bool -isForeignImport (ForeignImport _ _ _ _ _) = True -isForeignImport _ = False +isForeignImport :: LForeignDecl name -> Bool +isForeignImport (L _ (ForeignImport _ _ _ _)) = True +isForeignImport _ = False -- Exports a binding -isForeignExport :: ForeignDecl name -> Bool -isForeignExport (ForeignExport _ _ _ _ _) = True -isForeignExport _ = False +isForeignExport :: LForeignDecl name -> Bool +isForeignExport (L _ (ForeignExport _ _ _ _)) = True +isForeignExport _ = False \end{code} %************************************************************************ @@ -73,14 +68,13 @@ isForeignExport _ = False %************************************************************************ \begin{code} -tcForeignImports :: [ForeignDecl Name] -> TcM ([Id], [TypecheckedForeignDecl]) +tcForeignImports :: [LForeignDecl Name] -> TcM ([Id], [LForeignDecl Id]) tcForeignImports decls - = mapAndUnzipM tcFImport (filter isForeignImport decls) + = mapAndUnzipM (wrapLocSndM tcFImport) (filter isForeignImport decls) -tcFImport :: RenamedForeignDecl -> TcM (Id, TypecheckedForeignDecl) -tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) - = addSrcLoc src_loc $ - addErrCtxt (foreignDeclCtxt fo) $ +tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id) +tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl isDeprec) + = addErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> let -- drop the foralls before inspecting the structure @@ -95,7 +89,7 @@ tcFImport fo@(ForeignImport nm hs_ty imp_decl isDeprec src_loc) tcCheckFIType sig_ty arg_tys res_ty imp_decl `thenM` \ imp_decl' -> -- can't use sig_ty here because it :: Type and we need HsType Id -- hence the undefined - returnM (id, ForeignImport id undefined imp_decl' isDeprec src_loc) + returnM (id, ForeignImport (L loc id) undefined imp_decl' isDeprec) \end{code} @@ -198,22 +192,21 @@ checkFEDArgs arg_tys = returnM () %************************************************************************ \begin{code} -tcForeignExports :: [ForeignDecl Name] - -> TcM (TcMonoBinds, [TcForeignDecl]) +tcForeignExports :: [LForeignDecl Name] + -> TcM (LHsBinds TcId, [LForeignDecl TcId]) tcForeignExports decls - = foldlM combine (EmptyMonoBinds, []) (filter isForeignExport decls) + = foldlM combine (emptyBag, []) (filter isForeignExport decls) where combine (binds, fs) fe = - tcFExport fe `thenM ` \ (b, f) -> - returnM (b `AndMonoBinds` binds, f:fs) + wrapLocSndM tcFExport fe `thenM` \ (b, f) -> + returnM (b `consBag` binds, f:fs) -tcFExport :: RenamedForeignDecl -> TcM (TcMonoBinds, TcForeignDecl) -tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = - addSrcLoc src_loc $ +tcFExport :: ForeignDecl Name -> TcM (LHsBind Id, ForeignDecl Id) +tcFExport fo@(ForeignExport (L loc nm) hs_ty spec isDeprec) = addErrCtxt (foreignDeclCtxt fo) $ tcHsSigType (ForSigCtxt nm) hs_ty `thenM` \ sig_ty -> - tcCheckSigma (HsVar nm) sig_ty `thenM` \ rhs -> + tcCheckSigma (nlHsVar nm) sig_ty `thenM` \ rhs -> tcCheckFEType sig_ty spec `thenM_` @@ -226,11 +219,11 @@ tcFExport fo@(ForeignExport nm hs_ty spec isDeprec src_loc) = getModule `thenM` \ mod -> let gnm = mkExternalName uniq mod (mkForeignExportOcc (getOccName nm)) - Nothing src_loc + Nothing (srcSpanStart loc) id = setIdLocalExported (mkLocalId gnm sig_ty) - bind = VarMonoBind id rhs + bind = L loc (VarBind id rhs) in - returnM (bind, ForeignExport id undefined spec isDeprec src_loc) + returnM (bind, ForeignExport (L loc id) undefined spec isDeprec) \end{code} ------------ Checking argument types for foreign export ---------------------- diff --git a/ghc/compiler/typecheck/TcGenDeriv.lhs b/ghc/compiler/typecheck/TcGenDeriv.lhs index 96680aa07e..e922146fc6 100644 --- a/ghc/compiler/typecheck/TcGenDeriv.lhs +++ b/ghc/compiler/typecheck/TcGenDeriv.lhs @@ -29,9 +29,9 @@ module TcGenDeriv ( #include "HsVersions.h" import HsSyn -import RdrName ( RdrName, mkVarUnqual, mkRdrUnqual, getRdrName, mkDerivedRdrName ) -import RdrHsSyn ( mkHsOpApp, RdrNameMonoBinds, RdrNameHsExpr, RdrNamePat, mkHsDo ) -import BasicTypes ( RecFlag(..), Fixity(..), maxPrecedence, Boxity(..) ) +import RdrName ( RdrName, mkVarUnqual, getRdrName, mkRdrUnqual, + mkDerivedRdrName ) +import BasicTypes ( Fixity(..), maxPrecedence, Boxity(..) ) import FieldLabel ( fieldLabelName ) import DataCon ( isNullaryDataCon, dataConTag, dataConOrigArgTys, dataConSourceArity, fIRST_TAG, @@ -49,7 +49,7 @@ import PrelNames import TysWiredIn import MkId ( eRROR_ID ) import PrimOp ( PrimOp(..) ) -import SrcLoc ( generatedSrcLoc, SrcLoc ) +import SrcLoc ( Located(..), noLoc, srcLocSpan ) import TyCon ( TyCon, isNewTyCon, tyConDataCons, isEnumerationTyCon, maybeTyConSingleCon, tyConFamilySize, tyConTyVars, tyConName ) @@ -65,6 +65,7 @@ import List ( partition, intersperse ) import Outputable import FastString import OccName +import Bag \end{code} %************************************************************************ @@ -148,11 +149,12 @@ instance ... Eq (Foo ...) where \begin{code} -gen_Eq_binds :: TyCon -> RdrNameMonoBinds +gen_Eq_binds :: TyCon -> LHsBinds RdrName gen_Eq_binds tycon = let - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon + (nullary_cons, nonnullary_cons) | isNewTyCon tycon = ([], tyConDataCons tycon) | otherwise = partition isNullaryDataCon (tyConDataCons tycon) @@ -166,18 +168,19 @@ gen_Eq_binds tycon else -- calc. and compare the tags [([a_Pat, b_Pat], untag_Expr tycon [(a_RDR,ah_RDR), (b_RDR,bh_RDR)] - (genOpApp (HsVar ah_RDR) eqInt_RDR (HsVar bh_RDR)))] + (genOpApp (nlHsVar ah_RDR) eqInt_RDR (nlHsVar bh_RDR)))] in - mk_FunMonoBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest) - `AndMonoBinds` - mk_easy_FunMonoBind tycon_loc ne_RDR [a_Pat, b_Pat] [] ( - HsApp (HsVar not_RDR) (HsPar (mkHsVarApps eq_RDR [a_RDR, b_RDR]))) + listToBag [ + mk_FunBind tycon_loc eq_RDR ((map pats_etc nonnullary_cons) ++ rest), + mk_easy_FunBind tycon_loc ne_RDR [a_Pat, b_Pat] emptyBag ( + nlHsApp (nlHsVar not_RDR) (nlHsPar (nlHsVarApps eq_RDR [a_RDR, b_RDR]))) + ] where ------------------------------------------------------------------ pats_etc data_con = let - con1_pat = mkConPat data_con_RDR as_needed - con2_pat = mkConPat data_con_RDR bs_needed + con1_pat = nlConVarPat data_con_RDR as_needed + con2_pat = nlConVarPat data_con_RDR bs_needed data_con_RDR = getRdrName data_con con_arity = length tys_needed @@ -191,7 +194,7 @@ gen_Eq_binds tycon nested_eq_expr tys as bs = foldl1 and_Expr (zipWith3Equal "nested_eq" nested_eq tys as bs) where - nested_eq ty a b = HsPar (eq_Expr tycon ty (HsVar a) (HsVar b)) + nested_eq ty a b = nlHsPar (eq_Expr tycon ty (nlHsVar a) (nlHsVar b)) \end{code} %************************************************************************ @@ -291,16 +294,17 @@ If there is only one constructor in the Data Type we don't need the WildCard Pat JJQC-30-Nov-1997 \begin{code} -gen_Ord_binds :: TyCon -> RdrNameMonoBinds +gen_Ord_binds :: TyCon -> LHsBinds RdrName gen_Ord_binds tycon - = compare -- `AndMonoBinds` compare + = unitBag compare -- `AndMonoBinds` compare -- The default declaration in PrelBase handles this where - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon -------------------------------------------------------------------- - compare = mk_easy_FunMonoBind tycon_loc compare_RDR - [a_Pat, b_Pat] [cmp_eq] compare_rhs + + compare = mk_easy_FunBind tycon_loc compare_RDR + [a_Pat, b_Pat] (unitBag cmp_eq) compare_rhs compare_rhs | single_con_type = cmp_eq_Expr a_Expr b_Expr | otherwise @@ -317,7 +321,7 @@ gen_Ord_binds tycon | isNewTyCon tycon = ([], tyConDataCons tycon) | otherwise = partition isNullaryDataCon tycon_data_cons - cmp_eq = mk_FunMonoBind tycon_loc cmp_eq_RDR cmp_eq_match + cmp_eq = mk_FunBind tycon_loc cmp_eq_RDR cmp_eq_match cmp_eq_match | isEnumerationTyCon tycon -- We know the tags are equal, so if it's an enumeration TyCon, @@ -338,8 +342,8 @@ gen_Ord_binds tycon = ([con1_pat, con2_pat], nested_compare_expr tys_needed as_needed bs_needed) where - con1_pat = mkConPat data_con_RDR as_needed - con2_pat = mkConPat data_con_RDR bs_needed + con1_pat = nlConVarPat data_con_RDR as_needed + con2_pat = nlConVarPat data_con_RDR bs_needed data_con_RDR = getRdrName data_con con_arity = length tys_needed @@ -348,11 +352,11 @@ gen_Ord_binds tycon tys_needed = dataConOrigArgTys data_con nested_compare_expr [ty] [a] [b] - = careful_compare_Case tycon ty eqTag_Expr (HsVar a) (HsVar b) + = careful_compare_Case tycon ty eqTag_Expr (nlHsVar a) (nlHsVar b) nested_compare_expr (ty:tys) (a:as) (b:bs) = let eq_expr = nested_compare_expr tys as bs - in careful_compare_Case tycon ty eq_expr (HsVar a) (HsVar b) + in careful_compare_Case tycon ty eq_expr (nlHsVar a) (nlHsVar b) default_rhs | null nullary_cons = impossible_Expr -- Keep desugarer from complaining about -- inexhaustive patterns @@ -402,76 +406,75 @@ instance ... Enum (Foo ...) where For @enumFromTo@ and @enumFromThenTo@, we use the default methods. \begin{code} -gen_Enum_binds :: TyCon -> RdrNameMonoBinds +gen_Enum_binds :: TyCon -> LHsBinds RdrName gen_Enum_binds tycon - = succ_enum `AndMonoBinds` - pred_enum `AndMonoBinds` - to_enum `AndMonoBinds` - enum_from `AndMonoBinds` - enum_from_then `AndMonoBinds` - from_enum + = listToBag [ + succ_enum, + pred_enum, + to_enum, + enum_from, + enum_from_then, + from_enum + ] where - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon occ_nm = getOccString tycon succ_enum - = mk_easy_FunMonoBind tycon_loc succ_RDR [a_Pat] [] $ + = mk_easy_FunBind tycon_loc succ_RDR [a_Pat] emptyBag $ untag_Expr tycon [(a_RDR, ah_RDR)] $ - HsIf (mkHsApps eq_RDR [HsVar (maxtag_RDR tycon), - mkHsVarApps intDataCon_RDR [ah_RDR]]) + nlHsIf (nlHsApps eq_RDR [nlHsVar (maxtag_RDR tycon), + nlHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "succ" occ_nm "tried to take `succ' of last tag in enumeration") - (HsApp (HsVar (tag2con_RDR tycon)) - (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], - mkHsIntLit 1])) - tycon_loc + (nlHsApp (nlHsVar (tag2con_RDR tycon)) + (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsIntLit 1])) pred_enum - = mk_easy_FunMonoBind tycon_loc pred_RDR [a_Pat] [] $ + = mk_easy_FunBind tycon_loc pred_RDR [a_Pat] emptyBag $ untag_Expr tycon [(a_RDR, ah_RDR)] $ - HsIf (mkHsApps eq_RDR [mkHsIntLit 0, - mkHsVarApps intDataCon_RDR [ah_RDR]]) + nlHsIf (nlHsApps eq_RDR [nlHsIntLit 0, + nlHsVarApps intDataCon_RDR [ah_RDR]]) (illegal_Expr "pred" occ_nm "tried to take `pred' of first tag in enumeration") - (HsApp (HsVar (tag2con_RDR tycon)) - (mkHsApps plus_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], - HsLit (HsInt (-1))])) - tycon_loc + (nlHsApp (nlHsVar (tag2con_RDR tycon)) + (nlHsApps plus_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsLit (HsInt (-1))])) to_enum - = mk_easy_FunMonoBind tycon_loc toEnum_RDR [a_Pat] [] $ - HsIf (mkHsApps and_RDR - [mkHsApps ge_RDR [HsVar a_RDR, mkHsIntLit 0], - mkHsApps le_RDR [HsVar a_RDR, HsVar (maxtag_RDR tycon)]]) - (mkHsVarApps (tag2con_RDR tycon) [a_RDR]) + = mk_easy_FunBind tycon_loc toEnum_RDR [a_Pat] emptyBag $ + nlHsIf (nlHsApps and_RDR + [nlHsApps ge_RDR [nlHsVar a_RDR, nlHsIntLit 0], + nlHsApps le_RDR [nlHsVar a_RDR, nlHsVar (maxtag_RDR tycon)]]) + (nlHsVarApps (tag2con_RDR tycon) [a_RDR]) (illegal_toEnum_tag occ_nm (maxtag_RDR tycon)) - tycon_loc enum_from - = mk_easy_FunMonoBind tycon_loc enumFrom_RDR [a_Pat] [] $ + = mk_easy_FunBind tycon_loc enumFrom_RDR [a_Pat] emptyBag $ untag_Expr tycon [(a_RDR, ah_RDR)] $ - mkHsApps map_RDR - [HsVar (tag2con_RDR tycon), - HsPar (enum_from_to_Expr - (mkHsVarApps intDataCon_RDR [ah_RDR]) - (HsVar (maxtag_RDR tycon)))] + nlHsApps map_RDR + [nlHsVar (tag2con_RDR tycon), + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVar (maxtag_RDR tycon)))] enum_from_then - = mk_easy_FunMonoBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] [] $ + = mk_easy_FunBind tycon_loc enumFromThen_RDR [a_Pat, b_Pat] emptyBag $ untag_Expr tycon [(a_RDR, ah_RDR), (b_RDR, bh_RDR)] $ - HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $ - HsPar (enum_from_then_to_Expr - (mkHsVarApps intDataCon_RDR [ah_RDR]) - (mkHsVarApps intDataCon_RDR [bh_RDR]) - (HsIf (mkHsApps gt_RDR [mkHsVarApps intDataCon_RDR [ah_RDR], - mkHsVarApps intDataCon_RDR [bh_RDR]]) - (mkHsIntLit 0) - (HsVar (maxtag_RDR tycon)) - tycon_loc)) + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ + nlHsPar (enum_from_then_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR]) + (nlHsIf (nlHsApps gt_RDR [nlHsVarApps intDataCon_RDR [ah_RDR], + nlHsVarApps intDataCon_RDR [bh_RDR]]) + (nlHsIntLit 0) + (nlHsVar (maxtag_RDR tycon)) + )) from_enum - = mk_easy_FunMonoBind tycon_loc fromEnum_RDR [a_Pat] [] $ + = mk_easy_FunBind tycon_loc fromEnum_RDR [a_Pat] emptyBag $ untag_Expr tycon [(a_RDR, ah_RDR)] $ - (mkHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [ah_RDR]) \end{code} %************************************************************************ @@ -483,17 +486,17 @@ gen_Enum_binds tycon \begin{code} gen_Bounded_binds tycon = if isEnumerationTyCon tycon then - min_bound_enum `AndMonoBinds` max_bound_enum + listToBag [ min_bound_enum, max_bound_enum ] else ASSERT(isSingleton data_cons) - min_bound_1con `AndMonoBinds` max_bound_1con + listToBag [ min_bound_1con, max_bound_1con ] where data_cons = tyConDataCons tycon - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon ----- enum-flavored: --------------------------- - min_bound_enum = mkVarMonoBind tycon_loc minBound_RDR (HsVar data_con_1_RDR) - max_bound_enum = mkVarMonoBind tycon_loc maxBound_RDR (HsVar data_con_N_RDR) + min_bound_enum = mkVarBind tycon_loc minBound_RDR (nlHsVar data_con_1_RDR) + max_bound_enum = mkVarBind tycon_loc maxBound_RDR (nlHsVar data_con_N_RDR) data_con_1 = head data_cons data_con_N = last data_cons @@ -503,10 +506,10 @@ gen_Bounded_binds tycon ----- single-constructor-flavored: ------------- arity = dataConSourceArity data_con_1 - min_bound_1con = mkVarMonoBind tycon_loc minBound_RDR $ - mkHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) - max_bound_1con = mkVarMonoBind tycon_loc maxBound_RDR $ - mkHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) + min_bound_1con = mkVarBind tycon_loc minBound_RDR $ + nlHsVarApps data_con_1_RDR (nOfThem arity minBound_RDR) + max_bound_1con = mkVarBind tycon_loc maxBound_RDR $ + nlHsVarApps data_con_1_RDR (nOfThem arity maxBound_RDR) \end{code} %************************************************************************ @@ -568,7 +571,7 @@ we follow the scheme given in Figure~19 of the Haskell~1.2 report (p.~147). \begin{code} -gen_Ix_binds :: TyCon -> RdrNameMonoBinds +gen_Ix_binds :: TyCon -> LHsBinds RdrName gen_Ix_binds tycon = if isEnumerationTyCon tycon @@ -576,59 +579,55 @@ gen_Ix_binds tycon else single_con_ixes where tycon_str = getOccString tycon - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon -------------------------------------------------------------- - enum_ixes = enum_range `AndMonoBinds` - enum_index `AndMonoBinds` enum_inRange + enum_ixes = listToBag [ enum_range, enum_index, enum_inRange ] enum_range - = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePat [a_Pat, b_Pat] Boxed] [] $ + = mk_easy_FunBind tycon_loc range_RDR + [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag $ untag_Expr tycon [(a_RDR, ah_RDR)] $ untag_Expr tycon [(b_RDR, bh_RDR)] $ - HsApp (mkHsVarApps map_RDR [tag2con_RDR tycon]) $ - HsPar (enum_from_to_Expr - (mkHsVarApps intDataCon_RDR [ah_RDR]) - (mkHsVarApps intDataCon_RDR [bh_RDR])) + nlHsApp (nlHsVarApps map_RDR [tag2con_RDR tycon]) $ + nlHsPar (enum_from_to_Expr + (nlHsVarApps intDataCon_RDR [ah_RDR]) + (nlHsVarApps intDataCon_RDR [bh_RDR])) enum_index - = mk_easy_FunMonoBind tycon_loc index_RDR - [AsPat c_RDR (TuplePat [a_Pat, wildPat] Boxed), - d_Pat] [] ( - HsIf (HsPar (mkHsVarApps inRange_RDR [c_RDR, d_RDR])) ( + = mk_easy_FunBind tycon_loc index_RDR + [noLoc (AsPat (noLoc c_RDR) + (nlTuplePat [a_Pat, wildPat] Boxed)), + d_Pat] emptyBag ( + nlHsIf (nlHsPar (nlHsVarApps inRange_RDR [c_RDR, d_RDR])) ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(d_RDR, dh_RDR)] ( let - rhs = mkHsVarApps intDataCon_RDR [c_RDR] + rhs = nlHsVarApps intDataCon_RDR [c_RDR] in - HsCase - (genOpApp (HsVar dh_RDR) minusInt_RDR (HsVar ah_RDR)) - [mkSimpleHsAlt (VarPat c_RDR) rhs] - tycon_loc + nlHsCase + (genOpApp (nlHsVar dh_RDR) minusInt_RDR (nlHsVar ah_RDR)) + [mkSimpleHsAlt (nlVarPat c_RDR) rhs] )) ) {-else-} ( - HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n")))) - ) - tycon_loc) + nlHsApp (nlHsVar error_RDR) (nlHsLit (HsString (mkFastString ("Ix."++tycon_str++".index: out of range\n")))) + )) enum_inRange - = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePat [a_Pat, b_Pat] Boxed, c_Pat] [] ( + = mk_easy_FunBind tycon_loc inRange_RDR + [nlTuplePat [a_Pat, b_Pat] Boxed, c_Pat] emptyBag ( untag_Expr tycon [(a_RDR, ah_RDR)] ( untag_Expr tycon [(b_RDR, bh_RDR)] ( untag_Expr tycon [(c_RDR, ch_RDR)] ( - HsIf (genOpApp (HsVar ch_RDR) geInt_RDR (HsVar ah_RDR)) ( - (genOpApp (HsVar ch_RDR) leInt_RDR (HsVar bh_RDR)) + nlHsIf (genOpApp (nlHsVar ch_RDR) geInt_RDR (nlHsVar ah_RDR)) ( + (genOpApp (nlHsVar ch_RDR) leInt_RDR (nlHsVar bh_RDR)) ) {-else-} ( false_Expr - ) tycon_loc)))) + ))))) -------------------------------------------------------------- single_con_ixes - = single_con_range `AndMonoBinds` - single_con_index `AndMonoBinds` - single_con_inRange + = listToBag [single_con_range, single_con_index, single_con_inRange] data_con = case maybeTyConSingleCon tycon of -- just checking... @@ -644,60 +643,59 @@ gen_Ix_binds tycon bs_needed = take con_arity bs_RDRs cs_needed = take con_arity cs_RDRs - con_pat xs = mkConPat data_con_RDR xs - con_expr = mkHsVarApps data_con_RDR cs_needed + con_pat xs = nlConVarPat data_con_RDR xs + con_expr = nlHsVarApps data_con_RDR cs_needed -------------------------------------------------------------- single_con_range - = mk_easy_FunMonoBind tycon_loc range_RDR - [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed] [] $ - mkHsDo ListComp stmts tycon_loc + = mk_easy_FunBind tycon_loc range_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed] emptyBag $ + nlHsDo ListComp stmts where stmts = zipWith3Equal "single_con_range" mk_qual as_needed bs_needed cs_needed ++ - [ResultStmt con_expr tycon_loc] + [nlResultStmt con_expr] - mk_qual a b c = BindStmt (VarPat c) - (HsApp (HsVar range_RDR) - (ExplicitTuple [HsVar a, HsVar b] Boxed)) - tycon_loc + mk_qual a b c = nlBindStmt (nlVarPat c) + (nlHsApp (nlHsVar range_RDR) + (nlTuple [nlHsVar a, nlHsVar b] Boxed)) ---------------- single_con_index - = mk_easy_FunMonoBind tycon_loc index_RDR - [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed, - con_pat cs_needed] [range_size] ( - foldl mk_index (mkHsIntLit 0) (zip3 as_needed bs_needed cs_needed)) + = mk_easy_FunBind tycon_loc index_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + con_pat cs_needed] (unitBag range_size) ( + foldl mk_index (nlHsIntLit 0) (zip3 as_needed bs_needed cs_needed)) where mk_index multiply_by (l, u, i) = genOpApp ( - (mkHsApps index_RDR [ExplicitTuple [HsVar l, HsVar u] Boxed, - HsVar i]) + (nlHsApps index_RDR [nlTuple [nlHsVar l, nlHsVar u] Boxed, + nlHsVar i]) ) plus_RDR ( genOpApp ( - (HsApp (HsVar rangeSize_RDR) - (ExplicitTuple [HsVar l, HsVar u] Boxed)) + (nlHsApp (nlHsVar rangeSize_RDR) + (nlTuple [nlHsVar l, nlHsVar u] Boxed)) ) times_RDR multiply_by ) range_size - = mk_easy_FunMonoBind tycon_loc rangeSize_RDR - [TuplePat [a_Pat, b_Pat] Boxed] [] ( + = mk_easy_FunBind tycon_loc rangeSize_RDR + [nlTuplePat [a_Pat, b_Pat] Boxed] emptyBag ( genOpApp ( - (mkHsApps index_RDR [ExplicitTuple [a_Expr, b_Expr] Boxed, + (nlHsApps index_RDR [nlTuple [a_Expr, b_Expr] Boxed, b_Expr]) - ) plus_RDR (mkHsIntLit 1)) + ) plus_RDR (nlHsIntLit 1)) ------------------ single_con_inRange - = mk_easy_FunMonoBind tycon_loc inRange_RDR - [TuplePat [con_pat as_needed, con_pat bs_needed] Boxed, + = mk_easy_FunBind tycon_loc inRange_RDR + [nlTuplePat [con_pat as_needed, con_pat bs_needed] Boxed, con_pat cs_needed] - [] ( + emptyBag ( foldl1 and_Expr (zipWith3Equal "single_con_inRange" in_range as_needed bs_needed cs_needed)) where - in_range a b c = mkHsApps inRange_RDR [ExplicitTuple [HsVar a, HsVar b] Boxed, - HsVar c] + in_range a b c = nlHsApps inRange_RDR [nlTuple [nlHsVar a, nlHsVar b] Boxed, + nlHsVar c] \end{code} %************************************************************************ @@ -743,24 +741,25 @@ instance Read T where \begin{code} -gen_Read_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds +gen_Read_binds :: FixityEnv -> TyCon -> LHsBinds RdrName gen_Read_binds get_fixity tycon - = read_prec `AndMonoBinds` default_binds + = listToBag [read_prec, default_readlist, default_readlistprec] where ----------------------------------------------------------------------- - default_binds - = mkVarMonoBind loc readList_RDR (HsVar readListDefault_RDR) - `AndMonoBinds` - mkVarMonoBind loc readListPrec_RDR (HsVar readListPrecDefault_RDR) + default_readlist + = mkVarBind loc readList_RDR (nlHsVar readListDefault_RDR) + + default_readlistprec + = mkVarBind loc readListPrec_RDR (nlHsVar readListPrecDefault_RDR) ----------------------------------------------------------------------- - loc = getSrcLoc tycon + loc = getSrcSpan tycon data_cons = tyConDataCons tycon (nullary_cons, non_nullary_cons) = partition isNullaryDataCon data_cons - read_prec = mkVarMonoBind loc readPrec_RDR - (HsApp (HsVar parens_RDR) read_cons) + read_prec = mkVarBind loc readPrec_RDR + (nlHsApp (nlHsVar parens_RDR) read_cons) read_cons = foldr1 mk_alt (read_nullary_cons ++ read_non_nullary_cons) read_non_nullary_cons = map read_non_nullary_con non_nullary_cons @@ -768,17 +767,17 @@ gen_Read_binds get_fixity tycon read_nullary_cons = case nullary_cons of [] -> [] - [con] -> [mkHsDo DoExpr [bindLex (ident_pat (data_con_str con)), - result_stmt con []] loc] - _ -> [HsApp (HsVar choose_RDR) - (ExplicitList placeHolderType (map mk_pair nullary_cons))] + [con] -> [nlHsDo DoExpr [bindLex (ident_pat (data_con_str con)), + result_stmt con []]] + _ -> [nlHsApp (nlHsVar choose_RDR) + (nlList (map mk_pair nullary_cons))] - mk_pair con = ExplicitTuple [HsLit (data_con_str con), - HsApp (HsVar returnM_RDR) (HsVar (getRdrName con))] + mk_pair con = nlTuple [nlHsLit (data_con_str con), + nlHsApp (nlHsVar returnM_RDR) (nlHsVar (getRdrName con))] Boxed read_non_nullary_con data_con - = mkHsApps prec_RDR [mkHsIntLit prec, mkHsDo DoExpr stmts loc] + = nlHsApps prec_RDR [nlHsIntLit prec, nlHsDo DoExpr stmts] where stmts | is_infix = infix_stmts | length labels > 0 = lbl_stmts @@ -817,24 +816,24 @@ gen_Read_binds get_fixity tycon -- Helpers ------------------------------------------------------------------------ mk_alt e1 e2 = genOpApp e1 alt_RDR e2 - bindLex pat = BindStmt pat (HsVar lexP_RDR) loc - result_stmt c as = ResultStmt (HsApp (HsVar returnM_RDR) (con_app c as)) loc - con_app c as = mkHsVarApps (getRdrName c) as + bindLex pat = nlBindStmt pat (nlHsVar lexP_RDR) + result_stmt c as = nlResultStmt (nlHsApp (nlHsVar returnM_RDR) (con_app c as)) + con_app c as = nlHsVarApps (getRdrName c) as - punc_pat s = ConPatIn punc_RDR (PrefixCon [LitPat (mkHsString s)]) -- Punc 'c' - ident_pat s = ConPatIn ident_RDR (PrefixCon [LitPat s]) -- Ident "foo" - symbol_pat s = ConPatIn symbol_RDR (PrefixCon [LitPat s]) -- Symbol ">>" + punc_pat s = nlConPat punc_RDR [nlLitPat (mkHsString s)] -- Punc 'c' + ident_pat s = nlConPat ident_RDR [nlLitPat s] -- Ident "foo" + symbol_pat s = nlConPat symbol_RDR [nlLitPat s] -- Symbol ">>" data_con_str con = mkHsString (occNameUserString (getOccName con)) read_punc c = bindLex (punc_pat c) read_arg a ty | isUnLiftedType ty = pprPanic "Error in deriving:" (text "Can't read unlifted types yet:" <+> ppr ty) - | otherwise = BindStmt (VarPat a) (mkHsVarApps step_RDR [readPrec_RDR]) loc + | otherwise = nlBindStmt (nlVarPat a) (nlHsVarApps step_RDR [readPrec_RDR]) read_field lbl a = read_lbl lbl ++ [read_punc "=", - BindStmt (VarPat a) (mkHsVarApps reset_RDR [readPrec_RDR]) loc] + nlBindStmt (nlVarPat a) (nlHsVarApps reset_RDR [readPrec_RDR])] -- When reading field labels we might encounter -- a = 3 @@ -884,17 +883,17 @@ Example -- the most tightly-binding operator \begin{code} -gen_Show_binds :: FixityEnv -> TyCon -> RdrNameMonoBinds +gen_Show_binds :: FixityEnv -> TyCon -> LHsBinds RdrName gen_Show_binds get_fixity tycon - = shows_prec `AndMonoBinds` show_list + = listToBag [shows_prec, show_list] where - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon ----------------------------------------------------------------------- - show_list = mkVarMonoBind tycon_loc showList_RDR - (HsApp (HsVar showList___RDR) (HsPar (HsApp (HsVar showsPrec_RDR) (mkHsIntLit 0)))) + show_list = mkVarBind tycon_loc showList_RDR + (nlHsApp (nlHsVar showList___RDR) (nlHsPar (nlHsApp (nlHsVar showsPrec_RDR) (nlHsIntLit 0)))) ----------------------------------------------------------------------- - shows_prec = mk_FunMonoBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) + shows_prec = mk_FunBind tycon_loc showsPrec_RDR (map pats_etc (tyConDataCons tycon)) where pats_etc data_con | nullary_con = -- skip the showParen junk... @@ -902,14 +901,14 @@ gen_Show_binds get_fixity tycon ([wildPat, con_pat], mk_showString_app con_str) | otherwise = ([a_Pat, con_pat], - showParen_Expr (HsPar (genOpApp a_Expr ge_RDR (HsLit (HsInt con_prec_plus_one)))) - (HsPar (nested_compose_Expr show_thingies))) + showParen_Expr (nlHsPar (genOpApp a_Expr ge_RDR (nlHsLit (HsInt con_prec_plus_one)))) + (nlHsPar (nested_compose_Expr show_thingies))) where data_con_RDR = getRdrName data_con con_arity = dataConSourceArity data_con bs_needed = take con_arity bs_RDRs arg_tys = dataConOrigArgTys data_con -- Correspond 1-1 with bs_needed - con_pat = mkConPat data_con_RDR bs_needed + con_pat = nlConVarPat data_con_RDR bs_needed nullary_con = con_arity == 0 labels = dataConFieldLabels data_con lab_fields = length labels @@ -939,7 +938,7 @@ gen_Show_binds get_fixity tycon show_args = zipWith show_arg bs_needed arg_tys (show_arg1:show_arg2:_) = show_args - show_prefix_args = intersperse (HsVar showSpace_RDR) show_args + show_prefix_args = intersperse (nlHsVar showSpace_RDR) show_args -- Assumption for record syntax: no of fields == no of labelled fields -- (and in same order) @@ -952,8 +951,8 @@ gen_Show_binds get_fixity tycon -- Generates (showsPrec p x) for argument x, but it also boxes -- the argument first if necessary. Note that this prints unboxed -- things without any '#' decorations; could change that if need be - show_arg b arg_ty = mkHsApps showsPrec_RDR [HsLit (HsInt arg_prec), - box_if_necy "Show" tycon (HsVar b) arg_ty] + show_arg b arg_ty = nlHsApps showsPrec_RDR [nlHsLit (HsInt arg_prec), + box_if_necy "Show" tycon (nlHsVar b) arg_ty] -- Fixity stuff is_infix = isDataSymOcc dc_occ_nm @@ -961,7 +960,7 @@ gen_Show_binds get_fixity tycon arg_prec | record_syntax = 0 -- Record fields don't need parens | otherwise = con_prec_plus_one -mk_showString_app str = HsApp (HsVar showString_RDR) (HsLit (mkHsString str)) +mk_showString_app str = nlHsApp (nlHsVar showString_RDR) (nlHsLit (mkHsString str)) \end{code} \begin{code} @@ -1002,18 +1001,19 @@ we generate Notice the use of lexically scoped type variables. \begin{code} -gen_Typeable_binds :: TyCon -> RdrNameMonoBinds +gen_Typeable_binds :: TyCon -> LHsBinds RdrName gen_Typeable_binds tycon - = mk_easy_FunMonoBind tycon_loc typeOf_RDR [wildPat] [] - (mkHsApps mkTypeRep_RDR [tycon_rep, arg_reps]) + = unitBag $ + mk_easy_FunBind tycon_loc typeOf_RDR [wildPat] emptyBag + (nlHsApps mkTypeRep_RDR [tycon_rep, arg_reps]) where - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon tyvars = tyConTyVars tycon - tycon_rep = HsVar mkTyConRep_RDR `HsApp` HsLit (mkHsString (showSDoc (ppr tycon))) - arg_reps = ExplicitList placeHolderType (map mk tyvars) - mk tyvar = HsApp (HsVar typeOf_RDR) - (ExprWithTySig (HsVar undefined_RDR) - (HsTyVar (getRdrName tyvar))) + tycon_rep = nlHsVar mkTyConRep_RDR `nlHsApp` nlHsLit (mkHsString (showSDoc (ppr tycon))) + arg_reps = nlList (map mk tyvars) + mk tyvar = nlHsApp (nlHsVar typeOf_RDR) + (noLoc (ExprWithTySig (nlHsVar undefined_RDR) + (nlHsTyVar (getRdrName tyvar)))) \end{code} @@ -1051,58 +1051,58 @@ we generate \begin{code} gen_Data_binds :: FixityEnv -> TyCon - -> (RdrNameMonoBinds, -- The method bindings - RdrNameMonoBinds) -- Auxiliary bindings + -> (LHsBinds RdrName, -- The method bindings + LHsBinds RdrName) -- Auxiliary bindings gen_Data_binds fix_env tycon - = (andMonoBindList [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind], + = (listToBag [gfoldl_bind, fromCon_bind, toCon_bind, dataTypeOf_bind], -- Auxiliary definitions: the data type and constructors - datatype_bind `AndMonoBinds` andMonoBindList (map mk_con_bind data_cons)) + datatype_bind `consBag` listToBag (map mk_con_bind data_cons)) where - tycon_loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon tycon_name = tyConName tycon data_cons = tyConDataCons tycon ------------ gfoldl - gfoldl_bind = mk_FunMonoBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) - gfoldl_eqn con = ([VarPat k_RDR, VarPat z_RDR, mkConPat con_name as_needed], - foldl mk_k_app (HsVar z_RDR `HsApp` HsVar con_name) as_needed) + gfoldl_bind = mk_FunBind tycon_loc gfoldl_RDR (map gfoldl_eqn data_cons) + gfoldl_eqn con = ([nlVarPat k_RDR, nlVarPat z_RDR, nlConVarPat con_name as_needed], + foldl mk_k_app (nlHsVar z_RDR `nlHsApp` nlHsVar con_name) as_needed) where - con_name :: RdrName + con_name :: RdrName con_name = getRdrName con as_needed = take (dataConSourceArity con) as_RDRs - mk_k_app e v = HsPar (mkHsOpApp e k_RDR (HsVar v)) + mk_k_app e v = nlHsPar (nlHsOpApp e k_RDR (nlHsVar v)) ------------ fromConstr - fromCon_bind = mk_FunMonoBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)] - from_con_rhs = HsCase (HsVar conIndex_RDR `HsApp` c_Expr) - (map from_con_alt data_cons) tycon_loc - from_con_alt dc = mkSimpleHsAlt (ConPatIn intDataCon_RDR (PrefixCon [LitPat (HsIntPrim (toInteger (dataConTag dc)))])) - (mkHsVarApps (getRdrName dc) + fromCon_bind = mk_FunBind tycon_loc fromConstr_RDR [([c_Pat], from_con_rhs)] + from_con_rhs = nlHsCase (nlHsVar conIndex_RDR `nlHsApp` c_Expr) + (map from_con_alt data_cons) + from_con_alt dc = mkSimpleHsAlt (nlConPat intDataCon_RDR [nlLitPat (HsIntPrim (toInteger (dataConTag dc)))]) + (nlHsVarApps (getRdrName dc) (replicate (dataConSourceArity dc) undefined_RDR)) ------------ toConstr - toCon_bind = mk_FunMonoBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) - to_con_eqn dc = ([mkWildConPat dc], HsVar (mk_constr_name dc)) + toCon_bind = mk_FunBind tycon_loc toConstr_RDR (map to_con_eqn data_cons) + to_con_eqn dc = ([nlWildConPat dc], nlHsVar (mk_constr_name dc)) ------------ dataTypeOf - dataTypeOf_bind = mk_easy_FunMonoBind tycon_loc dataTypeOf_RDR [wildPat] - [] (HsVar data_type_name) + dataTypeOf_bind = mk_easy_FunBind tycon_loc dataTypeOf_RDR [wildPat] + emptyBag (nlHsVar data_type_name) ------------ $dT data_type_name = mkDerivedRdrName tycon_name mkDataTOcc - datatype_bind = mkVarMonoBind tycon_loc data_type_name - (HsVar mkDataType_RDR `HsApp` - ExplicitList placeHolderType constrs) - constrs = [HsVar (mk_constr_name con) | con <- data_cons] + datatype_bind = mkVarBind tycon_loc data_type_name + (nlHsVar mkDataType_RDR `nlHsApp` + nlList constrs) + constrs = [nlHsVar (mk_constr_name con) | con <- data_cons] ------------ $cT1 etc mk_constr_name con = mkDerivedRdrName (dataConName con) mkDataCOcc - mk_con_bind dc = mkVarMonoBind tycon_loc (mk_constr_name dc) - (mkHsApps mkConstr_RDR (constr_args dc)) - constr_args dc = [mkHsIntLit (toInteger (dataConTag dc)), -- Tag - HsLit (mkHsString (occNameUserString dc_occ)), -- String name - HsVar fixity] -- Fixity + mk_con_bind dc = mkVarBind tycon_loc (mk_constr_name dc) + (nlHsApps mkConstr_RDR (constr_args dc)) + constr_args dc = [nlHsIntLit (toInteger (dataConTag dc)), -- Tag + nlHsLit (mkHsString (occNameUserString dc_occ)), -- String name + nlHsVar fixity] -- Fixity where dc_occ = getOccName dc is_infix = isDataSymOcc dc_occ @@ -1142,53 +1142,53 @@ data TagThingWanted = GenCon2Tag | GenTag2Con | GenMaxTag gen_tag_n_con_monobind - :: (RdrName, -- (proto)Name for the thing in question + :: ( RdrName, -- (proto)Name for the thing in question TyCon, -- tycon in question TagThingWanted) - -> RdrNameMonoBinds + -> LHsBind RdrName gen_tag_n_con_monobind (rdr_name, tycon, GenCon2Tag) | lots_of_constructors - = mk_FunMonoBind loc rdr_name [([], get_tag_rhs)] + = mk_FunBind tycon_loc rdr_name [([], get_tag_rhs)] | otherwise - = mk_FunMonoBind loc rdr_name (map mk_stuff (tyConDataCons tycon)) + = mk_FunBind tycon_loc rdr_name (map mk_stuff (tyConDataCons tycon)) where - loc = getSrcLoc tycon + tycon_loc = getSrcSpan tycon tvs = map (mkRdrUnqual . getOccName) (tyConTyVars tycon) - -- We can't use gerRdrName because that makes an Exact RdrName + -- We can't use gerRdrName because that makes an Exact RdrName -- and we can't put them in the LocalRdrEnv -- Give a signature to the bound variable, so -- that the case expression generated by getTag is -- monomorphic. In the push-enter model we get better code. - get_tag_rhs = ExprWithTySig - (HsLam (mkSimpleHsAlt (VarPat a_RDR) - (HsApp (HsVar getTag_RDR) a_Expr))) - (mkExplicitHsForAllTy (map UserTyVar tvs) [] con2tag_ty) + get_tag_rhs = noLoc $ ExprWithTySig + (nlHsLam (mkSimpleHsAlt (nlVarPat a_RDR) + (nlHsApp (nlHsVar getTag_RDR) a_Expr))) + (noLoc (mkExplicitHsForAllTy (map (noLoc.UserTyVar) tvs) (noLoc []) con2tag_ty)) - con2tag_ty = foldl HsAppTy (HsTyVar (getRdrName tycon)) - (map HsTyVar tvs) - `HsFunTy` - HsTyVar (getRdrName intPrimTyCon) + con2tag_ty = foldl nlHsAppTy (nlHsTyVar (getRdrName tycon)) + (map nlHsTyVar tvs) + `nlHsFunTy` + nlHsTyVar (getRdrName intPrimTyCon) lots_of_constructors = tyConFamilySize tycon > mAX_FAMILY_SIZE_FOR_VEC_RETURNS - mk_stuff :: DataCon -> ([RdrNamePat], RdrNameHsExpr) - mk_stuff con = ([mkWildConPat con], - HsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) + mk_stuff :: DataCon -> ([LPat RdrName], LHsExpr RdrName) + mk_stuff con = ([nlWildConPat con], + nlHsLit (HsIntPrim (toInteger ((dataConTag con) - fIRST_TAG)))) gen_tag_n_con_monobind (rdr_name, tycon, GenTag2Con) - = mk_FunMonoBind (getSrcLoc tycon) rdr_name - [([mkConPat intDataCon_RDR [a_RDR]], - ExprWithTySig (HsApp (HsVar tagToEnum_RDR) a_Expr) - (HsTyVar (getRdrName tycon)))] + = mk_FunBind (getSrcSpan tycon) rdr_name + [([nlConVarPat intDataCon_RDR [a_RDR]], + noLoc (ExprWithTySig (nlHsApp (nlHsVar tagToEnum_RDR) a_Expr) + (nlHsTyVar (getRdrName tycon))))] gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) - = mkVarMonoBind (getSrcLoc tycon) rdr_name - (HsApp (HsVar intDataCon_RDR) (HsLit (HsIntPrim max_tag))) + = mkVarBind (getSrcSpan tycon) rdr_name + (nlHsApp (nlHsVar intDataCon_RDR) (nlHsLit (HsIntPrim max_tag))) where max_tag = case (tyConDataCons tycon) of data_cons -> toInteger ((length data_cons) - fIRST_TAG) @@ -1201,95 +1201,39 @@ gen_tag_n_con_monobind (rdr_name, tycon, GenMaxTag) %* * %************************************************************************ -@mk_easy_FunMonoBind fun pats binds expr@ generates: -\begin{verbatim} - fun pat1 pat2 ... patN = expr where binds -\end{verbatim} - -@mk_FunMonoBind fun [([p1a, p1b, ...], e1), ...]@ is for -multi-clause definitions; it generates: -\begin{verbatim} - fun p1a p1b ... p1N = e1 - fun p2a p2b ... p2N = e2 - ... - fun pMa pMb ... pMN = eM -\end{verbatim} - -\begin{code} -mkVarMonoBind :: SrcLoc -> RdrName -> RdrNameHsExpr -> RdrNameMonoBinds -mkVarMonoBind loc var rhs = mk_easy_FunMonoBind loc var [] [] rhs - -mk_easy_FunMonoBind :: SrcLoc -> RdrName -> [RdrNamePat] - -> [RdrNameMonoBinds] -> RdrNameHsExpr - -> RdrNameMonoBinds - -mk_easy_FunMonoBind loc fun pats binds expr - = FunMonoBind fun False{-not infix-} [mk_easy_Match loc pats binds expr] loc - -mk_easy_Match loc pats binds expr - = mk_match loc pats expr (mkMonoBind Recursive (andMonoBindList binds)) - -- The renamer expects everything in its input to be a - -- "recursive" MonoBinds, and it is its job to sort things out - -- from there. - -mk_FunMonoBind :: SrcLoc -> RdrName - -> [([RdrNamePat], RdrNameHsExpr)] - -> RdrNameMonoBinds - -mk_FunMonoBind loc fun [] = panic "TcGenDeriv:mk_FunMonoBind" -mk_FunMonoBind loc fun pats_and_exprs - = FunMonoBind fun False{-not infix-} - [ mk_match loc p e EmptyBinds | (p,e) <-pats_and_exprs ] - loc - -mk_match loc pats expr binds - = Match (map paren pats) Nothing - (GRHSs (unguardedRHS expr loc) binds placeHolderType) - where - paren p@(VarPat _) = p - paren other_p = ParPat other_p - -mkWildConPat :: DataCon -> Pat RdrName -mkWildConPat con = ConPatIn (getRdrName con) (PrefixCon (nOfThem (dataConSourceArity con) wildPat)) - -wildPat :: Pat id -wildPat = WildPat placeHolderType -- Pre-typechecking -\end{code} ToDo: Better SrcLocs. \begin{code} compare_gen_Case :: - RdrNameHsExpr -- What to do for equality - -> RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr + LHsExpr RdrName -- What to do for equality + -> LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName careful_compare_Case :: -- checks for primitive types... TyCon -- The tycon we are deriving for -> Type - -> RdrNameHsExpr -- What to do for equality - -> RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr + -> LHsExpr RdrName -- What to do for equality + -> LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName -cmp_eq_Expr a b = HsApp (HsApp (HsVar cmp_eq_RDR) a) b +cmp_eq_Expr a b = nlHsApp (nlHsApp (nlHsVar cmp_eq_RDR) a) b -- Was: compare_gen_Case cmp_eq_RDR -compare_gen_Case (HsVar eq_tag) a b | eq_tag == eqTag_RDR - = HsApp (HsApp (HsVar compare_RDR) a) b -- Simple case +compare_gen_Case (L _ (HsVar eq_tag)) a b | eq_tag == eqTag_RDR + = nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b -- Simple case compare_gen_Case eq a b -- General case - = HsCase (HsPar (HsApp (HsApp (HsVar compare_RDR) a) b)) {-of-} - [mkSimpleHsAlt (mkNullaryConPat ltTag_RDR) ltTag_Expr, - mkSimpleHsAlt (mkNullaryConPat eqTag_RDR) eq, - mkSimpleHsAlt (mkNullaryConPat gtTag_RDR) gtTag_Expr] - generatedSrcLoc + = nlHsCase (nlHsPar (nlHsApp (nlHsApp (nlHsVar compare_RDR) a) b)) {-of-} + [mkSimpleHsAlt (nlNullaryConPat ltTag_RDR) ltTag_Expr, + mkSimpleHsAlt (nlNullaryConPat eqTag_RDR) eq, + mkSimpleHsAlt (nlNullaryConPat gtTag_RDR) gtTag_Expr] careful_compare_Case tycon ty eq a b | not (isUnLiftedType ty) = compare_gen_Case eq a b | otherwise -- We have to do something special for primitive things... - = HsIf (genOpApp a relevant_eq_op b) + = nlHsIf (genOpApp a relevant_eq_op b) eq - (HsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr generatedSrcLoc) - generatedSrcLoc + (nlHsIf (genOpApp a relevant_lt_op b) ltTag_Expr gtTag_Expr) where relevant_eq_op = primOpRdrName (assoc_ty_id "Ord" tycon eq_op_tbl ty) relevant_lt_op = primOpRdrName (assoc_ty_id "Ord" tycon lt_op_tbl ty) @@ -1297,11 +1241,11 @@ careful_compare_Case tycon ty eq a b box_if_necy :: String -- The class involved -> TyCon -- The tycon involved - -> RdrNameHsExpr -- The argument + -> LHsExpr RdrName -- The argument -> Type -- The argument type - -> RdrNameHsExpr -- Boxed version of the arg + -> LHsExpr RdrName -- Boxed version of the arg box_if_necy cls_str tycon arg arg_ty - | isUnLiftedType arg_ty = HsApp (HsVar box_con) arg + | isUnLiftedType arg_ty = nlHsApp (nlHsVar box_con) arg | otherwise = arg where box_con = assoc_ty_id cls_str tycon box_con_tbl arg_ty @@ -1349,12 +1293,12 @@ box_con_tbl = ----------------------------------------------------------------------- -and_Expr :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr +and_Expr :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName and_Expr a b = genOpApp a and_RDR b ----------------------------------------------------------------------- -eq_Expr :: TyCon -> Type -> RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr +eq_Expr :: TyCon -> Type -> LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName eq_Expr tycon ty a b = genOpApp a eq_op b where eq_op @@ -1365,78 +1309,81 @@ eq_Expr tycon ty a b = genOpApp a eq_op b \end{code} \begin{code} -untag_Expr :: TyCon -> [(RdrName, RdrName)] -> RdrNameHsExpr -> RdrNameHsExpr +untag_Expr :: TyCon -> [( RdrName, RdrName)] -> LHsExpr RdrName -> LHsExpr RdrName untag_Expr tycon [] expr = expr untag_Expr tycon ((untag_this, put_tag_here) : more) expr - = HsCase (HsPar (mkHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} - [mkSimpleHsAlt (VarPat put_tag_here) (untag_Expr tycon more expr)] - generatedSrcLoc + = nlHsCase (nlHsPar (nlHsVarApps (con2tag_RDR tycon) [untag_this])) {-of-} + [mkSimpleHsAlt (nlVarPat put_tag_here) (untag_Expr tycon more expr)] -cmp_tags_Expr :: RdrName -- Comparison op - -> RdrName -> RdrName -- Things to compare - -> RdrNameHsExpr -- What to return if true - -> RdrNameHsExpr -- What to return if false - -> RdrNameHsExpr +cmp_tags_Expr :: RdrName -- Comparison op + -> RdrName -> RdrName -- Things to compare + -> LHsExpr RdrName -- What to return if true + -> LHsExpr RdrName -- What to return if false + -> LHsExpr RdrName cmp_tags_Expr op a b true_case false_case - = HsIf (genOpApp (HsVar a) op (HsVar b)) true_case false_case generatedSrcLoc + = nlHsIf (genOpApp (nlHsVar a) op (nlHsVar b)) true_case false_case enum_from_to_Expr - :: RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr + :: LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName enum_from_then_to_Expr - :: RdrNameHsExpr -> RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr + :: LHsExpr RdrName -> LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName -enum_from_to_Expr f t2 = HsApp (HsApp (HsVar enumFromTo_RDR) f) t2 -enum_from_then_to_Expr f t t2 = HsApp (HsApp (HsApp (HsVar enumFromThenTo_RDR) f) t) t2 +enum_from_to_Expr f t2 = nlHsApp (nlHsApp (nlHsVar enumFromTo_RDR) f) t2 +enum_from_then_to_Expr f t t2 = nlHsApp (nlHsApp (nlHsApp (nlHsVar enumFromThenTo_RDR) f) t) t2 showParen_Expr - :: RdrNameHsExpr -> RdrNameHsExpr - -> RdrNameHsExpr + :: LHsExpr RdrName -> LHsExpr RdrName + -> LHsExpr RdrName -showParen_Expr e1 e2 = HsApp (HsApp (HsVar showParen_RDR) e1) e2 +showParen_Expr e1 e2 = nlHsApp (nlHsApp (nlHsVar showParen_RDR) e1) e2 -nested_compose_Expr :: [RdrNameHsExpr] -> RdrNameHsExpr +nested_compose_Expr :: [LHsExpr RdrName] -> LHsExpr RdrName nested_compose_Expr [e] = parenify e nested_compose_Expr (e:es) - = HsApp (HsApp (HsVar compose_RDR) (parenify e)) (nested_compose_Expr es) + = nlHsApp (nlHsApp (nlHsVar compose_RDR) (parenify e)) (nested_compose_Expr es) -- impossible_Expr is used in case RHSs that should never happen. -- We generate these to keep the desugarer from complaining that they *might* happen! -impossible_Expr = HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString "Urk! in TcGenDeriv"))) +impossible_Expr = nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString "Urk! in TcGenDeriv")) -- illegal_Expr is used when signalling error conditions in the RHS of a derived -- method. It is currently only used by Enum.{succ,pred} illegal_Expr meth tp msg = - HsApp (HsVar error_RDR) (HsLit (HsString (mkFastString (meth ++ '{':tp ++ "}: " ++ msg)))) + nlHsApp (nlHsVar error_RDR) (nlHsLit (mkHsString (meth ++ '{':tp ++ "}: " ++ msg))) -- illegal_toEnum_tag is an extended version of illegal_Expr, which also allows you -- to include the value of a_RDR in the error string. illegal_toEnum_tag tp maxtag = - HsApp (HsVar error_RDR) - (HsApp (HsApp (HsVar append_RDR) - (HsLit (HsString (mkFastString ("toEnum{" ++ tp ++ "}: tag ("))))) - (HsApp (HsApp (HsApp - (HsVar showsPrec_RDR) - (mkHsIntLit 0)) - (HsVar a_RDR)) - (HsApp (HsApp - (HsVar append_RDR) - (HsLit (HsString (mkFastString ") is outside of enumeration's range (0,")))) - (HsApp (HsApp (HsApp - (HsVar showsPrec_RDR) - (mkHsIntLit 0)) - (HsVar maxtag)) - (HsLit (HsString (mkFastString ")"))))))) - -parenify e@(HsVar _) = e -parenify e = HsPar e + nlHsApp (nlHsVar error_RDR) + (nlHsApp (nlHsApp (nlHsVar append_RDR) + (nlHsLit (mkHsString ("toEnum{" ++ tp ++ "}: tag (")))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar a_RDR)) + (nlHsApp (nlHsApp + (nlHsVar append_RDR) + (nlHsLit (mkHsString ") is outside of enumeration's range (0,"))) + (nlHsApp (nlHsApp (nlHsApp + (nlHsVar showsPrec_RDR) + (nlHsIntLit 0)) + (nlHsVar maxtag)) + (nlHsLit (mkHsString ")")))))) + +parenify e@(L _ (HsVar _)) = e +parenify e = mkHsPar e -- genOpApp wraps brackets round the operator application, so that the -- renamer won't subsequently try to re-associate it. -genOpApp e1 op e2 = HsPar (mkHsOpApp e1 op e2) +genOpApp e1 op e2 = nlHsPar (nlHsOpApp e1 op e2) +\end{code} + +\begin{code} +getSrcSpan = srcLocSpan . getSrcLoc \end{code} \begin{code} @@ -1457,22 +1404,22 @@ as_RDRs = [ mkVarUnqual (mkFastString ("a"++show i)) | i <- [(1::Int) .. ] ] bs_RDRs = [ mkVarUnqual (mkFastString ("b"++show i)) | i <- [(1::Int) .. ] ] cs_RDRs = [ mkVarUnqual (mkFastString ("c"++show i)) | i <- [(1::Int) .. ] ] -a_Expr = HsVar a_RDR -b_Expr = HsVar b_RDR -c_Expr = HsVar c_RDR -ltTag_Expr = HsVar ltTag_RDR -eqTag_Expr = HsVar eqTag_RDR -gtTag_Expr = HsVar gtTag_RDR -false_Expr = HsVar false_RDR -true_Expr = HsVar true_RDR - -a_Pat = VarPat a_RDR -b_Pat = VarPat b_RDR -c_Pat = VarPat c_RDR -d_Pat = VarPat d_RDR - -con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName --- Generates Orig RdrNames, for the binding positions +a_Expr = nlHsVar a_RDR +b_Expr = nlHsVar b_RDR +c_Expr = nlHsVar c_RDR +ltTag_Expr = nlHsVar ltTag_RDR +eqTag_Expr = nlHsVar eqTag_RDR +gtTag_Expr = nlHsVar gtTag_RDR +false_Expr = nlHsVar false_RDR +true_Expr = nlHsVar true_RDR + +a_Pat = nlVarPat a_RDR +b_Pat = nlVarPat b_RDR +c_Pat = nlVarPat c_RDR +d_Pat = nlVarPat d_RDR + +con2tag_RDR, tag2con_RDR, maxtag_RDR :: TyCon -> RdrName +-- Generates Orig s RdrName, for the binding positions con2tag_RDR tycon = mk_tc_deriv_name tycon "con2tag_" tag2con_RDR tycon = mk_tc_deriv_name tycon "tag2con_" maxtag_RDR tycon = mk_tc_deriv_name tycon "maxtag_" @@ -1486,7 +1433,7 @@ mk_tc_deriv_name tycon str new_str = str ++ occNameString tc_occ ++ "#" \end{code} -RdrNames for PrimOps. Can't be done in PrelNames, because PrimOp imports +s RdrName for PrimOps. Can't be done in PrelNames, because PrimOp imports PrelNames, so PrelNames can't import PrimOp. \begin{code} diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 62c9c7a756..8968e49f42 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -8,26 +8,12 @@ checker. \begin{code} module TcHsSyn ( - TcMonoBinds, TcHsBinds, TcPat, - TcExpr, TcGRHSs, TcGRHS, TcMatch, - TcStmt, TcArithSeqInfo, TcRecordBinds, - TcHsModule, TcDictBinds, - TcForeignDecl, - TcCmd, TcCmdTop, - - TypecheckedHsBinds, TypecheckedRuleDecl, - TypecheckedMonoBinds, TypecheckedPat, - TypecheckedHsExpr, TypecheckedArithSeqInfo, - TypecheckedStmt, TypecheckedForeignDecl, - TypecheckedMatch, TypecheckedHsModule, - TypecheckedGRHSs, TypecheckedGRHS, - TypecheckedRecordBinds, TypecheckedDictBinds, - TypecheckedMatchContext, TypecheckedCoreBind, - TypecheckedHsCmd, TypecheckedHsCmdTop, - + TcDictBinds, mkHsTyApp, mkHsDictApp, mkHsConApp, - mkHsTyLam, mkHsDictLam, mkHsLet, - hsLitType, hsPatType, + mkHsTyLam, mkHsDictLam, mkHsLet, mkHsApp, + hsLitType, hsPatType, mkHsAppTy, mkSimpleHsAlt, + nlHsIntLit, glueBindsOnGRHSs, + -- Coercions Coercion, ExprCoFn, PatCoFn, @@ -37,7 +23,7 @@ module TcHsSyn ( -- re-exported from TcMonad TcId, TcIdSet, - zonkTopBinds, zonkTopDecls, zonkTopExpr, + zonkTopDecls, zonkTopExpr, zonkTopLExpr, zonkId, zonkTopBndrs ) where @@ -48,7 +34,6 @@ import HsSyn -- oodles of it -- others: import Id ( idType, setIdType, Id ) -import DataCon ( dataConWrapId ) import TcRnMonad import Type ( Type ) @@ -65,88 +50,22 @@ import TysWiredIn ( charTy, stringTy, intTy, voidTy, listTyCon, tupleTyCon ) import TyCon ( mkPrimTyCon, tyConKind ) import PrimRep ( PrimRep(VoidRep) ) -import CoreSyn ( CoreExpr ) -import Name ( Name, getOccName, mkInternalName, mkDerivedTyConOcc ) -import Var ( isId, isLocalVar, tyVarKind ) +import Name ( getOccName, mkInternalName, mkDerivedTyConOcc ) +import Var ( Var, isId, isLocalVar, tyVarKind ) import VarSet import VarEnv -import BasicTypes ( RecFlag(..), Boxity(..), IPName(..), ipNameName, mapIPName ) +import BasicTypes ( Boxity(..), IPName(..), ipNameName, mapIPName ) import Maybes ( orElse ) import Maybe ( isNothing ) import Unique ( Uniquable(..) ) -import SrcLoc ( noSrcLoc ) +import SrcLoc ( noSrcLoc, noLoc, Located(..), unLoc ) import Bag import Outputable \end{code} -Type definitions -~~~~~~~~~~~~~~~~ - -The @Tc...@ datatypes are the ones that apply {\em during} type checking. -All the types in @Tc...@ things have mutable type-variables in them for -unification. - -At the end of type checking we zonk everything to @Typechecked...@ datatypes, -which have immutable type variables in them. - -\begin{code} -type TcHsBinds = HsBinds TcId -type TcMonoBinds = MonoBinds TcId -type TcDictBinds = TcMonoBinds -type TcPat = OutPat TcId -type TcExpr = HsExpr TcId -type TcGRHSs = GRHSs TcId -type TcGRHS = GRHS TcId -type TcMatch = Match TcId -type TcStmt = Stmt TcId -type TcArithSeqInfo = ArithSeqInfo TcId -type TcRecordBinds = HsRecordBinds TcId -type TcHsModule = HsModule TcId -type TcForeignDecl = ForeignDecl TcId -type TcRuleDecl = RuleDecl TcId -type TcCmd = HsCmd TcId -type TcCmdTop = HsCmdTop TcId - -type TypecheckedPat = OutPat Id -type TypecheckedMonoBinds = MonoBinds Id -type TypecheckedDictBinds = TypecheckedMonoBinds -type TypecheckedHsBinds = HsBinds Id -type TypecheckedHsExpr = HsExpr Id -type TypecheckedArithSeqInfo = ArithSeqInfo Id -type TypecheckedStmt = Stmt Id -type TypecheckedMatch = Match Id -type TypecheckedGRHSs = GRHSs Id -type TypecheckedGRHS = GRHS Id -type TypecheckedRecordBinds = HsRecordBinds Id -type TypecheckedHsModule = HsModule Id -type TypecheckedForeignDecl = ForeignDecl Id -type TypecheckedRuleDecl = RuleDecl Id -type TypecheckedCoreBind = (Id, CoreExpr) -type TypecheckedHsCmd = HsCmd Id -type TypecheckedHsCmdTop = HsCmdTop Id - -type TypecheckedMatchContext = HsMatchContext Name -- Keeps consistency with - -- HsDo arg StmtContext -\end{code} - \begin{code} -mkHsTyApp expr [] = expr -mkHsTyApp expr tys = TyApp expr tys - -mkHsDictApp expr [] = expr -mkHsDictApp expr dict_vars = DictApp expr dict_vars - -mkHsTyLam [] expr = expr -mkHsTyLam tyvars expr = TyLam tyvars expr - -mkHsDictLam [] expr = expr -mkHsDictLam dicts expr = DictLam dicts expr - -mkHsLet EmptyMonoBinds expr = expr -mkHsLet mbinds expr = HsLet (MonoBind mbinds [] Recursive) expr - -mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHsTyApp` tys) args +type TcDictBinds = LHsBinds TcId -- Bag of dictionary bindings \end{code} @@ -159,22 +78,23 @@ mkHsConApp data_con tys args = foldl HsApp (HsVar (dataConWrapId data_con) `mkHs Note: If @hsPatType@ doesn't bear a strong resemblance to @exprType@, then something is wrong. \begin{code} -hsPatType :: TypecheckedPat -> Type - -hsPatType (ParPat pat) = hsPatType pat -hsPatType (WildPat ty) = ty -hsPatType (VarPat var) = idType var -hsPatType (LazyPat pat) = hsPatType pat -hsPatType (LitPat lit) = hsLitType lit -hsPatType (AsPat var pat) = idType var -hsPatType (ListPat _ ty) = mkListTy ty -hsPatType (PArrPat _ ty) = mkPArrTy ty -hsPatType (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats) -hsPatType (ConPatOut _ _ ty _ _) = ty -hsPatType (SigPatOut _ ty _) = ty -hsPatType (NPatOut lit ty _) = ty -hsPatType (NPlusKPatOut id _ _ _) = idType id -hsPatType (DictPat ds ms) = case (ds ++ ms) of +hsPatType :: OutPat Id -> Type +hsPatType pat = pat_type (unLoc pat) + +pat_type (ParPat pat) = hsPatType pat +pat_type (WildPat ty) = ty +pat_type (VarPat var) = idType var +pat_type (LazyPat pat) = hsPatType pat +pat_type (LitPat lit) = hsLitType lit +pat_type (AsPat var pat) = idType (unLoc var) +pat_type (ListPat _ ty) = mkListTy ty +pat_type (PArrPat _ ty) = mkPArrTy ty +pat_type (TuplePat pats box) = mkTupleTy box (length pats) (map hsPatType pats) +pat_type (ConPatOut _ _ ty _ _) = ty +pat_type (SigPatOut _ ty _) = ty +pat_type (NPatOut lit ty _) = ty +pat_type (NPlusKPatOut id _ _ _) = idType (unLoc id) +pat_type (DictPat ds ms) = case (ds ++ ms) of [] -> unitTy [d] -> idType d ds -> mkTupleTy Boxed (length ds) (map idType ds) @@ -203,8 +123,8 @@ hsLitType (HsDoublePrim d) = doublePrimTy type Coercion a = Maybe (a -> a) -- Nothing => identity fn -type ExprCoFn = Coercion TypecheckedHsExpr -type PatCoFn = Coercion TcPat +type ExprCoFn = Coercion (HsExpr TcId) +type PatCoFn = Coercion (Pat TcId) (<.>) :: Coercion a -> Coercion a -> Coercion a -- Composition Nothing <.> Nothing = Nothing @@ -312,117 +232,95 @@ zonkTopBndrs ids = zonkIdBndrs emptyZonkEnv ids \begin{code} -zonkTopExpr :: TcExpr -> TcM TypecheckedHsExpr +zonkTopExpr :: HsExpr TcId -> TcM (HsExpr Id) zonkTopExpr e = zonkExpr emptyZonkEnv e -zonkTopDecls :: TcMonoBinds -> [TcRuleDecl] -> [TcForeignDecl] +zonkTopLExpr :: LHsExpr TcId -> TcM (LHsExpr Id) +zonkTopLExpr e = zonkLExpr emptyZonkEnv e + +zonkTopDecls :: Bag (LHsBind TcId) -> [LRuleDecl TcId] -> [LForeignDecl TcId] -> TcM ([Id], - TypecheckedMonoBinds, - [TypecheckedForeignDecl], - [TypecheckedRuleDecl]) + Bag (LHsBind Id), + [LForeignDecl Id], + [LRuleDecl Id]) zonkTopDecls binds rules fords -- Top level is implicitly recursive = fixM (\ ~(new_ids, _, _, _) -> let zonk_env = mkZonkEnv new_ids in - zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) -> + zonkMonoBinds zonk_env binds `thenM` \ binds' -> zonkRules zonk_env rules `thenM` \ rules' -> zonkForeignExports zonk_env fords `thenM` \ fords' -> - returnM (bagToList new_ids, binds', fords', rules') - ) - -zonkTopBinds :: TcMonoBinds -> TcM ([Id], TypecheckedMonoBinds) -zonkTopBinds binds - = fixM (\ ~(new_ids, _) -> - let - zonk_env = mkZonkEnv new_ids - in - zonkMonoBinds zonk_env binds `thenM` \ (binds', new_ids) -> - returnM (bagToList new_ids, binds') + returnM (collectHsBindBinders binds', binds', fords', rules') ) --------------------------------------------- -zonkBinds :: ZonkEnv -> TcHsBinds -> TcM (ZonkEnv, TypecheckedHsBinds) -zonkBinds env EmptyBinds = returnM (env, EmptyBinds) - -zonkBinds env (ThenBinds b1 b2) - = zonkBinds env b1 `thenM` \ (env1, b1') -> - zonkBinds env1 b2 `thenM` \ (env2, b2') -> - returnM (env2, b1' `ThenBinds` b2') - -zonkBinds env (MonoBind bind sigs is_rec) +zonkGroup :: ZonkEnv -> HsBindGroup TcId -> TcM (ZonkEnv, HsBindGroup Id) +zonkGroup env (HsBindGroup bs sigs is_rec) = ASSERT( null sigs ) - fixM (\ ~(_, _, new_ids) -> - let - env1 = extendZonkEnv env (bagToList new_ids) - in - zonkMonoBinds env1 bind `thenM` \ (new_bind, new_ids) -> - returnM (env1, new_bind, new_ids) - ) `thenM` \ (env1, new_bind, _) -> - returnM (env1, mkMonoBind is_rec new_bind) - -zonkBinds env (IPBinds binds) - = mappM zonk_ip_bind binds `thenM` \ new_binds -> + do { (env1, bs') <- fixM (\ ~(_, new_binds) -> do + { let env1 = extendZonkEnv env (collectHsBindBinders new_binds) + ; bs' <- zonkMonoBinds env1 bs + ; return (env1, bs') }) + ; return (env1, HsBindGroup bs' [] is_rec) } + + +zonkGroup env (HsIPBinds binds) + = mappM (wrapLocM zonk_ip_bind) binds `thenM` \ new_binds -> let - env1 = extendZonkEnv env (map (ipNameName . fst) new_binds) + env1 = extendZonkEnv env [ipNameName n | L _ (IPBind n _) <- new_binds] in - returnM (env1, IPBinds new_binds) + returnM (env1, HsIPBinds new_binds) where - zonk_ip_bind (n, e) + zonk_ip_bind (IPBind n e) = mapIPNameTc (zonkIdBndr env) n `thenM` \ n' -> - zonkExpr env e `thenM` \ e' -> - returnM (n', e') - + zonkLExpr env e `thenM` \ e' -> + returnM (IPBind n' e') --------------------------------------------- -zonkMonoBinds :: ZonkEnv -> TcMonoBinds - -> TcM (TypecheckedMonoBinds, Bag Id) +zonkNestedBinds :: ZonkEnv -> [HsBindGroup TcId] -> TcM (ZonkEnv, [HsBindGroup Id]) +zonkNestedBinds env [] = return (env, []) +zonkNestedBinds env (b:bs) = do { (env1, b') <- zonkGroup env b + ; (env2, bs') <- zonkNestedBinds env1 bs + ; return (env2, b':bs') } -zonkMonoBinds env EmptyMonoBinds = returnM (EmptyMonoBinds, emptyBag) - -zonkMonoBinds env (AndMonoBinds mbinds1 mbinds2) - = zonkMonoBinds env mbinds1 `thenM` \ (b1', ids1) -> - zonkMonoBinds env mbinds2 `thenM` \ (b2', ids2) -> - returnM (b1' `AndMonoBinds` b2', - ids1 `unionBags` ids2) +--------------------------------------------- +zonkMonoBinds :: ZonkEnv -> Bag (LHsBind TcId) -> TcM (Bag (LHsBind Id)) +zonkMonoBinds env binds = mapBagM (wrapLocM (zonk_bind env)) binds -zonkMonoBinds env (PatMonoBind pat grhss locn) - = zonkPat env pat `thenM` \ (new_pat, ids) -> +zonk_bind :: ZonkEnv -> HsBind TcId -> TcM (HsBind Id) +zonk_bind env (PatBind pat grhss) + = zonkPat env pat `thenM` \ (new_pat, _) -> zonkGRHSs env grhss `thenM` \ new_grhss -> - returnM (PatMonoBind new_pat new_grhss locn, ids) + returnM (PatBind new_pat new_grhss) -zonkMonoBinds env (VarMonoBind var expr) - = zonkIdBndr env var `thenM` \ new_var -> - zonkExpr env expr `thenM` \ new_expr -> - returnM (VarMonoBind new_var new_expr, unitBag new_var) +zonk_bind env (VarBind var expr) + = zonkIdBndr env var `thenM` \ new_var -> + zonkLExpr env expr `thenM` \ new_expr -> + returnM (VarBind new_var new_expr) -zonkMonoBinds env (FunMonoBind var inf ms locn) - = zonkIdBndr env var `thenM` \ new_var -> +zonk_bind env (FunBind var inf ms) + = wrapLocM (zonkIdBndr env) var `thenM` \ new_var -> mappM (zonkMatch env) ms `thenM` \ new_ms -> - returnM (FunMonoBind new_var inf new_ms locn, unitBag new_var) + returnM (FunBind new_var inf new_ms) - -zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind) +zonk_bind env (AbsBinds tyvars dicts exports inlines val_binds) = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> -- No need to extend tyvar env: the effects are -- propagated through binding the tyvars themselves zonkIdBndrs env dicts `thenM` \ new_dicts -> - fixM (\ ~(_, _, val_bind_ids) -> + fixM (\ ~(new_val_binds, _) -> let env1 = extendZonkEnv (extendZonkEnv env new_dicts) - (bagToList val_bind_ids) + (collectHsBindBinders new_val_binds) in - zonkMonoBinds env1 val_bind `thenM` \ (new_val_bind, val_bind_ids) -> - mappM (zonkExport env1) exports `thenM` \ new_exports -> - returnM (new_val_bind, new_exports, val_bind_ids) - ) `thenM ` \ (new_val_bind, new_exports, _) -> - let - new_globals = listToBag [global | (_, global, local) <- new_exports] - in - returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind, - new_globals) + zonkMonoBinds env1 val_binds `thenM` \ new_val_binds -> + mappM (zonkExport env1) exports `thenM` \ new_exports -> + returnM (new_val_binds, new_exports) + ) `thenM` \ (new_val_bind, new_exports) -> + returnM (AbsBinds new_tyvars new_dicts new_exports inlines new_val_bind) where zonkExport env (tyvars, global, local) = zonkTcTyVars tyvars `thenM` \ tys -> @@ -442,25 +340,25 @@ zonkMonoBinds env (AbsBinds tyvars dicts exports inlines val_bind) %************************************************************************ \begin{code} -zonkMatch :: ZonkEnv -> TcMatch -> TcM TypecheckedMatch +zonkMatch :: ZonkEnv -> LMatch TcId-> TcM (LMatch Id) -zonkMatch env (Match pats _ grhss) +zonkMatch env (L loc (Match pats _ grhss)) = zonkPats env pats `thenM` \ (new_pats, new_ids) -> zonkGRHSs (extendZonkEnv env (bagToList new_ids)) grhss `thenM` \ new_grhss -> - returnM (Match new_pats Nothing new_grhss) + returnM (L loc (Match new_pats Nothing new_grhss)) ------------------------------------------------------------------------- -zonkGRHSs :: ZonkEnv -> TcGRHSs -> TcM TypecheckedGRHSs +zonkGRHSs :: ZonkEnv -> GRHSs TcId -> TcM (GRHSs Id) zonkGRHSs env (GRHSs grhss binds ty) - = zonkBinds env binds `thenM` \ (new_env, new_binds) -> + = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> let - zonk_grhs (GRHS guarded locn) - = zonkStmts new_env guarded `thenM` \ new_guarded -> - returnM (GRHS new_guarded locn) + zonk_grhs (GRHS guarded) + = zonkStmts new_env guarded `thenM` \ new_guarded -> + returnM (GRHS new_guarded) in - mappM zonk_grhs grhss `thenM` \ new_grhss -> - zonkTcTypeToType env ty `thenM` \ new_ty -> + mappM (wrapLocM zonk_grhs) grhss `thenM` \ new_grhss -> + zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (GRHSs new_grhss new_binds new_ty) \end{code} @@ -471,11 +369,12 @@ zonkGRHSs env (GRHSs grhss binds ty) %************************************************************************ \begin{code} -zonkExprs :: ZonkEnv -> [TcExpr] -> TcM [TypecheckedHsExpr] -zonkExpr :: ZonkEnv -> TcExpr -> TcM TypecheckedHsExpr - -zonkExprs env exprs = mappM (zonkExpr env) exprs +zonkLExprs :: ZonkEnv -> [LHsExpr TcId] -> TcM [LHsExpr Id] +zonkLExpr :: ZonkEnv -> LHsExpr TcId -> TcM (LHsExpr Id) +zonkExpr :: ZonkEnv -> HsExpr TcId -> TcM (HsExpr Id) +zonkLExprs env exprs = mappM (zonkLExpr env) exprs +zonkLExpr env expr = wrapLocM (zonkExpr env) expr zonkExpr env (HsVar id) = returnM (HsVar (zonkIdOcc env id)) @@ -497,88 +396,87 @@ zonkExpr env (HsLam match) returnM (HsLam new_match) zonkExpr env (HsApp e1 e2) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> returnM (HsApp new_e1 new_e2) zonkExpr env (HsBracketOut body bs) = mappM zonk_b bs `thenM` \ bs' -> returnM (HsBracketOut body bs') where - zonk_b (n,e) = zonkExpr env e `thenM` \ e' -> + zonk_b (n,e) = zonkLExpr env e `thenM` \ e' -> returnM (n,e') -zonkExpr env (HsSplice n e loc) = WARN( True, ppr e ) -- Should not happen - returnM (HsSplice n e loc) +zonkExpr env (HsSplice n e) = WARN( True, ppr e ) -- Should not happen + returnM (HsSplice n e) zonkExpr env (OpApp e1 op fixity e2) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env op `thenM` \ new_op -> - zonkExpr env e2 `thenM` \ new_e2 -> + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env op `thenM` \ new_op -> + zonkLExpr env e2 `thenM` \ new_e2 -> returnM (OpApp new_e1 new_op fixity new_e2) zonkExpr env (NegApp _ _) = panic "zonkExpr env: NegApp" zonkExpr env (HsPar e) - = zonkExpr env e `thenM` \new_e -> + = zonkLExpr env e `thenM` \new_e -> returnM (HsPar new_e) zonkExpr env (SectionL expr op) - = zonkExpr env expr `thenM` \ new_expr -> - zonkExpr env op `thenM` \ new_op -> + = zonkLExpr env expr `thenM` \ new_expr -> + zonkLExpr env op `thenM` \ new_op -> returnM (SectionL new_expr new_op) zonkExpr env (SectionR op expr) - = zonkExpr env op `thenM` \ new_op -> - zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env op `thenM` \ new_op -> + zonkLExpr env expr `thenM` \ new_expr -> returnM (SectionR new_op new_expr) -zonkExpr env (HsCase expr ms src_loc) - = zonkExpr env expr `thenM` \ new_expr -> +zonkExpr env (HsCase expr ms) + = zonkLExpr env expr `thenM` \ new_expr -> mappM (zonkMatch env) ms `thenM` \ new_ms -> - returnM (HsCase new_expr new_ms src_loc) + returnM (HsCase new_expr new_ms) -zonkExpr env (HsIf e1 e2 e3 src_loc) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> - zonkExpr env e3 `thenM` \ new_e3 -> - returnM (HsIf new_e1 new_e2 new_e3 src_loc) +zonkExpr env (HsIf e1 e2 e3) + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> + zonkLExpr env e3 `thenM` \ new_e3 -> + returnM (HsIf new_e1 new_e2 new_e3) zonkExpr env (HsLet binds expr) - = zonkBinds env binds `thenM` \ (new_env, new_binds) -> - zonkExpr new_env expr `thenM` \ new_expr -> + = zonkNestedBinds env binds `thenM` \ (new_env, new_binds) -> + zonkLExpr new_env expr `thenM` \ new_expr -> returnM (HsLet new_binds new_expr) -zonkExpr env (HsDo do_or_lc stmts ids ty src_loc) +zonkExpr env (HsDo do_or_lc stmts ids ty) = zonkStmts env stmts `thenM` \ new_stmts -> zonkTcTypeToType env ty `thenM` \ new_ty -> zonkReboundNames env ids `thenM` \ new_ids -> - returnM (HsDo do_or_lc new_stmts new_ids - new_ty src_loc) + returnM (HsDo do_or_lc new_stmts new_ids new_ty) zonkExpr env (ExplicitList ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkExprs env exprs `thenM` \ new_exprs -> + zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitList new_ty new_exprs) zonkExpr env (ExplicitPArr ty exprs) = zonkTcTypeToType env ty `thenM` \ new_ty -> - zonkExprs env exprs `thenM` \ new_exprs -> + zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitPArr new_ty new_exprs) zonkExpr env (ExplicitTuple exprs boxed) - = zonkExprs env exprs `thenM` \ new_exprs -> + = zonkLExprs env exprs `thenM` \ new_exprs -> returnM (ExplicitTuple new_exprs boxed) zonkExpr env (RecordConOut data_con con_expr rbinds) - = zonkExpr env con_expr `thenM` \ new_con_expr -> + = zonkLExpr env con_expr `thenM` \ new_con_expr -> zonkRbinds env rbinds `thenM` \ new_rbinds -> returnM (RecordConOut data_con new_con_expr new_rbinds) zonkExpr env (RecordUpd _ _) = panic "zonkExpr env:RecordUpd" zonkExpr env (RecordUpdOut expr in_ty out_ty rbinds) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> zonkTcTypeToType env in_ty `thenM` \ new_in_ty -> zonkTcTypeToType env out_ty `thenM` \ new_out_ty -> zonkRbinds env rbinds `thenM` \ new_rbinds -> @@ -589,33 +487,33 @@ zonkExpr env (ArithSeqIn _) = panic "zonkExpr env:ArithSeqIn" zonkExpr env (PArrSeqIn _) = panic "zonkExpr env:PArrSeqIn" zonkExpr env (ArithSeqOut expr info) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> zonkArithSeq env info `thenM` \ new_info -> returnM (ArithSeqOut new_expr new_info) zonkExpr env (PArrSeqOut expr info) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> zonkArithSeq env info `thenM` \ new_info -> returnM (PArrSeqOut new_expr new_info) zonkExpr env (HsSCC lbl expr) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> returnM (HsSCC lbl new_expr) -- hdaume: core annotations zonkExpr env (HsCoreAnn lbl expr) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> returnM (HsCoreAnn lbl new_expr) zonkExpr env (TyLam tyvars expr) = mappM zonkTcTyVarToTyVar tyvars `thenM` \ new_tyvars -> -- No need to extend tyvar env; see AbsBinds - zonkExpr env expr `thenM` \ new_expr -> + zonkLExpr env expr `thenM` \ new_expr -> returnM (TyLam new_tyvars new_expr) zonkExpr env (TyApp expr tys) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> mappM (zonkTcTypeToType env) tys `thenM` \ new_tys -> returnM (TyApp new_expr new_tys) @@ -624,36 +522,38 @@ zonkExpr env (DictLam dicts expr) let env1 = extendZonkEnv env new_dicts in - zonkExpr env1 expr `thenM` \ new_expr -> + zonkLExpr env1 expr `thenM` \ new_expr -> returnM (DictLam new_dicts new_expr) zonkExpr env (DictApp expr dicts) - = zonkExpr env expr `thenM` \ new_expr -> + = zonkLExpr env expr `thenM` \ new_expr -> returnM (DictApp new_expr (zonkIdOccs env dicts)) -- arrow notation extensions -zonkExpr env (HsProc pat body src_loc) +zonkExpr env (HsProc pat body) = zonkPat env pat `thenM` \ (new_pat, new_ids) -> let env1 = extendZonkEnv env (bagToList new_ids) in zonkCmdTop env1 body `thenM` \ new_body -> - returnM (HsProc new_pat new_body src_loc) + returnM (HsProc new_pat new_body) -zonkExpr env (HsArrApp e1 e2 ty ho rl src_loc) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> +zonkExpr env (HsArrApp e1 e2 ty ho rl) + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> zonkTcTypeToType env ty `thenM` \ new_ty -> - returnM (HsArrApp new_e1 new_e2 new_ty ho rl src_loc) + returnM (HsArrApp new_e1 new_e2 new_ty ho rl) -zonkExpr env (HsArrForm op fixity args src_loc) - = zonkExpr env op `thenM` \ new_op -> +zonkExpr env (HsArrForm op fixity args) + = zonkLExpr env op `thenM` \ new_op -> mappM (zonkCmdTop env) args `thenM` \ new_args -> - returnM (HsArrForm new_op fixity new_args src_loc) + returnM (HsArrForm new_op fixity new_args) -zonkCmdTop :: ZonkEnv -> TcCmdTop -> TcM TypecheckedHsCmdTop -zonkCmdTop env (HsCmdTop cmd stack_tys ty ids) - = zonkExpr env cmd `thenM` \ new_cmd -> +zonkCmdTop :: ZonkEnv -> LHsCmdTop TcId -> TcM (LHsCmdTop Id) +zonkCmdTop env cmd = wrapLocM (zonk_cmd_top env) cmd + +zonk_cmd_top env (HsCmdTop cmd stack_tys ty ids) + = zonkLExpr env cmd `thenM` \ new_cmd -> mappM (zonkTcTypeToType env) stack_tys `thenM` \ new_stack_tys -> zonkTcTypeToType env ty `thenM` \ new_ty -> @@ -665,57 +565,59 @@ zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id) zonkReboundNames env prs = mapM zonk prs where - zonk (n, e) = zonkExpr env e `thenM` \ new_e -> + zonk (n, e) = zonkLExpr env e `thenM` \ new_e -> returnM (n, new_e) ------------------------------------------------------------------------- -zonkArithSeq :: ZonkEnv -> TcArithSeqInfo -> TcM TypecheckedArithSeqInfo +zonkArithSeq :: ZonkEnv -> ArithSeqInfo TcId -> TcM (ArithSeqInfo Id) zonkArithSeq env (From e) - = zonkExpr env e `thenM` \ new_e -> + = zonkLExpr env e `thenM` \ new_e -> returnM (From new_e) zonkArithSeq env (FromThen e1 e2) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> returnM (FromThen new_e1 new_e2) zonkArithSeq env (FromTo e1 e2) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> returnM (FromTo new_e1 new_e2) zonkArithSeq env (FromThenTo e1 e2 e3) - = zonkExpr env e1 `thenM` \ new_e1 -> - zonkExpr env e2 `thenM` \ new_e2 -> - zonkExpr env e3 `thenM` \ new_e3 -> + = zonkLExpr env e1 `thenM` \ new_e1 -> + zonkLExpr env e2 `thenM` \ new_e2 -> + zonkLExpr env e3 `thenM` \ new_e3 -> returnM (FromThenTo new_e1 new_e2 new_e3) ------------------------------------------------------------------------- -zonkStmts :: ZonkEnv -> [TcStmt] -> TcM [TypecheckedStmt] +zonkStmts :: ZonkEnv -> [LStmt TcId] -> TcM [LStmt Id] zonkStmts env stmts = zonk_stmts env stmts `thenM` \ (_, stmts) -> returnM stmts -zonk_stmts :: ZonkEnv -> [TcStmt] -> TcM (ZonkEnv, [TypecheckedStmt]) - -zonk_stmts env [] = returnM (env, []) +zonk_stmts :: ZonkEnv -> [LStmt TcId] -> TcM (ZonkEnv, [LStmt Id]) +zonk_stmts env [] = return (env, []) +zonk_stmts env (s:ss) = do { (env1, s') <- wrapLocSndM (zonkStmt env) s + ; (env2, ss') <- zonk_stmts env1 ss + ; return (env2, s' : ss') } -zonk_stmts env (ParStmt stmts_w_bndrs : stmts) +zonkStmt :: ZonkEnv -> Stmt TcId -> TcM (ZonkEnv, Stmt Id) +zonkStmt env (ParStmt stmts_w_bndrs) = mappM zonk_branch stmts_w_bndrs `thenM` \ new_stmts_w_bndrs -> let new_binders = concat (map snd new_stmts_w_bndrs) env1 = extendZonkEnv env new_binders in - zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> - returnM (env2, ParStmt new_stmts_w_bndrs : new_stmts) + return (env1, ParStmt new_stmts_w_bndrs) where zonk_branch (stmts, bndrs) = zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> returnM (new_stmts, zonkIdOccs env1 bndrs) -zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts) +zonkStmt env (RecStmt segStmts lvs rvs rets) = zonkIdBndrs env rvs `thenM` \ new_rvs -> let env1 = extendZonkEnv env new_rvs @@ -723,50 +625,45 @@ zonk_stmts env (RecStmt segStmts lvs rvs rets : stmts) zonk_stmts env1 segStmts `thenM` \ (env2, new_segStmts) -> -- Zonk the ret-expressions in an envt that -- has the polymorphic bindings in the envt - zonkExprs env2 rets `thenM` \ new_rets -> + zonkLExprs env2 rets `thenM` \ new_rets -> let new_lvs = zonkIdOccs env2 lvs env3 = extendZonkEnv env new_lvs -- Only the lvs are needed in - zonk_stmts env3 stmts `thenM` \ (env4, new_stmts) -> - returnM (env4, RecStmt new_segStmts new_lvs new_rvs new_rets : new_stmts) + returnM (env3, RecStmt new_segStmts new_lvs new_rvs new_rets) -zonk_stmts env (ResultStmt expr locn : stmts) - = ASSERT( null stmts ) - zonkExpr env expr `thenM` \ new_expr -> - returnM (env, [ResultStmt new_expr locn]) +zonkStmt env (ResultStmt expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (env, ResultStmt new_expr) -zonk_stmts env (ExprStmt expr ty locn : stmts) - = zonkExpr env expr `thenM` \ new_expr -> +zonkStmt env (ExprStmt expr ty) + = zonkLExpr env expr `thenM` \ new_expr -> zonkTcTypeToType env ty `thenM` \ new_ty -> - zonk_stmts env stmts `thenM` \ (env1, new_stmts) -> - returnM (env1, ExprStmt new_expr new_ty locn : new_stmts) + returnM (env, ExprStmt new_expr new_ty) -zonk_stmts env (LetStmt binds : stmts) - = zonkBinds env binds `thenM` \ (env1, new_binds) -> - zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> - returnM (env2, LetStmt new_binds : new_stmts) +zonkStmt env (LetStmt binds) + = zonkNestedBinds env binds `thenM` \ (env1, new_binds) -> + returnM (env1, LetStmt new_binds) -zonk_stmts env (BindStmt pat expr locn : stmts) - = zonkExpr env expr `thenM` \ new_expr -> +zonkStmt env (BindStmt pat expr) + = zonkLExpr env expr `thenM` \ new_expr -> zonkPat env pat `thenM` \ (new_pat, new_ids) -> let env1 = extendZonkEnv env (bagToList new_ids) in - zonk_stmts env1 stmts `thenM` \ (env2, new_stmts) -> - returnM (env2, BindStmt new_pat new_expr locn : new_stmts) + returnM (env1, BindStmt new_pat new_expr) ------------------------------------------------------------------------- -zonkRbinds :: ZonkEnv -> TcRecordBinds -> TcM TypecheckedRecordBinds +zonkRbinds :: ZonkEnv -> HsRecordBinds TcId -> TcM (HsRecordBinds Id) zonkRbinds env rbinds = mappM zonk_rbind rbinds where zonk_rbind (field, expr) - = zonkExpr env expr `thenM` \ new_expr -> - returnM (zonkIdOcc env field, new_expr) + = zonkLExpr env expr `thenM` \ new_expr -> + returnM (fmap (zonkIdOcc env) field, new_expr) ------------------------------------------------------------------------- mapIPNameTc :: (a -> TcM b) -> IPName a -> TcM (IPName b) @@ -782,44 +679,45 @@ mapIPNameTc f (Linear n) = f n `thenM` \ r -> returnM (Linear r) %************************************************************************ \begin{code} -zonkPat :: ZonkEnv -> TcPat -> TcM (TypecheckedPat, Bag Id) +zonkPat :: ZonkEnv -> OutPat TcId -> TcM (OutPat Id, Bag Id) +zonkPat env pat = wrapLocFstM (zonk_pat env) pat -zonkPat env (ParPat p) +zonk_pat env (ParPat p) = zonkPat env p `thenM` \ (new_p, ids) -> returnM (ParPat new_p, ids) -zonkPat env (WildPat ty) +zonk_pat env (WildPat ty) = zonkTcTypeToType env ty `thenM` \ new_ty -> returnM (WildPat new_ty, emptyBag) -zonkPat env (VarPat v) +zonk_pat env (VarPat v) = zonkIdBndr env v `thenM` \ new_v -> returnM (VarPat new_v, unitBag new_v) -zonkPat env (LazyPat pat) +zonk_pat env (LazyPat pat) = zonkPat env pat `thenM` \ (new_pat, ids) -> returnM (LazyPat new_pat, ids) -zonkPat env (AsPat n pat) - = zonkIdBndr env n `thenM` \ new_n -> - zonkPat env pat `thenM` \ (new_pat, ids) -> - returnM (AsPat new_n new_pat, new_n `consBag` ids) +zonk_pat env (AsPat n pat) + = wrapLocM (zonkIdBndr env) n `thenM` \ new_n -> + zonkPat env pat `thenM` \ (new_pat, ids) -> + returnM (AsPat new_n new_pat, unLoc new_n `consBag` ids) -zonkPat env (ListPat pats ty) +zonk_pat env (ListPat pats ty) = zonkTcTypeToType env ty `thenM` \ new_ty -> zonkPats env pats `thenM` \ (new_pats, ids) -> returnM (ListPat new_pats new_ty, ids) -zonkPat env (PArrPat pats ty) +zonk_pat env (PArrPat pats ty) = zonkTcTypeToType env ty `thenM` \ new_ty -> zonkPats env pats `thenM` \ (new_pats, ids) -> returnM (PArrPat new_pats new_ty, ids) -zonkPat env (TuplePat pats boxed) +zonk_pat env (TuplePat pats boxed) = zonkPats env pats `thenM` \ (new_pats, ids) -> returnM (TuplePat new_pats boxed, ids) -zonkPat env (ConPatOut n stuff ty tvs dicts) +zonk_pat env (ConPatOut n stuff ty tvs dicts) = zonkTcTypeToType env ty `thenM` \ new_ty -> mappM zonkTcTyVarToTyVar tvs `thenM` \ new_tvs -> zonkIdBndrs env dicts `thenM` \ new_dicts -> @@ -830,26 +728,26 @@ zonkPat env (ConPatOut n stuff ty tvs dicts) returnM (ConPatOut n new_stuff new_ty new_tvs new_dicts, listToBag new_dicts `unionBags` ids) -zonkPat env (LitPat lit) = returnM (LitPat lit, emptyBag) +zonk_pat env (LitPat lit) = returnM (LitPat lit, emptyBag) -zonkPat env (SigPatOut pat ty expr) +zonk_pat env (SigPatOut pat ty expr) = zonkPat env pat `thenM` \ (new_pat, ids) -> zonkTcTypeToType env ty `thenM` \ new_ty -> zonkExpr env expr `thenM` \ new_expr -> returnM (SigPatOut new_pat new_ty new_expr, ids) -zonkPat env (NPatOut lit ty expr) +zonk_pat env (NPatOut lit ty expr) = zonkTcTypeToType env ty `thenM` \ new_ty -> zonkExpr env expr `thenM` \ new_expr -> returnM (NPatOut lit new_ty new_expr, emptyBag) -zonkPat env (NPlusKPatOut n k e1 e2) - = zonkIdBndr env n `thenM` \ new_n -> +zonk_pat env (NPlusKPatOut n k e1 e2) + = wrapLocM (zonkIdBndr env) n `thenM` \ new_n -> zonkExpr env e1 `thenM` \ new_e1 -> zonkExpr env e2 `thenM` \ new_e2 -> - returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag new_n) + returnM (NPlusKPatOut new_n k new_e1 new_e2, unitBag (unLoc new_n)) -zonkPat env (DictPat ds ms) +zonk_pat env (DictPat ds ms) = zonkIdBndrs env ds `thenM` \ new_ds -> zonkIdBndrs env ms `thenM` \ new_ms -> returnM (DictPat new_ds new_ms, @@ -891,25 +789,26 @@ zonkPats env (pat:pats) \begin{code} -zonkForeignExports :: ZonkEnv -> [TcForeignDecl] -> TcM [TypecheckedForeignDecl] -zonkForeignExports env ls = mappM (zonkForeignExport env) ls +zonkForeignExports :: ZonkEnv -> [LForeignDecl TcId] -> TcM [LForeignDecl Id] +zonkForeignExports env ls = mappM (wrapLocM (zonkForeignExport env)) ls -zonkForeignExport :: ZonkEnv -> TcForeignDecl -> TcM (TypecheckedForeignDecl) -zonkForeignExport env (ForeignExport i hs_ty spec isDeprec src_loc) = - returnM (ForeignExport (zonkIdOcc env i) undefined spec isDeprec src_loc) +zonkForeignExport :: ZonkEnv -> ForeignDecl TcId -> TcM (ForeignDecl Id) +zonkForeignExport env (ForeignExport i hs_ty spec isDeprec) = + returnM (ForeignExport (fmap (zonkIdOcc env) i) undefined spec isDeprec) zonkForeignExport env for_imp = returnM for_imp -- Foreign imports don't need zonking \end{code} \begin{code} -zonkRules :: ZonkEnv -> [TcRuleDecl] -> TcM [TypecheckedRuleDecl] -zonkRules env rs = mappM (zonkRule env) rs +zonkRules :: ZonkEnv -> [LRuleDecl TcId] -> TcM [LRuleDecl Id] +zonkRules env rs = mappM (wrapLocM (zonkRule env)) rs -zonkRule env (HsRule name act vars lhs rhs loc) +zonkRule :: ZonkEnv -> RuleDecl TcId -> TcM (RuleDecl Id) +zonkRule env (HsRule name act (vars::[RuleBndr TcId]) lhs rhs) = mappM zonk_bndr vars `thenM` \ new_bndrs -> newMutVar emptyVarSet `thenM` \ unbound_tv_set -> let - env_rhs = extendZonkEnv env (filter isId new_bndrs) + env_rhs = extendZonkEnv env [id | b <- new_bndrs, let id = unLoc b, isId id] -- Type variables don't need an envt -- They are bound through the mutable mechanism @@ -933,19 +832,20 @@ zonkRule env (HsRule name act vars lhs rhs loc) -- free type vars of an expression is necessarily monadic operation. -- (consider /\a -> f @ b, where b is side-effected to a) in - zonkExpr env_lhs lhs `thenM` \ new_lhs -> - zonkExpr env_rhs rhs `thenM` \ new_rhs -> + zonkLExpr env_lhs lhs `thenM` \ new_lhs -> + zonkLExpr env_rhs rhs `thenM` \ new_rhs -> readMutVar unbound_tv_set `thenM` \ unbound_tvs -> let - final_bndrs = map RuleBndr (varSetElems unbound_tvs ++ new_bndrs) - -- I hate this map RuleBndr stuff + final_bndrs :: [Located Var] + final_bndrs = map noLoc (varSetElems unbound_tvs) ++ new_bndrs in - returnM (HsRule name act final_bndrs new_lhs new_rhs loc) + returnM (HsRule name act (map RuleBndr final_bndrs) new_lhs new_rhs) + -- I hate this map RuleBndr stuff where zonk_bndr (RuleBndr v) - | isId v = zonkIdBndr env v - | otherwise = zonkTcTyVarToTyVar v + | isId (unLoc v) = wrapLocM (zonkIdBndr env) v + | otherwise = wrapLocM zonkTcTyVarToTyVar v \end{code} diff --git a/ghc/compiler/typecheck/TcHsType.lhs b/ghc/compiler/typecheck/TcHsType.lhs index 473166d2a4..7d6e53c93c 100644 --- a/ghc/compiler/typecheck/TcHsType.lhs +++ b/ghc/compiler/typecheck/TcHsType.lhs @@ -17,13 +17,14 @@ module TcHsType ( tcAddScopedTyVars, - TcSigInfo(..), tcTySig, mkTcSig, maybeSig, tcSigPolyId, tcSigMonoId + TcSigInfo(..), tcTySig, mkTcSig, maybeSig ) where #include "HsVersions.h" -import HsSyn ( HsType(..), HsTyVarBndr(..), HsContext, Sig(..), HsPred(..) ) -import RnHsSyn ( RenamedHsType, RenamedContext, RenamedSig, extractHsTyVars ) +import HsSyn ( HsType(..), LHsType, HsTyVarBndr(..), LHsTyVarBndr, + LHsContext, Sig(..), LSig, HsPred(..), LHsPred ) +import RnHsSyn ( extractHsTyVars ) import TcHsSyn ( TcId ) import TcRnMonad @@ -57,7 +58,7 @@ import PrelNames ( genUnitTyConName ) import Subst ( deShadowTy ) import TysWiredIn ( mkListTy, mkPArrTy, mkTupleTy ) import BasicTypes ( Boxity(..) ) -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcSpan, Located(..), unLoc, noLoc ) import Outputable import List ( nubBy ) \end{code} @@ -146,7 +147,7 @@ the TyCon being defined. %************************************************************************ \begin{code} -tcHsSigType :: UserTypeCtxt -> RenamedHsType -> TcM Type +tcHsSigType :: UserTypeCtxt -> LHsType Name -> TcM Type -- Do kind checking, and hoist for-alls to the top tcHsSigType ctxt hs_ty = addErrCtxt (pprHsSigCtxt ctxt hs_ty) $ @@ -158,8 +159,8 @@ tcHsSigType ctxt hs_ty -- tcHsPred is happy with a partial application, e.g. (ST s) -- Used from TcDeriv tcHsPred pred - = do { (kinded_pred,_) <- kc_pred pred -- kc_pred rather than kcHsPred - -- to avoid the partial application check + = do { (kinded_pred,_) <- wrapLocFstM kc_pred pred -- kc_pred rather than kcHsPred + -- to avoid the partial application check ; dsHsPred kinded_pred } \end{code} @@ -168,12 +169,12 @@ tcHsPred pred separate kind-checking, desugaring, and validity checking \begin{code} -kcHsSigType, kcHsLiftedSigType :: HsType Name -> TcM (HsType Name) +kcHsSigType, kcHsLiftedSigType :: LHsType Name -> TcM (LHsType Name) -- Used for type signatures kcHsSigType ty = kcTypeType ty kcHsLiftedSigType ty = kcLiftedType ty -tcHsKindedType :: RenamedHsType -> TcM Type +tcHsKindedType :: LHsType Name -> TcM Type -- Don't do kind checking, nor validity checking, -- but do hoist for-alls to the top -- This is used in type and class decls, where kinding is @@ -183,10 +184,10 @@ tcHsKindedType hs_ty = do { ty <- dsHsType hs_ty ; return (hoistForAllTys ty) } -tcHsKindedContext :: RenamedContext -> TcM ThetaType +tcHsKindedContext :: LHsContext Name -> TcM ThetaType -- Used when we are expecting a ClassContext (i.e. no implicit params) -- Does not do validity checking, like tcHsKindedType -tcHsKindedContext hs_theta = mappM dsHsPred hs_theta +tcHsKindedContext hs_theta = addLocM (mappM dsHsPred) hs_theta \end{code} @@ -200,12 +201,12 @@ tcHsKindedContext hs_theta = mappM dsHsPred hs_theta \begin{code} --------------------------- -kcLiftedType :: HsType Name -> TcM (HsType Name) +kcLiftedType :: LHsType Name -> TcM (LHsType Name) -- The type ty must be a *lifted* *type* kcLiftedType ty = kcCheckHsType ty liftedTypeKind --------------------------- -kcTypeType :: HsType Name -> TcM (HsType Name) +kcTypeType :: LHsType Name -> TcM (LHsType Name) -- The type ty must be a *type*, but it can be lifted or unlifted -- Be sure to use checkExpectedKind, rather than simply unifying -- with (Type bx), because it gives better error messages @@ -216,22 +217,23 @@ kcTypeType ty else newOpenTypeKind `thenM` \ type_kind -> traceTc (text "kcTypeType" $$ nest 2 (ppr ty $$ ppr ty' $$ ppr kind $$ ppr type_kind)) `thenM_` - checkExpectedKind (ppr ty) kind type_kind `thenM_` + checkExpectedKind ty kind type_kind `thenM_` returnM ty' --------------------------- -kcCheckHsType :: HsType Name -> TcKind -> TcM (HsType Name) +kcCheckHsType :: LHsType Name -> TcKind -> TcM (LHsType Name) -- Check that the type has the specified kind -kcCheckHsType ty exp_kind - = kcHsType ty `thenM` \ (ty', act_kind) -> - checkExpectedKind (ppr ty) act_kind exp_kind `thenM_` +kcCheckHsType ty exp_kind + = kcHsType ty `thenM` \ (ty', act_kind) -> + checkExpectedKind ty act_kind exp_kind `thenM_` returnM ty' \end{code} Here comes the main function \begin{code} -kcHsType :: HsType Name -> TcM (HsType Name, TcKind) +kcHsType :: LHsType Name -> TcM (LHsType Name, TcKind) +kcHsType ty = wrapLocFstM kc_hs_type ty -- kcHsType *returns* the kind of the type, rather than taking an expected -- kind as argument as tcExpr does. -- Reasons: @@ -242,61 +244,63 @@ kcHsType :: HsType Name -> TcM (HsType Name, TcKind) -- -- The translated type has explicitly-kinded type-variable binders -kcHsType (HsParTy ty) +kc_hs_type (HsParTy ty) = kcHsType ty `thenM` \ (ty', kind) -> returnM (HsParTy ty', kind) -kcHsType (HsTyVar name) +kc_hs_type (HsTyVar name) = kcTyVar name `thenM` \ kind -> returnM (HsTyVar name, kind) -kcHsType (HsListTy ty) +kc_hs_type (HsListTy ty) = kcLiftedType ty `thenM` \ ty' -> returnM (HsListTy ty', liftedTypeKind) -kcHsType (HsPArrTy ty) +kc_hs_type (HsPArrTy ty) = kcLiftedType ty `thenM` \ ty' -> returnM (HsPArrTy ty', liftedTypeKind) -kcHsType (HsNumTy n) +kc_hs_type (HsNumTy n) = returnM (HsNumTy n, liftedTypeKind) -kcHsType (HsKindSig ty k) +kc_hs_type (HsKindSig ty k) = kcCheckHsType ty k `thenM` \ ty' -> returnM (HsKindSig ty' k, k) -kcHsType (HsTupleTy Boxed tys) +kc_hs_type (HsTupleTy Boxed tys) = mappM kcLiftedType tys `thenM` \ tys' -> returnM (HsTupleTy Boxed tys', liftedTypeKind) -kcHsType (HsTupleTy Unboxed tys) +kc_hs_type (HsTupleTy Unboxed tys) = mappM kcTypeType tys `thenM` \ tys' -> returnM (HsTupleTy Unboxed tys', unliftedTypeKind) -kcHsType (HsFunTy ty1 ty2) +kc_hs_type (HsFunTy ty1 ty2) = kcTypeType ty1 `thenM` \ ty1' -> kcTypeType ty2 `thenM` \ ty2' -> returnM (HsFunTy ty1' ty2', liftedTypeKind) -kcHsType ty@(HsOpTy ty1 op ty2) - = kcTyVar op `thenM` \ op_kind -> +kc_hs_type ty@(HsOpTy ty1 op ty2) + = addLocM kcTyVar op `thenM` \ op_kind -> kcApps op_kind (ppr op) [ty1,ty2] `thenM` \ ([ty1',ty2'], res_kind) -> returnM (HsOpTy ty1' op ty2', res_kind) -kcHsType ty@(HsAppTy ty1 ty2) +kc_hs_type ty@(HsAppTy ty1 ty2) = kcHsType fun_ty `thenM` \ (fun_ty', fun_kind) -> - kcApps fun_kind (ppr fun_ty) arg_tys `thenM` \ (arg_tys', res_kind) -> - returnM (foldl HsAppTy fun_ty' arg_tys', res_kind) + kcApps fun_kind (ppr fun_ty) arg_tys `thenM` \ ((arg_ty':arg_tys'), res_kind) -> + returnM (foldl mk_app (HsAppTy fun_ty' arg_ty') arg_tys', res_kind) where (fun_ty, arg_tys) = split ty1 [ty2] - split (HsAppTy f a) as = split f (a:as) - split f as = (f,as) - -kcHsType (HsPredTy pred) + split (L _ (HsAppTy f a)) as = split f (a:as) + split f as = (f,as) + mk_app fun arg = HsAppTy (noLoc fun) arg -- Add noLocs for inner nodes of + -- the application; they are never used + +kc_hs_type (HsPredTy pred) = kcHsPred pred `thenM` \ pred' -> returnM (HsPredTy pred', liftedTypeKind) -kcHsType (HsForAllTy exp tv_names context ty) +kc_hs_type (HsForAllTy exp tv_names context ty) = kcHsTyVars tv_names $ \ tv_names' -> kcHsContext context `thenM` \ ctxt' -> kcLiftedType ty `thenM` \ ty' -> @@ -313,10 +317,10 @@ kcHsType (HsForAllTy exp tv_names context ty) returnM (HsForAllTy exp tv_names' ctxt' ty', liftedTypeKind) --------------------------- -kcApps :: TcKind -- Function kind - -> SDoc -- Function - -> [HsType Name] -- Arg types - -> TcM ([HsType Name], TcKind) -- Kind-checked args +kcApps :: TcKind -- Function kind + -> SDoc -- Function + -> [LHsType Name] -- Arg types + -> TcM ([LHsType Name], TcKind) -- Kind-checked args kcApps fun_kind ppr_fun args = split_fk fun_kind (length args) `thenM` \ (arg_kinds, res_kind) -> mappM kc_arg (args `zip` arg_kinds) `thenM` \ args' -> @@ -335,12 +339,12 @@ kcApps fun_kind ppr_fun args ptext SLIT("is applied to too many type arguments") --------------------------- -kcHsContext :: HsContext Name -> TcM (HsContext Name) -kcHsContext ctxt = mappM kcHsPred ctxt +kcHsContext :: LHsContext Name -> TcM (LHsContext Name) +kcHsContext ctxt = wrapLocM (mappM kcHsPred) ctxt kcHsPred pred -- Checks that the result is of kind liftedType - = kc_pred pred `thenM` \ (pred', kind) -> - checkExpectedKind (ppr pred) kind liftedTypeKind `thenM_` + = wrapLocFstM kc_pred pred `thenM` \ (pred', kind) -> + checkExpectedKind pred kind liftedTypeKind `thenM_` returnM pred' --------------------------- @@ -388,11 +392,11 @@ kcClass cls -- Must be a class -- -checkExpectedKind :: SDoc -> TcKind -> TcKind -> TcM TcKind +checkExpectedKind :: Outputable a => Located a -> TcKind -> TcKind -> TcM TcKind -- A fancy wrapper for 'unifyKind', which tries to give -- decent error messages. -- Returns the same kind that it is passed, exp_kind -checkExpectedKind pp_ty act_kind exp_kind +checkExpectedKind (L span ty) act_kind exp_kind | act_kind `eqKind` exp_kind -- Short cut for a very common case = returnM exp_kind | otherwise @@ -403,6 +407,7 @@ checkExpectedKind pp_ty act_kind exp_kind -- So there's definitely an error -- Now to find out what sort + addSrcSpan span $ zonkTcType exp_kind `thenM` \ exp_kind -> zonkTcType act_kind `thenM` \ act_kind -> @@ -413,21 +418,21 @@ checkExpectedKind pp_ty act_kind exp_kind n_act_as = length act_as err | n_exp_as < n_act_as -- E.g. [Maybe] - = quotes pp_ty <+> ptext SLIT("is not applied to enough type arguments") + = quotes (ppr ty) <+> ptext SLIT("is not applied to enough type arguments") -- Now n_exp_as >= n_act_as. In the next two cases, -- n_exp_as == 0, and hence so is n_act_as | exp_kind `eqKind` liftedTypeKind && act_kind `eqKind` unliftedTypeKind - = ptext SLIT("Expecting a lifted type, but") <+> quotes pp_ty + = ptext SLIT("Expecting a lifted type, but") <+> quotes (ppr ty) <+> ptext SLIT("is unlifted") | exp_kind `eqKind` unliftedTypeKind && act_kind `eqKind` liftedTypeKind - = ptext SLIT("Expecting an unlifted type, but") <+> quotes pp_ty + = ptext SLIT("Expecting an unlifted type, but") <+> quotes (ppr ty) <+> ptext SLIT("is lifted") | otherwise -- E.g. Monad [Int] = sep [ ptext SLIT("Expecting kind") <+> quotes (pprKind exp_kind) <> comma, - ptext SLIT("but") <+> quotes pp_ty <+> + ptext SLIT("but") <+> quotes (ppr ty) <+> ptext SLIT("has kind") <+> quotes (pprKind act_kind)] in failWithTc (ptext SLIT("Kind error:") <+> err) @@ -448,55 +453,56 @@ The type desugarer It cannot fail, and does no validity checking \begin{code} -dsHsType :: HsType Name -- All HsTyVarBndrs are kind-annotated - -> TcM Type +dsHsType :: LHsType Name -> TcM Type +-- All HsTyVarBndrs in the intput type are kind-annotated +dsHsType ty = ds_type (unLoc ty) -dsHsType ty@(HsTyVar name) +ds_type ty@(HsTyVar name) = ds_app ty [] -dsHsType (HsParTy ty) -- Remove the parentheses markers +ds_type (HsParTy ty) -- Remove the parentheses markers = dsHsType ty -dsHsType (HsKindSig ty k) +ds_type (HsKindSig ty k) = dsHsType ty -- Kind checking done already -dsHsType (HsListTy ty) +ds_type (HsListTy ty) = dsHsType ty `thenM` \ tau_ty -> returnM (mkListTy tau_ty) -dsHsType (HsPArrTy ty) +ds_type (HsPArrTy ty) = dsHsType ty `thenM` \ tau_ty -> returnM (mkPArrTy tau_ty) -dsHsType (HsTupleTy boxity tys) +ds_type (HsTupleTy boxity tys) = dsHsTypes tys `thenM` \ tau_tys -> returnM (mkTupleTy boxity (length tys) tau_tys) -dsHsType (HsFunTy ty1 ty2) +ds_type (HsFunTy ty1 ty2) = dsHsType ty1 `thenM` \ tau_ty1 -> dsHsType ty2 `thenM` \ tau_ty2 -> returnM (mkFunTy tau_ty1 tau_ty2) -dsHsType (HsOpTy ty1 op ty2) - = dsHsType ty1 `thenM` \ tau_ty1 -> - dsHsType ty2 `thenM` \ tau_ty2 -> - ds_var_app op [tau_ty1,tau_ty2] +ds_type (HsOpTy ty1 (L span op) ty2) + = dsHsType ty1 `thenM` \ tau_ty1 -> + dsHsType ty2 `thenM` \ tau_ty2 -> + addSrcSpan span (ds_var_app op [tau_ty1,tau_ty2]) -dsHsType (HsNumTy n) +ds_type (HsNumTy n) = ASSERT(n==1) tcLookupTyCon genUnitTyConName `thenM` \ tc -> returnM (mkTyConApp tc []) -dsHsType ty@(HsAppTy ty1 ty2) - = ds_app ty1 [ty2] +ds_type ty@(HsAppTy _ _) + = ds_app ty [] -dsHsType (HsPredTy pred) +ds_type (HsPredTy pred) = dsHsPred pred `thenM` \ pred' -> returnM (mkPredTy pred') -dsHsType full_ty@(HsForAllTy exp tv_names ctxt ty) +ds_type full_ty@(HsForAllTy exp tv_names ctxt ty) = tcTyVarBndrs tv_names $ \ tyvars -> - mappM dsHsPred ctxt `thenM` \ theta -> + mappM dsHsPred (unLoc ctxt) `thenM` \ theta -> dsHsType ty `thenM` \ tau -> returnM (mkSigmaTy tyvars theta tau) @@ -507,15 +513,15 @@ Help functions for type applications ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -ds_app :: HsType Name -> [HsType Name] -> TcM Type +ds_app :: HsType Name -> [LHsType Name] -> TcM Type ds_app (HsAppTy ty1 ty2) tys - = ds_app ty1 (ty2:tys) + = ds_app (unLoc ty1) (ty2:tys) ds_app ty tys = dsHsTypes tys `thenM` \ arg_tys -> case ty of HsTyVar fun -> ds_var_app fun arg_tys - other -> dsHsType ty `thenM` \ fun_ty -> + other -> ds_type ty `thenM` \ fun_ty -> returnM (mkAppTys fun_ty arg_tys) ds_var_app :: Name -> [Type] -> TcM Type @@ -533,13 +539,15 @@ ds_var_app name arg_tys Contexts ~~~~~~~~ \begin{code} -dsHsPred :: HsPred Name -> TcM PredType -dsHsPred pred@(HsClassP class_name tys) +dsHsPred :: LHsPred Name -> TcM PredType +dsHsPred pred = ds_pred (unLoc pred) + +ds_pred pred@(HsClassP class_name tys) = dsHsTypes tys `thenM` \ arg_tys -> tcLookupClass class_name `thenM` \ clas -> returnM (ClassP clas arg_tys) -dsHsPred (HsIParam name ty) +ds_pred (HsIParam name ty) = dsHsType ty `thenM` \ arg_ty -> returnM (IParam name arg_ty) \end{code} @@ -553,13 +561,13 @@ dsHsPred (HsIParam name ty) \begin{code} -kcHsTyVars :: [HsTyVarBndr Name] - -> ([HsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated +kcHsTyVars :: [LHsTyVarBndr Name] + -> ([LHsTyVarBndr Name] -> TcM r) -- These binders are kind-annotated -- They scope over the thing inside -> TcM r kcHsTyVars tvs thing_inside - = mappM kcHsTyVar tvs `thenM` \ bndrs -> - tcExtendTyVarKindEnv bndrs $ + = mappM (wrapLocM kcHsTyVar) tvs `thenM` \ bndrs -> + tcExtendTyVarKindEnv bndrs $ thing_inside bndrs kcHsTyVar :: HsTyVarBndr Name -> TcM (HsTyVarBndr Name) @@ -569,13 +577,13 @@ kcHsTyVar (UserTyVar name) = newKindVar `thenM` \ kind -> kcHsTyVar (KindedTyVar name kind) = returnM (KindedTyVar name kind) ------------------ -tcTyVarBndrs :: [HsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking +tcTyVarBndrs :: [LHsTyVarBndr Name] -- Kind-annotated binders, which need kind-zonking -> ([TyVar] -> TcM r) -> TcM r -- Used when type-checking types/classes/type-decls -- Brings into scope immutable TyVars, not mutable ones that require later zonking tcTyVarBndrs bndrs thing_inside - = mapM zonk bndrs `thenM` \ tyvars -> + = mapM (zonk . unLoc) bndrs `thenM` \ tyvars -> tcExtendTyVarEnv tyvars (thing_inside tyvars) where zonk (KindedTyVar name kind) = zonkTcKindToKind kind `thenM` \ kind' -> @@ -625,16 +633,18 @@ Historical note: it with expected_ty afterwards \begin{code} -tcAddScopedTyVars :: [RenamedHsType] -> TcM a -> TcM a +tcAddScopedTyVars :: [LHsType Name] -> TcM a -> TcM a tcAddScopedTyVars [] thing_inside = thing_inside -- Quick get-out for the empty case tcAddScopedTyVars sig_tys thing_inside = getInLocalScope `thenM` \ in_scope -> + getSrcSpanM `thenM` \ span -> let - sig_tvs = [ UserTyVar n | ty <- sig_tys, - n <- nameSetToList (extractHsTyVars ty), - not (in_scope n) ] + sig_tvs = [ L span (UserTyVar n) + | ty <- sig_tys, + n <- nameSetToList (extractHsTyVars ty), + not (in_scope n) ] -- The tyvars we want are the free type variables of -- the type that are not already in scope in @@ -655,7 +665,7 @@ tcAddScopedTyVars sig_tys thing_inside -- Quantified type variable `t' escapes -- It is mentioned in the environment: -- t is bound by the pattern type signature at tcfail103.hs:6 - mapM zonk kinded_tvs `thenM` \ tyvars -> + mapM (zonk . unLoc) kinded_tvs `thenM` \ tyvars -> tcExtendTyVarEnv tyvars thing_inside where @@ -683,33 +693,29 @@ been instantiated. \begin{code} data TcSigInfo - = TySigInfo - TcId -- *Polymorphic* binder for this value... + = TySigInfo { + sig_poly_id :: TcId, -- *Polymorphic* binder for this value... -- Has name = N - [TcTyVar] -- tyvars - TcThetaType -- theta - TcTauType -- tau + sig_tvs :: [TcTyVar], -- tyvars + sig_theta :: TcThetaType, -- theta + sig_tau :: TcTauType, -- tau - TcId -- *Monomorphic* binder for this value + sig_mono_id :: TcId, -- *Monomorphic* binder for this value -- Does *not* have name = N -- Has type tau - [Inst] -- Empty if theta is null, or - -- (method mono_id) otherwise + sig_insts :: [Inst], -- Empty if theta is null, or + -- (method mono_id) otherwise + + sig_loc :: SrcSpan -- The location of the signature + } - SrcLoc -- Of the signature instance Outputable TcSigInfo where - ppr (TySigInfo id tyvars theta tau _ inst loc) = + ppr (TySigInfo id tyvars theta tau _ inst _) = ppr id <+> ptext SLIT("::") <+> ppr tyvars <+> ppr theta <+> ptext SLIT("=>") <+> ppr tau -tcSigPolyId :: TcSigInfo -> TcId -tcSigPolyId (TySigInfo id _ _ _ _ _ _) = id - -tcSigMonoId :: TcSigInfo -> TcId -tcSigMonoId (TySigInfo _ _ _ _ id _ _) = id - maybeSig :: [TcSigInfo] -> Name -> Maybe (TcSigInfo) -- Search for a particular signature maybeSig [] name = Nothing @@ -720,10 +726,10 @@ maybeSig (sig@(TySigInfo sig_id _ _ _ _ _ _) : sigs) name \begin{code} -tcTySig :: RenamedSig -> TcM TcSigInfo +tcTySig :: LSig Name -> TcM TcSigInfo -tcTySig (Sig v ty src_loc) - = addSrcLoc src_loc $ +tcTySig (L span (Sig (L _ v) ty)) + = addSrcSpan span $ tcHsSigType (FunSigCtxt v) ty `thenM` \ sigma_tc_ty -> mkTcSig (mkLocalId v sigma_tc_ty) `thenM` \ sig -> returnM sig @@ -746,9 +752,11 @@ mkTcSig poly_id -- We make a Method even if it's not overloaded; no harm -- But do not extend the LIE! We're just making an Id. - getSrcLocM `thenM` \ src_loc -> - returnM (TySigInfo poly_id tyvars' theta' tau' - (instToId inst) [inst] src_loc) + getSrcSpanM `thenM` \ src_loc -> + returnM (TySigInfo { sig_poly_id = poly_id, sig_tvs = tyvars', + sig_theta = theta', sig_tau = tau', + sig_mono_id = instToId inst, + sig_insts = [inst], sig_loc = src_loc }) \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 35795abd53..109fb30b78 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -8,13 +8,8 @@ module TcInstDcls ( tcInstDecls1, tcInstDecls2 ) where #include "HsVersions.h" -import HsSyn ( InstDecl(..), HsType(..), - MonoBinds(..), HsExpr(..), HsLit(..), Sig(..), - andMonoBindList, collectMonoBinders, - isClassDecl - ) -import RnHsSyn ( RenamedHsBinds, RenamedInstDecl, RenamedTyClDecl ) -import TcHsSyn ( TcMonoBinds, mkHsConApp ) +import HsSyn +import TcHsSyn ( mkHsConApp ) import TcBinds ( tcSpecSigs ) import TcClassDcl ( tcMethodBind, mkMethodBind, badMethodErr, tcClassDecl2, getGenericInstances ) @@ -37,16 +32,18 @@ import TcSimplify ( tcSimplifyCheck, tcSimplifyTop ) import Subst ( mkTyVarSubst, substTheta, substTy ) import DataCon ( classDataCon ) import Class ( classBigSig ) -import Var ( idName, idType ) +import Var ( Id, idName, idType ) import NameSet import MkId ( mkDictFunId, rUNTIME_ERROR_ID ) import FunDeps ( checkInstFDs ) -import Name ( getSrcLoc ) +import Name ( Name, getSrcLoc ) import NameSet ( unitNameSet, emptyNameSet, nameSetToList ) import UnicodeUtil ( stringToUtf8 ) import Maybe ( catMaybes ) +import SrcLoc ( srcLocSpan, unLoc, noLoc, Located(..), srcSpanStart ) import ListSetOps ( minusList ) import Outputable +import Bag import FastString \end{code} @@ -134,12 +131,12 @@ Gather up the instance declarations from their various sources \begin{code} tcInstDecls1 -- Deal with both source-code and imported instance decls - :: [RenamedTyClDecl] -- For deriving stuff - -> [RenamedInstDecl] -- Source code instance decls + :: [LTyClDecl Name] -- For deriving stuff + -> [LInstDecl Name] -- Source code instance decls -> TcM (TcGblEnv, -- The full inst env [InstInfo], -- Source-code instance decls to process; -- contains all dfuns for this module - RenamedHsBinds) -- Supporting bindings for derived instances + [HsBindGroup Name]) -- Supporting bindings for derived instances tcInstDecls1 tycl_decls inst_decls = checkNoErrs $ @@ -151,7 +148,7 @@ tcInstDecls1 tycl_decls inst_decls let local_inst_info = catMaybes local_inst_infos - clas_decls = filter isClassDecl tycl_decls + clas_decls = filter (isClassDecl.unLoc) tycl_decls in -- (2) Instances from generic class declarations getGenericInstances clas_decls `thenM` \ generic_inst_info -> @@ -179,7 +176,7 @@ addInsts infos thing_inside \end{code} \begin{code} -tcLocalInstDecl1 :: RenamedInstDecl +tcLocalInstDecl1 :: LInstDecl Name -> TcM (Maybe InstInfo) -- Nothing if there was an error -- A source-file instance declaration -- Type-check all the stuff before the "where" @@ -189,10 +186,10 @@ tcLocalInstDecl1 :: RenamedInstDecl -- Imported ones should have been checked already, and may indeed -- contain something illegal in normal Haskell, notably -- instance CCallable [Char] -tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags src_loc) +tcLocalInstDecl1 decl@(L loc (InstDecl poly_ty binds uprags)) = -- Prime error recovery, set source location recoverM (returnM Nothing) $ - addSrcLoc src_loc $ + addSrcSpan loc $ addErrCtxt (instDeclCtxt1 poly_ty) $ -- Typecheck the instance type itself. We can't use @@ -207,7 +204,7 @@ tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags src_loc) checkValidInstHead tau `thenM` \ (clas,inst_tys) -> checkTc (checkInstFDs theta clas inst_tys) (instTypeErr (pprClassPred clas inst_tys) msg) `thenM_` - newDFunName clas inst_tys src_loc `thenM` \ dfun_name -> + newDFunName clas inst_tys (srcSpanStart loc) `thenM` \ dfun_name -> returnM (Just (InstInfo { iDFunId = mkDictFunId dfun_name tyvars theta clas inst_tys, iBinds = VanillaInst binds uprags })) where @@ -222,8 +219,8 @@ tcLocalInstDecl1 decl@(InstDecl poly_ty binds uprags src_loc) %************************************************************************ \begin{code} -tcInstDecls2 :: [RenamedTyClDecl] -> [InstInfo] - -> TcM (TcLclEnv, TcMonoBinds) +tcInstDecls2 :: [LTyClDecl Name] -> [InstInfo] + -> TcM (TcLclEnv, LHsBinds Id) -- (a) From each class declaration, -- generate any default-method bindings -- (b) From each instance decl @@ -232,7 +229,7 @@ tcInstDecls2 :: [RenamedTyClDecl] -> [InstInfo] tcInstDecls2 tycl_decls inst_decls = do { -- (a) Default methods from class decls (dm_binds_s, dm_ids_s) <- mapAndUnzipM tcClassDecl2 $ - filter isClassDecl tycl_decls + filter (isClassDecl.unLoc) tycl_decls ; tcExtendLocalValEnv (concat dm_ids_s) $ do -- (b) instance declarations @@ -240,8 +237,8 @@ tcInstDecls2 tycl_decls inst_decls -- Done ; tcl_env <- getLclEnv - ; returnM (tcl_env, andMonoBindList dm_binds_s `AndMonoBinds` - andMonoBindList inst_binds_s) } + ; returnM (tcl_env, unionManyBags dm_binds_s `unionBags` + unionManyBags inst_binds_s) } \end{code} ======= New documentation starts here (Sept 92) ============== @@ -312,12 +309,12 @@ First comes the easy case of a non-local instance decl. \begin{code} -tcInstDecl2 :: InstInfo -> TcM TcMonoBinds +tcInstDecl2 :: InstInfo -> TcM (LHsBinds Id) tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) = -- Prime error recovery - recoverM (returnM EmptyMonoBinds) $ - addSrcLoc (getSrcLoc dfun_id) $ + recoverM (returnM emptyBag) $ + addSrcSpan (srcLocSpan (getSrcLoc dfun_id)) $ addErrCtxt (instDeclCtxt2 (idType dfun_id)) $ let inst_ty = idType dfun_id @@ -364,8 +361,8 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) uprags = case binds of VanillaInst _ uprags -> uprags other -> [] - spec_prags = [ SpecSig (idName dfun_id) ty loc - | SpecInstSig ty loc <- uprags ] + spec_prags = [ L loc (SpecSig (L loc (idName dfun_id)) ty) + | L loc (SpecInstSig ty) <- uprags ] xtve = inst_tyvars `zip` inst_tyvars' in tcExtendGlobalValEnv [dfun_id] ( @@ -399,8 +396,9 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) -- emit an error message. This in turn means that we don't -- mention the constructor, which doesn't exist for CCallable, CReturnable -- Hardly beautiful, but only three extra lines. - HsApp (TyApp (HsVar rUNTIME_ERROR_ID) [idType this_dict_id]) - (HsLit (HsStringPrim (mkFastString (stringToUtf8 msg)))) + nlHsApp (noLoc $ TyApp (nlHsVar rUNTIME_ERROR_ID) + [idType this_dict_id]) + (nlHsLit (HsStringPrim (mkFastString (stringToUtf8 msg)))) | otherwise -- The common case = mkHsConApp dict_constr inst_tys' (map HsVar scs_and_meths) @@ -414,17 +412,19 @@ tcInstDecl2 (InstInfo { iDFunId = dfun_id, iBinds = binds }) where msg = "Compiler error: bad dictionary " ++ showSDoc (ppr clas) - dict_bind = VarMonoBind this_dict_id dict_rhs - all_binds = sc_binds_inner `AndMonoBinds` meth_binds `AndMonoBinds` dict_bind + dict_bind = noLoc (VarBind this_dict_id dict_rhs) + all_binds = dict_bind `consBag` (sc_binds_inner `unionBags` meth_binds) - main_bind = AbsBinds + main_bind = noLoc $ AbsBinds zonked_inst_tyvars (map instToId dfun_arg_dicts) [(inst_tyvars', dfun_id, this_dict_id)] inlines all_binds in showLIE (text "instance") `thenM_` - returnM (main_bind `AndMonoBinds` prag_binds `AndMonoBinds` sc_binds_outer) + returnM (unitBag main_bind `unionBags` + prag_binds `unionBags` + sc_binds_outer) tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' @@ -432,7 +432,7 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' = -- Check that all the method bindings come from this class let sel_names = [idName sel_id | (sel_id, _) <- op_items] - bad_bndrs = collectMonoBinders monobinds `minusList` sel_names + bad_bndrs = collectHsBindBinders monobinds `minusList` sel_names in mappM (addErrTc . badMethodErr clas) bad_bndrs `thenM_` @@ -479,7 +479,7 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' mapM tc_method_bind meth_infos `thenM` \ meth_binds_s -> returnM ([meth_id | (_,meth_id,_) <- meth_infos], - andMonoBindList meth_binds_s) + unionManyBags meth_binds_s) -- Derived newtype instances @@ -494,7 +494,7 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' -- I don't think we have to do the checkSigTyVars thing - returnM (meth_ids, lie_binds `AndMonoBinds` andMonoBindList meth_binds) + returnM (meth_ids, lie_binds `unionBags` listToBag meth_binds) where do_one inst_loc (sel_id, _) @@ -507,7 +507,7 @@ tcMethods clas inst_tyvars inst_tyvars' dfun_theta' inst_tys' let meth_id = instToId meth_inst in - return (meth_id, VarMonoBind meth_id (HsVar (instToId rhs_inst)), rhs_inst) + return (meth_id, noLoc (VarBind meth_id (nlHsVar (instToId rhs_inst))), rhs_inst) -- Instantiate rep_tys with the relevant type variables rep_tys' = map (substTy subst) rep_tys @@ -676,8 +676,8 @@ simplified: only zeze2 is extracted and its body is simplified. \begin{code} instDeclCtxt1 hs_inst_ty - = inst_decl_ctxt (case hs_inst_ty of - HsForAllTy _ _ _ (HsPredTy pred) -> ppr pred + = inst_decl_ctxt (case unLoc hs_inst_ty of + HsForAllTy _ _ _ (L _ (HsPredTy pred)) -> ppr pred HsPredTy pred -> ppr pred other -> ppr hs_inst_ty) -- Don't expect this instDeclCtxt2 dfun_ty diff --git a/ghc/compiler/typecheck/TcMType.lhs b/ghc/compiler/typecheck/TcMType.lhs index c1c7bceddb..41e556a524 100644 --- a/ghc/compiler/typecheck/TcMType.lhs +++ b/ghc/compiler/typecheck/TcMType.lhs @@ -43,7 +43,7 @@ module TcMType ( -- friends: -import HsSyn ( HsType ) +import HsSyn ( LHsType ) import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation Kind, ThetaType ) @@ -61,7 +61,7 @@ import TcType ( TcType, TcThetaType, TcTauType, TcPredType, liftedTypeKind, defaultKind, superKind, superBoxity, liftedBoxity, typeKind, tyVarsOfType, tyVarsOfTypes, - eqKind, isTypeKind, pprThetaArrow, + eqKind, isTypeKind, pprPred, pprTheta, pprClassPred ) import Subst ( Subst, mkTopTyVarSubst, substTy ) import Class ( Class, classArity, className ) @@ -78,6 +78,7 @@ import VarSet import CmdLineOpts ( dopt, DynFlag(..) ) import Util ( nOfThem, isSingleton, equalLength, notNull ) import ListSetOps ( removeDups ) +import SrcLoc ( unLoc ) import Outputable \end{code} @@ -530,8 +531,8 @@ data UserTypeCtxt -- With gla-exts that's right, but for H98 we should complain. -pprHsSigCtxt :: UserTypeCtxt -> HsType Name -> SDoc -pprHsSigCtxt ctxt hs_ty = pprUserTypeCtxt hs_ty ctxt +pprHsSigCtxt :: UserTypeCtxt -> LHsType Name -> SDoc +pprHsSigCtxt ctxt hs_ty = pprUserTypeCtxt (unLoc hs_ty) ctxt pprUserTypeCtxt ty (FunSigCtxt n) = sep [ptext SLIT("In the type signature:"), pp_sig n ty] pprUserTypeCtxt ty ExprSigCtxt = sep [ptext SLIT("In an expression type signature:"), nest 2 (ppr ty)] diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-5 b/ghc/compiler/typecheck/TcMatches.hi-boot-5 index 6b568de830..43e2330683 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot-5 +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-5 @@ -1,11 +1,10 @@ __interface TcMatches 1 0 where __export TcMatches tcGRHSsPat tcMatchesFun; -1 tcGRHSsPat :: RnHsSyn.RenamedGRHSs +1 tcGRHSsPat :: HsExpr.GRHSs Name.Name -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcGRHSs ; -1 tcMatchesFun :: - Name.Name - -> [RnHsSyn.RenamedMatch] - -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM [TcHsSyn.TcMatch] ; + -> TcRnTypes.TcM (HsExpr.GRHSs Var.Id) ; +1 tcMatchesFun :: Name.Name + -> [HsExpr.LMatch Name.Name] + -> TcUnify.Expected TcType.TcType + -> TcRnTypes.TcM [HsExpr.LMatch Var.Id] ; diff --git a/ghc/compiler/typecheck/TcMatches.hi-boot-6 b/ghc/compiler/typecheck/TcMatches.hi-boot-6 index aca8a45c9d..25d13a53e7 100644 --- a/ghc/compiler/typecheck/TcMatches.hi-boot-6 +++ b/ghc/compiler/typecheck/TcMatches.hi-boot-6 @@ -1,11 +1,10 @@ module TcMatches where -tcGRHSsPat :: RnHsSyn.RenamedGRHSs +tcGRHSsPat :: HsExpr.GRHSs Name.Name -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcGRHSs + -> TcRnTypes.TcM (HsExpr.GRHSs Var.Id) tcMatchesFun :: Name.Name - -> [RnHsSyn.RenamedMatch] + -> [HsExpr.LMatch Name.Name] -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM [TcHsSyn.TcMatch] - + -> TcRnTypes.TcM [HsExpr.LMatch Var.Id] diff --git a/ghc/compiler/typecheck/TcMatches.lhs b/ghc/compiler/typecheck/TcMatches.lhs index 21c74dcce4..12a59d7660 100644 --- a/ghc/compiler/typecheck/TcMatches.lhs +++ b/ghc/compiler/typecheck/TcMatches.lhs @@ -15,18 +15,15 @@ module TcMatches ( tcMatchesFun, tcGRHSsPat, tcMatchesCase, tcMatchLambda, import {-# SOURCE #-} TcExpr( tcCheckRho, tcMonoExpr ) -import HsSyn ( HsExpr(..), HsBinds(..), Match(..), GRHSs(..), GRHS(..), - MonoBinds(..), Stmt(..), HsMatchContext(..), HsStmtContext(..), - ReboundNames, - pprMatch, getMatchLoc, isDoExpr, +import HsSyn ( HsExpr(..), LHsExpr, HsBindGroup(..), + Match(..), LMatch, GRHSs(..), GRHS(..), + Stmt(..), LStmt, HsMatchContext(..), HsStmtContext(..), + ReboundNames, LPat, + pprMatch, isDoExpr, pprMatchContext, pprStmtContext, pprStmtResultContext, - mkMonoBind, collectSigTysFromPats, glueBindsOnGRHSs + collectSigTysFromPats, glueBindsOnGRHSs ) -import RnHsSyn ( RenamedMatch, RenamedGRHSs, RenamedStmt, RenamedHsExpr, - RenamedPat, RenamedMatchContext ) -import TcHsSyn ( TcMatch, TcGRHSs, TcStmt, TcDictBinds, TcHsBinds, TcExpr, - TcPat, TcStmt, ExprCoFn, - isIdCoercion, (<$>), (<.>) ) +import TcHsSyn ( ExprCoFn, TcDictBinds, isIdCoercion, (<$>), (<.>) ) import TcRnMonad import TcHsType ( tcAddScopedTyVars, tcHsSigType, UserTypeCtxt(..) ) @@ -52,6 +49,7 @@ import VarSet import Bag import Util ( isSingleton, notNull ) import Outputable +import SrcLoc ( Located(..), noLoc ) import List ( nub ) \end{code} @@ -69,21 +67,19 @@ same number of arguments before using @tcMatches@ to do the work. \begin{code} tcMatchesFun :: Name - -> [RenamedMatch] + -> [LMatch Name] -> Expected TcRhoType -- Expected type - -> TcM [TcMatch] + -> TcM [LMatch TcId] tcMatchesFun fun_name matches@(first_match:_) expected_ty = -- Check that they all have the same no of arguments - -- Set the location to that of the first equation, so that + -- Location is in the monad, set the caller so that -- any inter-equation error messages get some vaguely -- sensible location. Note: we have to do this odd -- ann-grabbing, because we don't always have annotations in -- hand when we call tcMatchesFun... - addSrcLoc (getMatchLoc first_match) ( - checkTc (sameNoOfArgs matches) - (varyingArgsErr fun_name matches) - ) `thenM_` + checkTc (sameNoOfArgs matches) + (varyingArgsErr fun_name matches) `thenM_` -- ToDo: Don't use "expected" stuff if there ain't a type signature -- because inconsistency between branches @@ -101,10 +97,10 @@ parser guarantees that each equation has exactly one argument. \begin{code} tcMatchesCase :: TcMatchCtxt -- Case context - -> [RenamedMatch] -- The case alternatives + -> [LMatch Name] -- The case alternatives -> Expected TcRhoType -- Type of whole case expressions -> TcM (TcRhoType, -- Inferred type of the scrutinee - [TcMatch]) -- Translated alternatives + [LMatch TcId]) -- Translated alternatives tcMatchesCase ctxt matches (Check expr_ty) = -- This case is a bit yukky, because it prevents the @@ -124,8 +120,8 @@ tcMatchesCase ctxt matches (Infer hole) returnM (scrut_ty, matches') -tcMatchLambda :: RenamedMatch -> Expected TcRhoType -> TcM TcMatch -tcMatchLambda match res_ty = tcMatch match_ctxt match res_ty +tcMatchLambda :: LMatch Name -> Expected TcRhoType -> TcM (LMatch TcId) +tcMatchLambda match res_ty = tcMatch match_ctxt res_ty match where match_ctxt = MC { mc_what = LambdaExpr, mc_body = tcMonoExpr } @@ -134,9 +130,9 @@ tcMatchLambda match res_ty = tcMatch match_ctxt match res_ty @tcGRHSsPat@ typechecks @[GRHSs]@ that occur in a @PatMonoBind@. \begin{code} -tcGRHSsPat :: RenamedGRHSs +tcGRHSsPat :: GRHSs Name -> Expected TcRhoType - -> TcM TcGRHSs + -> TcM (GRHSs TcId) tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty where match_ctxt = MC { mc_what = PatBindRhs, @@ -145,24 +141,22 @@ tcGRHSsPat grhss exp_ty = tcGRHSs match_ctxt grhss exp_ty \begin{code} data TcMatchCtxt -- c.f. TcStmtCtxt, also in this module - = MC { mc_what :: RenamedMatchContext, -- What kind of thing this is - mc_body :: RenamedHsExpr -- Type checker for a body of an alternative + = MC { mc_what :: HsMatchContext Name, -- What kind of thing this is + mc_body :: LHsExpr Name -- Type checker for a body of an alternative -> Expected TcRhoType - -> TcM TcExpr } + -> TcM (LHsExpr TcId) } tcMatches :: TcMatchCtxt - -> [RenamedMatch] + -> [LMatch Name] -> Expected TcRhoType - -> TcM [TcMatch] + -> TcM [LMatch TcId] tcMatches ctxt matches exp_ty = -- If there is more than one branch, and exp_ty is a 'hole', -- all branches must be types, not type schemes, otherwise the -- order in which we check them would affect the result. zapExpectedBranches matches exp_ty `thenM` \ exp_ty' -> - mappM (tc_match exp_ty') matches - where - tc_match exp_ty match = tcMatch ctxt match exp_ty + mappM (tcMatch ctxt exp_ty') matches \end{code} @@ -174,17 +168,18 @@ tcMatches ctxt matches exp_ty \begin{code} tcMatch :: TcMatchCtxt - -> RenamedMatch -> Expected TcRhoType -- Expected result-type of the Match. -- Early unification with this guy gives better error messages -- We regard the Match as having type -- (ty1 -> ... -> tyn -> result_ty) -- where there are n patterns. - -> TcM TcMatch + -> LMatch Name + -> TcM (LMatch TcId) + +tcMatch ctxt exp_ty match = wrapLocM (tc_match ctxt exp_ty) match -tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty - = addSrcLoc (getMatchLoc match) $ -- At one stage I removed this; - addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back +tc_match ctxt expected_ty match@(Match pats maybe_rhs_sig grhss) + = addErrCtxt (matchCtxt (mc_what ctxt) match) $ -- I'm not sure why, so I put it back subFunTys pats expected_ty $ \ pats_w_tys rhs_ty -> -- This is the unique place we call subFunTys -- The point is that if expected_y is a "hole", we want @@ -211,16 +206,16 @@ tcMatch ctxt match@(Match pats maybe_rhs_sig grhss) expected_ty returnM (lift_grhss co_fn rhs_ty' grhss') lift_grhss co_fn rhs_ty (GRHSs grhss binds ty) - = GRHSs (map lift_grhs grhss) binds rhs_ty -- Change the type, since the coercion does + = GRHSs (map (fmap lift_grhs) grhss) binds rhs_ty -- Change the type, since the coercion does where - lift_grhs (GRHS stmts loc) = GRHS (map lift_stmt stmts) loc + lift_grhs (GRHS stmts) = GRHS (map lift_stmt stmts) - lift_stmt (ResultStmt e l) = ResultStmt (co_fn <$> e) l - lift_stmt stmt = stmt + lift_stmt (L loc (ResultStmt e)) = L loc (ResultStmt (fmap (co_fn <$>) e)) + lift_stmt stmt = stmt -tcGRHSs :: TcMatchCtxt -> RenamedGRHSs +tcGRHSs :: TcMatchCtxt -> GRHSs Name -> Expected TcRhoType - -> TcM TcGRHSs + -> TcM (GRHSs TcId) -- Special case when there is just one equation with a degenerate -- guard; then we pass in the full Expected type, so that we get @@ -228,11 +223,11 @@ tcGRHSs :: TcMatchCtxt -> RenamedGRHSs -- f = \(x::forall a.a->a) -> <stuff> -- This is a consequence of the fact that tcStmts takes a TcType, -- not a Expected TcType, a decision we could revisit if necessary -tcGRHSs ctxt (GRHSs [GRHS [ResultStmt rhs loc1] loc2] binds _) exp_ty +tcGRHSs ctxt (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs)])] binds _) exp_ty = tcBindsAndThen glueBindsOnGRHSs binds $ mc_body ctxt rhs exp_ty `thenM` \ rhs' -> readExpectedType exp_ty `thenM` \ exp_ty' -> - returnM (GRHSs [GRHS [ResultStmt rhs' loc1] loc2] EmptyBinds exp_ty') + returnM (GRHSs [L loc1 (GRHS [L loc2 (ResultStmt rhs')])] [] exp_ty') tcGRHSs ctxt (GRHSs grhss binds _) exp_ty = tcBindsAndThen glueBindsOnGRHSs binds $ @@ -247,13 +242,12 @@ tcGRHSs ctxt (GRHSs grhss binds _) exp_ty sc_ty = exp_ty' } sc_body body = mc_body ctxt body (Check exp_ty') - tc_grhs (GRHS guarded locn) - = addSrcLoc locn $ - tcStmts stmt_ctxt guarded `thenM` \ guarded' -> - returnM (GRHS guarded' locn) + tc_grhs (GRHS guarded) + = tcStmts stmt_ctxt guarded `thenM` \ guarded' -> + returnM (GRHS guarded') in - mappM tc_grhs grhss `thenM` \ grhss' -> - returnM (GRHSs grhss' EmptyBinds exp_ty') + mappM (wrapLocM tc_grhs) grhss `thenM` \ grhss' -> + returnM (GRHSs grhss' [] exp_ty') \end{code} @@ -290,10 +284,10 @@ tcThingWithSig sig_ty thing_inside res_ty \begin{code} tcMatchPats - :: [(RenamedPat, Expected TcRhoType)] + :: [(LPat Name, Expected TcRhoType)] -> Expected TcRhoType -> TcM a - -> TcM ([TcPat], a, TcHsBinds) + -> TcM ([LPat TcId], a, HsBindGroup TcId) -- Typecheck the patterns, extend the environment to bind the variables, -- do the thing inside, use any existentially-bound dictionaries to -- discharge parts of the returning LIE, and deal with pattern type @@ -324,7 +318,7 @@ tcMatchPats pats_w_tys body_ty thing_inside -- f (C g) x = g x -- Here, result_ty will be simply Int, but expected_ty is (C -> a -> Int). - returnM (pats', result, mkMonoBind Recursive ex_binds) + returnM (pats', result, HsBindGroup ex_binds [] Recursive) tc_match_pats [] thing_inside = thing_inside `thenM` \ answer -> @@ -367,7 +361,7 @@ tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty -- Here we must discharge op Methods = ASSERT( null ex_lie ) extendLIEs lie_req `thenM_` - returnM EmptyMonoBinds + returnM emptyBag | otherwise = -- Read the by-now-filled-in expected types @@ -385,7 +379,7 @@ tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty -- Check for type variable escape checkSigTyVarsWrt (tyVarsOfTypes tys) tv_list `thenM_` - returnM (dict_binds `AndMonoBinds` inst_binds) + returnM (dict_binds `unionBags` inst_binds) where doc = text ("existential context of a data constructor") tv_list = bagToList ex_tvs @@ -401,9 +395,9 @@ tcCheckExistentialPat ex_tvs ex_ids ex_lie lie_req pats_w_tys body_ty \begin{code} tcDoStmts :: HsStmtContext Name - -> [RenamedStmt] -> ReboundNames Name + -> [LStmt Name] -> ReboundNames Name -> TcRhoType -- To keep it simple, we don't have an "expected" type here - -> TcM ([TcStmt], ReboundNames TcId) + -> TcM ([LStmt TcId], ReboundNames TcId) tcDoStmts PArrComp stmts method_names res_ty = unifyPArrTy res_ty `thenM` \elt_ty -> tcComprehension PArrComp mkPArrTy elt_ty stmts `thenM` \ stmts' -> @@ -482,14 +476,14 @@ tcStmts ctxt stmts data TcStmtCtxt = SC { sc_what :: HsStmtContext Name, -- What kind of thing this is - sc_rhs :: RenamedHsExpr -> TcType -> TcM TcExpr, -- Type checker for RHS computations - sc_body :: RenamedHsExpr -> TcM TcExpr, -- Type checker for return computation + sc_rhs :: LHsExpr Name -> TcType -> TcM (LHsExpr TcId), -- Type checker for RHS computations + sc_body :: LHsExpr Name -> TcM (LHsExpr TcId), -- Type checker for return computation sc_ty :: TcType } -- Return type; used *only* to check -- for escape in existential patterns tcStmtsAndThen - :: (TcStmt -> thing -> thing) -- Combiner + :: (LStmt TcId -> thing -> thing) -- Combiner -> TcStmtCtxt - -> [RenamedStmt] + -> [LStmt Name] -> TcM thing -> TcM thing @@ -503,36 +497,36 @@ tcStmtsAndThen combine ctxt (stmt:stmts) thing_inside thing_inside -- LetStmt -tcStmtAndThen combine ctxt (LetStmt binds) thing_inside +tcStmtAndThen combine ctxt (L _ (LetStmt binds)) thing_inside = tcBindsAndThen -- No error context, but a binding group is (glue_binds combine) -- rather a large thing for an error context anyway binds thing_inside -- BindStmt -tcStmtAndThen combine ctxt stmt@(BindStmt pat exp src_loc) thing_inside - = addSrcLoc src_loc $ +tcStmtAndThen combine ctxt (L src_loc stmt@(BindStmt pat exp)) thing_inside + = addSrcSpan src_loc $ addErrCtxt (stmtCtxt ctxt stmt) $ newTyVarTy liftedTypeKind `thenM` \ pat_ty -> sc_rhs ctxt exp pat_ty `thenM` \ exp' -> tcMatchPats [(pat, Check pat_ty)] (Check (sc_ty ctxt)) ( popErrCtxt thing_inside ) `thenM` \ ([pat'], thing, dict_binds) -> - returnM (combine (BindStmt pat' exp' src_loc) + returnM (combine (L src_loc (BindStmt pat' exp')) (glue_binds combine dict_binds thing)) -- ExprStmt -tcStmtAndThen combine ctxt stmt@(ExprStmt exp _ src_loc) thing_inside - = addSrcLoc src_loc ( +tcStmtAndThen combine ctxt (L src_loc stmt@(ExprStmt exp _)) thing_inside + = addSrcSpan src_loc ( addErrCtxt (stmtCtxt ctxt stmt) $ if isDoExpr (sc_what ctxt) then -- do or mdo; the expression is a computation newTyVarTy openTypeKind `thenM` \ any_ty -> sc_rhs ctxt exp any_ty `thenM` \ exp' -> - returnM (ExprStmt exp' any_ty src_loc) + returnM (L src_loc (ExprStmt exp' any_ty)) else -- List comprehensions, pattern guards; expression is a boolean tcCheckRho exp boolTy `thenM` \ exp' -> - returnM (ExprStmt exp' boolTy src_loc) + returnM (L src_loc (ExprStmt exp' boolTy)) ) `thenM` \ stmt' -> thing_inside `thenM` \ thing -> @@ -540,9 +534,9 @@ tcStmtAndThen combine ctxt stmt@(ExprStmt exp _ src_loc) thing_inside -- ParStmt -tcStmtAndThen combine ctxt (ParStmt bndr_stmts_s) thing_inside +tcStmtAndThen combine ctxt (L src_loc (ParStmt bndr_stmts_s)) thing_inside = loop bndr_stmts_s `thenM` \ (pairs', thing) -> - returnM (combine (ParStmt pairs') thing) + returnM (combine (L src_loc (ParStmt pairs')) thing) where loop [] = thing_inside `thenM` \ thing -> returnM ([], thing) @@ -558,7 +552,7 @@ tcStmtAndThen combine ctxt (ParStmt bndr_stmts_s) thing_inside combine_par stmt ((stmts, bndrs) : pairs , thing) = ((stmt:stmts, bndrs) : pairs, thing) -- RecStmt -tcStmtAndThen combine ctxt (RecStmt stmts laterNames recNames _) thing_inside +tcStmtAndThen combine ctxt (L src_loc (RecStmt stmts laterNames recNames _)) thing_inside = newTyVarTys (length recNames) liftedTypeKind `thenM` \ recTys -> let rec_ids = zipWith mkLocalId recNames recTys @@ -575,7 +569,7 @@ tcStmtAndThen combine ctxt (RecStmt stmts laterNames recNames _) thing_inside -- already scope over this part thing_inside `thenM` \ thing -> - returnM (combine (RecStmt stmts' later_ids rec_ids rec_rets) thing) + returnM (combine (L src_loc (RecStmt stmts' later_ids rec_ids rec_rets)) thing) where combine_rec stmt (stmts, thing) = (stmt:stmts, thing) @@ -585,18 +579,18 @@ tcStmtAndThen combine ctxt (RecStmt stmts laterNames recNames _) thing_inside -- poly_id may have a polymorphic type -- but mono_ty is just a monomorphic type variable tcSubExp (Check mono_ty) (idType poly_id) `thenM` \ co_fn -> - returnM (co_fn <$> HsVar poly_id) + returnM (L src_loc (co_fn <$> HsVar poly_id)) -- Result statements -tcStmtAndThen combine ctxt stmt@(ResultStmt exp locn) thing_inside +tcStmtAndThen combine ctxt (L src_loc stmt@(ResultStmt exp)) thing_inside = addErrCtxt (stmtCtxt ctxt stmt) (sc_body ctxt exp) `thenM` \ exp' -> thing_inside `thenM` \ thing -> - returnM (combine (ResultStmt exp' locn) thing) + returnM (combine (L src_loc (ResultStmt exp')) thing) ------------------------------ -glue_binds combine EmptyBinds thing = thing -glue_binds combine other_binds thing = combine (LetStmt other_binds) thing +glue_binds combine binds thing = combine (noLoc (LetStmt [binds])) thing + -- ToDo: fix the noLoc \end{code} @@ -610,11 +604,11 @@ glue_binds combine other_binds thing = combine (LetStmt other_binds) thing number of args are used in each equation. \begin{code} -sameNoOfArgs :: [RenamedMatch] -> Bool +sameNoOfArgs :: [LMatch Name] -> Bool sameNoOfArgs matches = isSingleton (nub (map args_in_match matches)) where - args_in_match :: RenamedMatch -> Int - args_in_match (Match pats _ _) = length pats + args_in_match :: LMatch Name -> Int + args_in_match (L _ (Match pats _ _)) = length pats \end{code} \begin{code} @@ -627,8 +621,8 @@ matchCtxt ctxt match = hang (ptext SLIT("In") <+> pprMatchContext ctxt <> colo stmtCtxt ctxt stmt = hang (ptext SLIT("In") <+> pp_ctxt (sc_what ctxt) <> colon) 4 (ppr stmt) where pp_ctxt = case stmt of - ResultStmt _ _ -> pprStmtResultContext - other -> pprStmtContext + ResultStmt _ -> pprStmtResultContext + other -> pprStmtContext sigPatCtxt bound_tvs bound_ids tys tidy_env = -- tys is (body_ty : pat_tys) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 8f6840452e..cf0ec1166a 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -10,9 +10,9 @@ module TcPat ( tcPat, tcMonoPatBndr, tcSubPat, #include "HsVersions.h" -import HsSyn ( Pat(..), HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..) ) -import RnHsSyn ( RenamedPat ) -import TcHsSyn ( TcPat, TcId, hsLitType, +import HsSyn ( Pat(..), LPat, HsConDetails(..), HsLit(..), HsOverLit(..), HsExpr(..) ) +import HsUtils +import TcHsSyn ( TcId, hsLitType, mkCoercion, idCoercion, isIdCoercion, (<$>), PatCoFn ) @@ -24,7 +24,7 @@ import Inst ( InstOrigin(..), import Id ( idType, mkLocalId, mkSysLocal ) import Name ( Name ) import FieldLabel ( fieldLabelName ) -import TcEnv ( tcLookupClass, tcLookupDataCon, tcLookupId ) +import TcEnv ( tcLookupClass, tcLookupLocatedDataCon, tcLookupId ) import TcMType ( newTyVarTy, arityErr ) import TcType ( TcType, TcTyVar, TcSigmaType, mkClassPred, liftedTypeKind ) @@ -38,6 +38,7 @@ import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity ) import PrelNames ( eqStringName, eqName, geName, negateName, minusName, integralClassName ) import BasicTypes ( isBoxed ) +import SrcLoc ( Located(..), noLoc, unLoc ) import Bag import Outputable import FastString @@ -90,13 +91,13 @@ tcMonoPatBndr binder_name pat_ty \begin{code} tcPat :: BinderChecker - -> RenamedPat + -> LPat Name -> Expected TcSigmaType -- Expected type derived from the context -- In the case of a function with a rank-2 signature, -- this type might be a forall type. - -> TcM (TcPat, + -> TcM (LPat TcId, Bag TcTyVar, -- TyVars bound by the pattern -- These are just the existentially-bound ones. -- Any tyvars bound by *type signatures* in the @@ -107,6 +108,10 @@ tcPat :: BinderChecker -- local name for each variable. [Inst]) -- Dicts or methods [see below] bound by the pattern -- from existential constructor patterns +tcPat tc_bndr (L span pat) exp_ty + = addSrcSpan span $ + do { (pat', tvs, ids, lie) <- tc_pat tc_bndr pat exp_ty + ; return (L span pat', tvs, ids, lie) } \end{code} @@ -117,47 +122,47 @@ tcPat :: BinderChecker %************************************************************************ \begin{code} -tcPat tc_bndr pat@(TypePat ty) pat_ty +tc_pat tc_bndr pat@(TypePat ty) pat_ty = failWithTc (badTypePat pat) -tcPat tc_bndr (VarPat name) pat_ty +tc_pat tc_bndr (VarPat name) pat_ty = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) -> returnM (co_fn <$> VarPat bndr_id, - emptyBag, unitBag (name, bndr_id), []) + emptyBag, unitBag (name, bndr_id), []) -tcPat tc_bndr (LazyPat pat) pat_ty +tc_pat tc_bndr (LazyPat pat) pat_ty = tcPat tc_bndr pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> returnM (LazyPat pat', tvs, ids, lie_avail) -tcPat tc_bndr pat_in@(AsPat name pat) pat_ty - = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) -> +tc_pat tc_bndr pat_in@(AsPat (L nm_loc name) pat) pat_ty + = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) -> tcPat tc_bndr pat (Check (idType bndr_id)) `thenM` \ (pat', tvs, ids, lie_avail) -> -- NB: if we have: -- \ (y@(x::forall a. a->a)) = e -- we'll fail. The as-pattern infers a monotype for 'y', which then -- fails to unify with the polymorphic type for 'x'. This could be -- fixed, but only with a bit more work. - returnM (co_fn <$> (AsPat bndr_id pat'), + returnM (co_fn <$> (AsPat (L nm_loc bndr_id) pat'), tvs, (name, bndr_id) `consBag` ids, lie_avail) -tcPat tc_bndr (WildPat _) pat_ty +tc_pat tc_bndr (WildPat _) pat_ty = zapExpectedType pat_ty `thenM` \ pat_ty' -> -- We might have an incoming 'hole' type variable; no annotation -- so zap it to a type. Rather like tcMonoPatBndr. returnM (WildPat pat_ty', emptyBag, emptyBag, []) -tcPat tc_bndr (ParPat parend_pat) pat_ty +tc_pat tc_bndr (ParPat parend_pat) pat_ty -- Leave the parens in, so that warnings from the -- desugarer have parens in them = tcPat tc_bndr parend_pat pat_ty `thenM` \ (pat', tvs, ids, lie_avail) -> returnM (ParPat pat', tvs, ids, lie_avail) -tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty +tc_pat tc_bndr pat_in@(SigPatIn pat sig) pat_ty = addErrCtxt (patCtxt pat_in) $ tcHsSigType PatSigCtxt sig `thenM` \ sig_ty -> tcSubPat sig_ty pat_ty `thenM` \ co_fn -> tcPat tc_bndr pat (Check sig_ty) `thenM` \ (pat', tvs, ids, lie_avail) -> - returnM (co_fn <$> pat', tvs, ids, lie_avail) + returnM (co_fn <$> unLoc pat', tvs, ids, lie_avail) \end{code} @@ -168,19 +173,19 @@ tcPat tc_bndr pat_in@(SigPatIn pat sig) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat_in@(ListPat pats _) pat_ty +tc_pat tc_bndr pat_in@(ListPat pats _) pat_ty = addErrCtxt (patCtxt pat_in) $ zapToListTy pat_ty `thenM` \ elem_ty -> tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) -> returnM (ListPat pats' elem_ty, tvs, ids, lie_avail) -tcPat tc_bndr pat_in@(PArrPat pats _) pat_ty +tc_pat tc_bndr pat_in@(PArrPat pats _) pat_ty = addErrCtxt (patCtxt pat_in) $ zapToPArrTy pat_ty `thenM` \ elem_ty -> tcPats tc_bndr pats (repeat elem_ty) `thenM` \ (pats', tvs, ids, lie_avail) -> returnM (PArrPat pats' elem_ty, tvs, ids, lie_avail) -tcPat tc_bndr pat_in@(TuplePat pats boxity) pat_ty +tc_pat tc_bndr pat_in@(TuplePat pats boxity) pat_ty = addErrCtxt (patCtxt pat_in) $ zapToTupleTy boxity arity pat_ty `thenM` \ arg_tys -> @@ -196,7 +201,7 @@ tcPat tc_bndr pat_in@(TuplePat pats boxity) pat_ty -- it was easy to do. possibly_mangled_result - | opt_IrrefutableTuples && isBoxed boxity = LazyPat unmangled_result + | opt_IrrefutableTuples && isBoxed boxity = LazyPat (noLoc unmangled_result) | otherwise = unmangled_result in returnM (possibly_mangled_result, tvs, ids, lie_avail) @@ -213,11 +218,11 @@ tcPat tc_bndr pat_in@(TuplePat pats boxity) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty +tc_pat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty = addErrCtxt (patCtxt pat_in) $ -- Check that it's a constructor, and instantiate it - tcLookupDataCon con_name `thenM` \ data_con -> + tcLookupLocatedDataCon con_name `thenM` \ data_con -> tcInstDataCon (PatOrigin pat_in) data_con `thenM` \ (_, ex_dicts1, arg_tys, con_res_ty, ex_tvs) -> -- Check overall type matches. @@ -242,19 +247,19 @@ tcPat tc_bndr pat_in@(ConPatIn con_name arg_pats) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty +tc_pat tc_bndr pat@(LitPat lit@(HsString _)) pat_ty = zapExpectedType pat_ty `thenM` \ pat_ty' -> unifyTauTy pat_ty' stringTy `thenM_` tcLookupId eqStringName `thenM` \ eq_id -> - returnM (NPatOut lit stringTy (HsVar eq_id `HsApp` HsLit lit), + returnM (NPatOut lit stringTy (nlHsVar eq_id `HsApp` nlHsLit lit), emptyBag, emptyBag, []) -tcPat tc_bndr (LitPat simple_lit) pat_ty +tc_pat tc_bndr (LitPat simple_lit) pat_ty = zapExpectedType pat_ty `thenM` \ pat_ty' -> unifyTauTy pat_ty' (hsLitType simple_lit) `thenM_` returnM (LitPat simple_lit, emptyBag, emptyBag, []) -tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty +tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty = zapExpectedType pat_ty `thenM` \ pat_ty' -> newOverloadedLit origin over_lit pat_ty' `thenM` \ pos_lit_expr -> newMethodFromName origin pat_ty' eqName `thenM` \ eq -> @@ -262,8 +267,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty Nothing -> returnM pos_lit_expr -- Positive literal Just neg -> -- Negative literal -- The 'negate' is re-mappable syntax - tcSyntaxName origin pat_ty' (negateName, HsVar neg) `thenM` \ (_, neg_expr) -> - returnM (HsApp neg_expr pos_lit_expr) + tcSyntaxName origin pat_ty' (negateName, noLoc (HsVar neg)) `thenM` \ (_, neg_expr) -> + returnM (mkHsApp neg_expr pos_lit_expr) ) `thenM` \ lit_expr -> let @@ -276,7 +281,7 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty (HsFractional f _, Nothing) -> HsRat f pat_ty' (HsFractional f _, Just _) -> HsRat (-f) pat_ty' in - returnM (NPatOut lit' pat_ty' (HsApp (HsVar eq) lit_expr), + returnM (NPatOut lit' pat_ty' (HsApp (nlHsVar eq) lit_expr), emptyBag, emptyBag, []) where origin = PatOrigin pat @@ -289,8 +294,8 @@ tcPat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty %************************************************************************ \begin{code} -tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty - = tc_bndr name pat_ty `thenM` \ (co_fn, bndr_id) -> +tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name) pat_ty + = addSrcSpan nm_loc (tc_bndr name pat_ty) `thenM` \ (co_fn, bndr_id) -> let pat_ty' = idType bndr_id in @@ -298,7 +303,7 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty newMethodFromName origin pat_ty' geName `thenM` \ ge -> -- The '-' part is re-mappable syntax - tcSyntaxName origin pat_ty' (minusName, HsVar minus_name) `thenM` \ (_, minus_expr) -> + tcSyntaxName origin pat_ty' (minusName, noLoc (HsVar minus_name)) `thenM` \ (_, minus_expr) -> -- The Report says that n+k patterns must be in Integral -- We may not want this when using re-mappable syntax, though (ToDo?) @@ -306,8 +311,8 @@ tcPat tc_bndr pat@(NPlusKPatIn name lit@(HsIntegral i _) minus_name) pat_ty newDicts origin [mkClassPred icls [pat_ty']] `thenM` \ dicts -> extendLIEs dicts `thenM_` - returnM (NPlusKPatOut bndr_id i - (SectionR (HsVar ge) over_lit_expr) + returnM (NPlusKPatOut (L nm_loc bndr_id) i + (SectionR (nlHsVar ge) over_lit_expr) (SectionR minus_expr over_lit_expr), emptyBag, unitBag (name, bndr_id), []) where @@ -325,8 +330,8 @@ Helper functions \begin{code} tcPats :: BinderChecker -- How to deal with variables - -> [RenamedPat] -> [TcType] -- Excess 'expected types' discarded - -> TcM ([TcPat], + -> [LPat Name] -> [TcType] -- Excess 'expected types' discarded + -> TcM ([LPat TcId], Bag TcTyVar, Bag (Name, TcId), -- Ids bound by the pattern [Inst]) -- Dicts bound by the pattern @@ -393,7 +398,7 @@ tcConStuff tc_bndr data_con (RecCon rpats) arg_tys tc_fields field_tys [] = returnM ([], emptyBag, emptyBag, []) - tc_fields field_tys ((field_label, rhs_pat) : rpats) + tc_fields field_tys ((L lbl_loc field_label, rhs_pat) : rpats) = tc_fields field_tys rpats `thenM` \ (rpats', tvs1, ids1, lie_avail1) -> (case [ty | (f,ty) <- field_tys, f == field_label] of @@ -413,13 +418,13 @@ tcConStuff tc_bndr data_con (RecCon rpats) arg_tys -- The normal case, when the field comes from the right constructor (pat_ty : extras) -> ASSERT( null extras ) - tcLookupId field_label `thenM` \ sel_id -> + addSrcSpan lbl_loc (tcLookupId field_label) `thenM` \ sel_id -> returnM (sel_id, pat_ty) ) `thenM` \ (sel_id, pat_ty) -> tcPat tc_bndr rhs_pat (Check pat_ty) `thenM` \ (rhs_pat', tvs2, ids2, lie_avail2) -> - returnM ((sel_id, rhs_pat') : rpats', + returnM ((L lbl_loc sel_id, rhs_pat') : rpats', tvs1 `unionBags` tvs2, ids1 `unionBags` ids2, lie_avail1 ++ lie_avail2) @@ -461,8 +466,8 @@ tcSubPat sig_ty exp_ty readExpectedType exp_ty `thenM` \ exp_ty' -> let arg_id = mkSysLocal FSLIT("sub") uniq exp_ty' - the_fn = DictLam [arg_id] (co_fn <$> HsVar arg_id) - pat_co_fn p = SigPatOut p exp_ty' the_fn + the_fn = DictLam [arg_id] (noLoc (co_fn <$> HsVar arg_id)) + pat_co_fn p = SigPatOut (noLoc p) exp_ty' the_fn in returnM (mkCoercion pat_co_fn) \end{code} diff --git a/ghc/compiler/typecheck/TcRnDriver.lhs b/ghc/compiler/typecheck/TcRnDriver.lhs index 7fbbc32cb3..03b2e46baa 100644 --- a/ghc/compiler/typecheck/TcRnDriver.lhs +++ b/ghc/compiler/typecheck/TcRnDriver.lhs @@ -21,12 +21,8 @@ import {-# SOURCE #-} TcSplice ( tcSpliceDecls ) import CmdLineOpts ( DynFlag(..), opt_PprStyle_Debug, dopt ) import DriverState ( v_MainModIs, v_MainFunIs ) -import HsSyn ( HsModule(..), HsBinds(..), MonoBinds(..), HsExpr(..), - HsGroup(..), SpliceDecl(..), HsExtCore(..), - andMonoBinds - ) -import RdrHsSyn ( RdrNameHsModule, RdrNameHsDecl, - findSplice, main_RDR_Unqual ) +import HsSyn +import RdrHsSyn ( findSplice, main_RDR_Unqual ) import PrelNames ( runIOName, rootMainName, mAIN_Name ) import RdrName ( RdrName, mkRdrUnqual, emptyGlobalRdrEnv, @@ -60,9 +56,9 @@ import OccName ( mkVarOcc ) import Name ( Name, isExternalName, getSrcLoc, getOccName ) import NameSet import TyCon ( tyConHasGenerics ) +import SrcLoc ( srcLocSpan, Located(..), noLoc, unLoc ) import Outputable -import HscTypes ( ModIface, ModDetails(..), ModGuts(..), - HscEnv(..), ModIface(..), ModDetails(..), +import HscTypes ( ModGuts(..), HscEnv(..), GhciMode(..), noDependencies, Deprecs( NoDeprecs ), plusDeprecs, GenAvailInfo(Avail), availsToNameSet, availName, @@ -72,15 +68,13 @@ import HscTypes ( ModIface, ModDetails(..), ModGuts(..), ) #ifdef GHCI import HsSyn ( HsStmtContext(..), - Stmt(..), Pat(VarPat), + Stmt(..), collectStmtsBinders, mkSimpleMatch, placeHolderType ) -import RdrHsSyn ( RdrNameHsExpr, RdrNameStmt ) import RdrName ( GlobalRdrEnv, mkGlobalRdrEnv, GlobalRdrElt(..), Provenance(..), ImportSpec(..), lookupLocalRdrEnv, extendLocalRdrEnv ) -import RnHsSyn ( RenamedStmt ) import RnSource ( addTcgDUs ) -import TcHsSyn ( TypecheckedHsExpr, mkHsLet, zonkTopExpr, zonkTopBndrs ) +import TcHsSyn ( mkHsLet, zonkTopLExpr, zonkTopBndrs ) import TcExpr ( tcCheckRho ) import TcMType ( zonkTcType ) import TcMatches ( tcStmtsAndThen, TcStmtCtxt(..) ) @@ -89,12 +83,11 @@ import TcType ( Type, mkForAllTys, mkFunTys, mkTyConApp, tyVarsOfType ) import TcEnv ( tcLookupTyCon, tcLookupId ) import TyCon ( DataConDetails(..) ) import Inst ( tcStdSyntaxName ) -import RnExpr ( rnStmts, rnExpr ) +import RnExpr ( rnStmts, rnLExpr ) import RnNames ( exportsToAvails ) import LoadIface ( loadSrcInterface ) import IfaceSyn ( IfaceDecl(..), IfaceClassOp(..), IfaceConDecl(..), IfaceExtName(..), tyThingToIfaceDecl ) -import IfaceEnv ( tcIfaceGlobal ) import RnEnv ( lookupOccRn, dataTcOccs, lookupFixityRn ) import Id ( Id, isImplicitId ) import MkId ( unsafeCoerceId ) @@ -108,13 +101,17 @@ import PrelNames ( iNTERACTIVE, ioTyConName, printName, monadNames, itName, retu import Module ( ModuleName, lookupModuleEnvByName ) import HscTypes ( InteractiveContext(..), HomeModInfo(..), typeEnvElts, - TyThing(..), availNames, icPrintUnqual ) + TyThing(..), availNames, icPrintUnqual, + ModIface(..), ModDetails(..) ) import BasicTypes ( RecFlag(..), Fixity ) import Panic ( ghcError, GhcException(..) ) #endif import FastString ( mkFastString ) import Util ( sortLt ) +import Bag ( unionBags, snocBag, unitBag ) + +import Maybe ( isJust ) \end{code} @@ -128,18 +125,21 @@ import Util ( sortLt ) \begin{code} tcRnModule :: HscEnv - -> RdrNameHsModule + -> Located (HsModule RdrName) -> IO (Maybe TcGblEnv) -tcRnModule hsc_env - (HsModule maybe_mod exports import_decls local_decls mod_deprec loc) +tcRnModule hsc_env (L loc (HsModule maybe_mod exports + import_decls local_decls mod_deprec)) = do { showPass (hsc_dflags hsc_env) "Renamer/typechecker" ; let { this_mod = case maybe_mod of - Nothing -> mkHomeModule mAIN_Name -- 'module M where' is omitted - Just mod -> mod } ; -- The normal case + Nothing -> mkHomeModule mAIN_Name + -- 'module M where' is omitted + Just (L _ mod) -> mod } ; + -- The normal case - initTc hsc_env this_mod $ addSrcLoc loc $ + initTc hsc_env this_mod $ + addSrcSpan loc $ do { -- Deal with imports; sets tcg_rdr_env, tcg_imports (rdr_env, imports) <- rnImports import_decls ; updGblEnv ( \ gbl -> gbl { tcg_rdr_env = rdr_env, @@ -163,7 +163,7 @@ tcRnModule hsc_env traceRn (text "rn3") ; -- Process the export list - export_avails <- exportsFromAvail maybe_mod exports ; + export_avails <- exportsFromAvail (isJust maybe_mod) exports ; -- Get any supporting decls for the exports that have not already -- been sucked in for the declarations in the body of the module. @@ -209,8 +209,8 @@ tcRnModule hsc_env #ifdef GHCI tcRnStmt :: HscEnv -> InteractiveContext - -> RdrNameStmt - -> IO (Maybe (InteractiveContext, [Name], TypecheckedHsExpr)) + -> LStmt RdrName + -> IO (Maybe (InteractiveContext, [Name], LHsExpr Id)) -- The returned [Name] is the same as the input except for -- ExprStmt, in which case the returned [Name] is [itName] -- @@ -290,23 +290,24 @@ Here is the grand plan, implemented in tcUserStmt \begin{code} --------------------------- -tcUserStmt :: RenamedStmt -> TcM ([Id], TypecheckedHsExpr) -tcUserStmt (ExprStmt expr _ loc) +tcUserStmt :: LStmt Name -> TcM ([Id], LHsExpr Id) +tcUserStmt (L _ (ExprStmt expr _)) = newUnique `thenM` \ uniq -> let fresh_it = itName uniq - the_bind = FunMonoBind fresh_it False - [ mkSimpleMatch [] expr placeHolderType loc ] loc + the_bind = noLoc $ FunBind (noLoc fresh_it) False + [ mkSimpleMatch [] expr placeHolderType ] in tryTcLIE_ (do { -- Try this if the other fails traceTc (text "tcs 1b") ; tc_stmts [ - LetStmt (MonoBind the_bind [] NonRecursive), - ExprStmt (HsApp (HsVar printName) (HsVar fresh_it)) - placeHolderType loc] }) + nlLetStmt [HsBindGroup (unitBag the_bind) [] NonRecursive], + nlExprStmt (nlHsApp (nlHsVar printName) + (nlHsVar fresh_it)) + ] }) (do { -- Try this first traceTc (text "tcs 1a") ; - tc_stmts [BindStmt (VarPat fresh_it) expr loc] }) + tc_stmts [nlBindStmt (nlVarPat fresh_it) expr] }) tcUserStmt stmt = tc_stmts [stmt] @@ -317,7 +318,7 @@ tc_stmts stmts ret_ty = mkListTy unitTy ; io_ret_ty = mkTyConApp ioTyCon [ret_ty] ; - names = collectStmtsBinders stmts ; + names = map unLoc (collectStmtsBinders stmts) ; stmt_ctxt = SC { sc_what = DoExpr, sc_rhs = check_rhs, @@ -338,10 +339,10 @@ tc_stmts stmts -- then the type checker would instantiate x..z, and we wouldn't -- get their *polymorphic* values. (And we'd get ambiguity errs -- if they were overloaded, since they aren't applied to anything.) - mk_return ret_id ids = HsApp (TyApp (HsVar ret_id) [ret_ty]) - (ExplicitList unitTy (map mk_item ids)) ; - mk_item id = HsApp (TyApp (HsVar unsafeCoerceId) [idType id, unitTy]) - (HsVar id) ; + mk_return ret_id ids = nlHsApp (noLoc $ TyApp (nlHsVar ret_id) [ret_ty]) + (noLoc $ ExplicitList unitTy (map mk_item ids)) ; + mk_item id = nlHsApp (noLoc $ TyApp (nlHsVar unsafeCoerceId) [idType id, unitTy]) + (nlHsVar id) ; io_ty = mkTyConApp ioTyCon [] } ; @@ -355,10 +356,10 @@ tc_stmts stmts -- where they will all be in scope ids <- mappM tcLookupId names ; ret_id <- tcLookupId returnIOName ; -- return @ IO - return (ids, [ResultStmt (mk_return ret_id ids) interactiveSrcLoc]) } ; + return (ids, [nlResultStmt (mk_return ret_id ids)]) } ; io_ids <- mappM (tcStdSyntaxName DoOrigin io_ty) monadNames ; - return (ids, HsDo DoExpr tc_stmts io_ids io_ret_ty interactiveSrcLoc) + return (ids, noLoc (HsDo DoExpr tc_stmts io_ids io_ret_ty)) } ; -- Simplify the context right here, so that we fail @@ -372,7 +373,7 @@ tc_stmts stmts -- Build result expression and zonk it let { expr = mkHsLet const_binds tc_expr } ; - zonked_expr <- zonkTopExpr expr ; + zonked_expr <- zonkTopLExpr expr ; zonked_ids <- zonkTopBndrs ids ; return (zonked_ids, zonked_expr) @@ -387,13 +388,13 @@ tcRnExpr just finds the type of an expression \begin{code} tcRnExpr :: HscEnv -> InteractiveContext - -> RdrNameHsExpr + -> LHsExpr RdrName -> IO (Maybe Type) tcRnExpr hsc_env ictxt rdr_expr = initTc hsc_env iNTERACTIVE $ setInteractiveContext ictxt $ do { - (rn_expr, fvs) <- rnExpr rdr_expr ; + (rn_expr, fvs) <- rnLExpr rdr_expr ; failIfErrsM ; -- Now typecheck the expression; @@ -497,15 +498,17 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) initTc hsc_env this_mod $ do { + let { ldecls = map noLoc decls } ; + -- Deal with the type declarations; first bring their stuff -- into scope, then rname them, then type check them - (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup decls) ; + (rdr_env, imports) <- importsFromLocalDecls (mkFakeGroup ldecls) ; updGblEnv (\gbl -> gbl { tcg_rdr_env = rdr_env `plusGlobalRdrEnv` tcg_rdr_env gbl, tcg_imports = imports `plusImportAvails` tcg_imports gbl }) $ do { - rn_decls <- rnTyClDecls decls ; + rn_decls <- rnTyClDecls ldecls ; failIfErrsM ; -- Dump trace of renaming part @@ -553,7 +556,7 @@ tcRnExtCore hsc_env (HsExtCore this_mod decls src_binds) mkFakeGroup decls -- Rather clumsy; lots of unused fields = HsGroup { hs_tyclds = decls, -- This is the one we want - hs_valds = EmptyBinds, hs_fords = [], + hs_valds = [], hs_fords = [], hs_instds = [], hs_fixds = [], hs_depds = [], hs_ruleds = [], hs_defds = [] } \end{code} @@ -566,7 +569,7 @@ mkFakeGroup decls -- Rather clumsy; lots of unused fields %************************************************************************ \begin{code} -tcRnSrcDecls :: [RdrNameHsDecl] -> TcM TcGblEnv +tcRnSrcDecls :: [LHsDecl RdrName] -> TcM TcGblEnv -- Returns the variables free in the decls -- Reason: solely to report unused imports and bindings tcRnSrcDecls decls @@ -592,7 +595,7 @@ tcRnSrcDecls decls TcGblEnv { tcg_type_env = type_env, tcg_binds = binds, tcg_rules = rules, tcg_fords = fords } = tcg_env } ; - (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `andMonoBinds` inst_binds) + (bind_ids, binds', fords', rules') <- zonkTopDecls (binds `unionBags` inst_binds) rules fords ; let { final_type_env = extendTypeEnvWithIds type_env bind_ids } ; @@ -604,7 +607,7 @@ tcRnSrcDecls decls tcg_binds = binds', tcg_rules = rules', tcg_fords = fords' }) } -tc_rn_src_decls :: [RdrNameHsDecl] -> TcM (TcGblEnv, TcLclEnv) +tc_rn_src_decls :: [LHsDecl RdrName] -> TcM (TcGblEnv, TcLclEnv) -- Loops around dealing with each top level inter-splice group -- in turn, until it's dealt with the entire module tc_rn_src_decls ds @@ -629,14 +632,13 @@ tc_rn_src_decls ds } ; -- If there's a splice, we must carry on - Just (SpliceDecl splice_expr splice_loc, rest_ds) -> do { + Just (SpliceDecl splice_expr, rest_ds) -> do { #ifndef GHCI failWithTc (text "Can't do a top-level splice; need a bootstrapped compiler") #else -- Rename the splice expression, and get its supporting decls - (rn_splice_expr, splice_fvs) <- addSrcLoc splice_loc $ - rnExpr splice_expr ; + (rn_splice_expr, splice_fvs) <- rnLExpr splice_expr ; failIfErrsM ; -- Don't typecheck if renaming failed -- Execute the splice @@ -744,7 +746,7 @@ tcTopSrcDecls -- We also typecheck any extra binds that came out -- of the "deriving" process (deriv_binds) traceTc (text "Tc5") ; - (tc_val_binds, lcl_env) <- tcTopBinds (val_binds `ThenBinds` deriv_binds) ; + (tc_val_binds, lcl_env) <- tcTopBinds (val_binds ++ deriv_binds) ; setLclTypeEnv lcl_env $ do { -- Second pass over class and instance declarations, @@ -763,13 +765,13 @@ tcTopSrcDecls -- Wrap up traceTc (text "Tc7a") ; tcg_env <- getGblEnv ; - let { all_binds = tc_val_binds `AndMonoBinds` - inst_binds `AndMonoBinds` + let { all_binds = tc_val_binds `unionBags` + inst_binds `unionBags` foe_binds ; -- Extend the GblEnv with the (as yet un-zonked) -- bindings, rules, foreign decls - tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `andMonoBinds` all_binds, + tcg_env' = tcg_env { tcg_binds = tcg_binds tcg_env `unionBags` all_binds, tcg_rules = tcg_rules tcg_env ++ rules, tcg_fords = tcg_fords tcg_env ++ foe_decls ++ fi_decls } } ; return (tcg_env', lcl_env) @@ -812,7 +814,8 @@ getModuleExports mod vanillaProv :: ModuleName -> Provenance -- We're building a GlobalRdrEnv as if the user imported -- all the specified modules into the global interactive module -vanillaProv mod = Imported [ImportSpec mod mod False interactiveSrcLoc] False +vanillaProv mod = Imported [ImportSpec mod mod False + (srcLocSpan interactiveSrcLoc)] False \end{code} \begin{code} @@ -922,17 +925,17 @@ check_main ghci_mode tcg_env main_mod main_fn Nothing -> do { complain_no_main ; return tcg_env } ; Just main_name -> do - { let { rhs = HsApp (HsVar runIOName) (HsVar main_name) } + { let { rhs = nlHsApp (nlHsVar runIOName) (nlHsVar main_name) } -- :Main.main :: IO () = runIO main - ; (main_expr, ty) <- addSrcLoc (getSrcLoc main_name) $ + ; (main_expr, ty) <- addSrcSpan (srcLocSpan (getSrcLoc main_name)) $ tcInferRho rhs ; let { root_main_id = setIdLocalExported (mkLocalId rootMainName ty) ; - main_bind = VarMonoBind root_main_id main_expr } + main_bind = noLoc (VarBind root_main_id main_expr) } ; return (tcg_env { tcg_binds = tcg_binds tcg_env - `andMonoBinds` main_bind, + `snocBag` main_bind, tcg_dus = tcg_dus tcg_env `plusDU` usesOnly (unitFV main_name) }) diff --git a/ghc/compiler/typecheck/TcRnMonad.lhs b/ghc/compiler/typecheck/TcRnMonad.lhs index 8f8a6df396..52cb3a7425 100644 --- a/ghc/compiler/typecheck/TcRnMonad.lhs +++ b/ghc/compiler/typecheck/TcRnMonad.lhs @@ -10,7 +10,6 @@ module TcRnMonad( import TcRnTypes -- Re-export all import IOEnv -- Re-export all -import HsSyn ( MonoBinds(..) ) import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..), TyThing, Dependencies(..), TypeEnv, emptyTypeEnv, ExternalPackageState(..), HomePackageTable, @@ -28,8 +27,8 @@ import InstEnv ( InstEnv, emptyInstEnv, extendInstEnv ) import VarSet ( emptyVarSet ) import VarEnv ( TidyEnv, emptyTidyEnv ) import ErrUtils ( Message, Messages, emptyMessages, errorsFound, - addShortErrLocLine, addShortWarnLocLine, printErrorsAndWarnings ) -import SrcLoc ( SrcLoc, mkGeneralSrcLoc ) + mkErrMsg, mkWarnMsg, printErrorsAndWarnings ) +import SrcLoc ( mkGeneralSrcSpan, SrcSpan, Located(..) ) import NameEnv ( emptyNameEnv ) import NameSet ( emptyDUs, emptyNameSet ) import OccName ( emptyOccEnv ) @@ -88,7 +87,7 @@ initTc hsc_env mod do_this tcg_exports = [], tcg_imports = init_imports, tcg_dus = emptyDUs, - tcg_binds = EmptyMonoBinds, + tcg_binds = emptyBag, tcg_deprecs = NoDeprecs, tcg_insts = [], tcg_rules = [], @@ -97,7 +96,7 @@ initTc hsc_env mod do_this } ; lcl_env = TcLclEnv { tcl_errs = errs_var, - tcl_loc = mkGeneralSrcLoc FSLIT("Top level of module"), + tcl_loc = mkGeneralSrcSpan FSLIT("Top level of module"), tcl_ctxt = [], tcl_rdr = emptyLocalRdrEnv, tcl_th_ctxt = topStage, @@ -353,12 +352,30 @@ getDefaultTys = do { env <- getGblEnv; return (tcg_default env) } %************************************************************************ \begin{code} -getSrcLocM :: TcRn SrcLoc +getSrcSpanM :: TcRn SrcSpan -- Avoid clash with Name.getSrcLoc -getSrcLocM = do { env <- getLclEnv; return (tcl_loc env) } +getSrcSpanM = do { env <- getLclEnv; return (tcl_loc env) } -addSrcLoc :: SrcLoc -> TcRn a -> TcRn a -addSrcLoc loc = updLclEnv (\env -> env { tcl_loc = loc }) +addSrcSpan :: SrcSpan -> TcRn a -> TcRn a +addSrcSpan loc = updLclEnv (\env -> env { tcl_loc = loc }) + +addLocM :: (a -> TcM b) -> Located a -> TcM b +addLocM fn (L loc a) = addSrcSpan loc $ fn a + +wrapLocM :: (a -> TcM b) -> Located a -> TcM (Located b) +wrapLocM fn (L loc a) = addSrcSpan loc $ do b <- fn a; return (L loc b) + +wrapLocFstM :: (a -> TcM (b,c)) -> Located a -> TcM (Located b, c) +wrapLocFstM fn (L loc a) = + addSrcSpan loc $ do + (b,c) <- fn a + return (L loc b, c) + +wrapLocSndM :: (a -> TcM (b,c)) -> Located a -> TcM (b, Located c) +wrapLocSndM fn (L loc a) = + addSrcSpan loc $ do + (b,c) <- fn a + return (b, L loc c) \end{code} @@ -370,33 +387,44 @@ setErrsVar :: TcRef Messages -> TcRn a -> TcRn a setErrsVar v = updLclEnv (\ env -> env { tcl_errs = v }) addErr :: Message -> TcRn () -addErr msg = do { loc <- getSrcLocM ; addErrAt loc msg } +addErr msg = do { loc <- getSrcSpanM ; addErrAt loc msg } -addErrAt :: SrcLoc -> Message -> TcRn () +addLocErr :: Located e -> (e -> Message) -> TcRn () +addLocErr (L loc e) fn = addErrAt loc (fn e) + +addErrAt :: SrcSpan -> Message -> TcRn () addErrAt loc msg = do { errs_var <- getErrsVar ; rdr_env <- getGlobalRdrEnv ; - let { err = addShortErrLocLine loc (unQualInScope rdr_env) msg } ; + let { err = mkErrMsg loc (unQualInScope rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns, errs `snocBag` err) } -addErrs :: [(SrcLoc,Message)] -> TcRn () +addErrs :: [(SrcSpan,Message)] -> TcRn () addErrs msgs = mappM_ add msgs where add (loc,msg) = addErrAt loc msg addReport :: Message -> TcRn () -addReport msg +addReport msg = do loc <- getSrcSpanM; addReportAt loc msg + +addReportAt :: SrcSpan -> Message -> TcRn () +addReportAt loc msg = do { errs_var <- getErrsVar ; - loc <- getSrcLocM ; rdr_env <- getGlobalRdrEnv ; - let { warn = addShortWarnLocLine loc (unQualInScope rdr_env) msg } ; + let { warn = mkWarnMsg loc (unQualInScope rdr_env) msg } ; (warns, errs) <- readMutVar errs_var ; writeMutVar errs_var (warns `snocBag` warn, errs) } addWarn :: Message -> TcRn () addWarn msg = addReport (ptext SLIT("Warning:") <+> msg) +addWarnAt :: SrcSpan -> Message -> TcRn () +addWarnAt loc msg = addReportAt loc (ptext SLIT("Warning:") <+> msg) + +addLocWarn :: Located e -> (e -> Message) -> TcRn () +addLocWarn (L loc e) fn = addReportAt loc (fn e) + checkErr :: Bool -> Message -> TcRn () -- Add the error if the bool is False checkErr ok msg = checkM ok (addErr msg) @@ -554,14 +582,14 @@ updCtxt upd = updLclEnv (\ env@(TcLclEnv { tcl_ctxt = ctxt }) -> getInstLoc :: InstOrigin -> TcM InstLoc getInstLoc origin - = do { loc <- getSrcLocM ; env <- getLclEnv ; + = do { loc <- getSrcSpanM ; env <- getLclEnv ; return (InstLoc origin loc (tcl_ctxt env)) } addInstCtxt :: InstLoc -> TcM a -> TcM a --- Add the SrcLoc and context from the first Inst in the list +-- Add the SrcSpan and context from the first Inst in the list -- (they all have similar locations) addInstCtxt (InstLoc _ src_loc ctxt) thing_inside - = addSrcLoc src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) + = addSrcSpan src_loc (updCtxt (\ old_ctxt -> ctxt) thing_inside) \end{code} The addErrTc functions add an error message, but do not cause failure. @@ -578,7 +606,7 @@ addErrsTc err_msgs = mappM_ addErrTc err_msgs addErrTcM :: (TidyEnv, Message) -> TcM () addErrTcM (tidy_env, err_msg) = do { ctxt <- getErrCtxt ; - loc <- getSrcLocM ; + loc <- getSrcSpanM ; add_err_tcm tidy_env err_msg loc ctxt } \end{code} diff --git a/ghc/compiler/typecheck/TcRnTypes.lhs b/ghc/compiler/typecheck/TcRnTypes.lhs index f7896ee470..14eae9b891 100644 --- a/ghc/compiler/typecheck/TcRnTypes.lhs +++ b/ghc/compiler/typecheck/TcRnTypes.lhs @@ -30,7 +30,8 @@ module TcRnTypes( ArrowCtxt(..), topArrowCtxt, ProcLevel, topProcLevel, -- Insts - Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, instLocSrcLoc, + Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc, + instLocSrcLoc, instLocSrcSpan, LIE, emptyLIE, unitLIE, plusLIE, consLIE, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, @@ -40,8 +41,8 @@ module TcRnTypes( #include "HsVersions.h" -import HsSyn ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl ) -import RnHsSyn ( RenamedPat, RenamedArithSeqInfo ) +import HsSyn ( PendingSplice, HsOverLit, LHsBind, LRuleDecl, LForeignDecl, + Pat, ArithSeqInfo ) import HscTypes ( FixityEnv, HscEnv, TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo, @@ -61,7 +62,7 @@ import Class ( Class ) import Var ( Id, TyVar ) import VarEnv ( TidyEnv ) import Module -import SrcLoc ( SrcLoc ) +import SrcLoc ( SrcSpan, SrcLoc, srcSpanStart ) import VarSet ( IdSet ) import ErrUtils ( Messages, Message ) import UniqSupply ( UniqSupply ) @@ -179,11 +180,11 @@ data TcGblEnv -- The next fields accumulate the payload of the module -- The binds, rules and foreign-decl fiels are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - tcg_binds :: MonoBinds Id, -- Value bindings in this module + tcg_binds :: Bag (LHsBind Id), -- Value bindings in this module tcg_deprecs :: Deprecations, -- ...Deprecations tcg_insts :: [DFunId], -- ...Instances - tcg_rules :: [RuleDecl Id], -- ...Rules - tcg_fords :: [ForeignDecl Id] -- ...Foreign import & exports + tcg_rules :: [LRuleDecl Id], -- ...Rules + tcg_fords :: [LForeignDecl Id] -- ...Foreign import & exports } \end{code} @@ -253,7 +254,7 @@ Why? Because they are now Ids not TcIds. This final GlobalEnv is data TcLclEnv -- Changes as we move inside an expression -- Discarded after typecheck/rename; not passed on to desugarer = TcLclEnv { - tcl_loc :: SrcLoc, -- Source location + tcl_loc :: SrcSpan, -- Source span tcl_ctxt :: ErrCtxt, -- Error context tcl_errs :: TcRef Messages, -- Place to accumulate errors @@ -714,16 +715,19 @@ It appears in TcMonad because there are a couple of error-message-generation functions that deal with it. \begin{code} -data InstLoc = InstLoc InstOrigin SrcLoc ErrCtxt +data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt instLocSrcLoc :: InstLoc -> SrcLoc -instLocSrcLoc (InstLoc _ src_loc _) = src_loc +instLocSrcLoc (InstLoc _ src_span _) = srcSpanStart src_span + +instLocSrcSpan :: InstLoc -> SrcSpan +instLocSrcSpan (InstLoc _ src_span _) = src_span data InstOrigin = OccurrenceOf Name -- Occurrence of an overloaded identifier - | IPOcc (IPName Name) -- Occurrence of an implicit parameter - | IPBind (IPName Name) -- Binding site of an implicit parameter + | IPOccOrigin (IPName Name) -- Occurrence of an implicit parameter + | IPBindOrigin (IPName Name) -- Binding site of an implicit parameter | RecordUpdOrigin @@ -733,10 +737,10 @@ data InstOrigin | LiteralOrigin HsOverLit -- Occurrence of a literal - | PatOrigin RenamedPat + | PatOrigin (Pat Name) - | ArithSeqOrigin RenamedArithSeqInfo -- [x..], [x..y] etc - | PArrSeqOrigin RenamedArithSeqInfo -- [:x..y:] and [:x,y..z:] + | ArithSeqOrigin (ArithSeqInfo Name) -- [x..], [x..y] etc + | PArrSeqOrigin (ArithSeqInfo Name) -- [:x..y:] and [:x,y..z:] | SignatureOrigin -- A dict created from a type signature | Rank2Origin -- A dict created when typechecking the argument @@ -772,9 +776,9 @@ pprInstLoc (InstLoc orig locn ctxt) where pp_orig (OccurrenceOf name) = hsep [ptext SLIT("use of"), quotes (ppr name)] - pp_orig (IPOcc name) + pp_orig (IPOccOrigin name) = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)] - pp_orig (IPBind name) + pp_orig (IPBindOrigin name) = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)] pp_orig RecordUpdOrigin = ptext SLIT("a record update") diff --git a/ghc/compiler/typecheck/TcRules.lhs b/ghc/compiler/typecheck/TcRules.lhs index 27072a244c..4fc001714a 100644 --- a/ghc/compiler/typecheck/TcRules.lhs +++ b/ghc/compiler/typecheck/TcRules.lhs @@ -8,9 +8,7 @@ module TcRules ( tcRules ) where #include "HsVersions.h" -import HsSyn ( RuleDecl(..), RuleBndr(..), collectRuleBndrSigTys ) -import RnHsSyn ( RenamedRuleDecl ) -import TcHsSyn ( TypecheckedRuleDecl, mkHsLet ) +import HsSyn ( RuleDecl(..), LRuleDecl, RuleBndr(..), collectRuleBndrSigTys, mkHsLet ) import TcRnMonad import TcSimplify ( tcSimplifyToDicts, tcSimplifyInferCheck ) import TcMType ( newTyVarTy ) @@ -20,17 +18,18 @@ import TcExpr ( tcCheckRho ) import TcEnv ( tcExtendLocalValEnv ) import Inst ( instToId ) import Id ( idType, mkLocalId ) +import Name ( Name ) +import SrcLoc ( noLoc, unLoc ) import Outputable \end{code} \begin{code} -tcRules :: [RenamedRuleDecl] -> TcM [TypecheckedRuleDecl] -tcRules decls = mappM tcRule decls +tcRules :: [LRuleDecl Name] -> TcM [LRuleDecl TcId] +tcRules decls = mappM (wrapLocM tcRule) decls -tcRule :: RenamedRuleDecl -> TcM TypecheckedRuleDecl -tcRule (HsRule name act vars lhs rhs src_loc) - = addSrcLoc src_loc $ - addErrCtxt (ruleCtxt name) $ +tcRule :: RuleDecl Name -> TcM (RuleDecl TcId) +tcRule (HsRule name act vars lhs rhs) + = addErrCtxt (ruleCtxt name) $ traceTc (ptext SLIT("---- Rule ------") <+> ppr name) `thenM_` newTyVarTy openTypeKind `thenM` \ rule_ty -> @@ -88,15 +87,16 @@ tcRule (HsRule name act vars lhs rhs src_loc) lhs_dicts rhs_lie `thenM` \ (forall_tvs1, rhs_binds) -> returnM (HsRule name act - (map RuleBndr (forall_tvs1 ++ tpl_ids)) -- yuk + (map (RuleBndr . noLoc) (forall_tvs1 ++ tpl_ids)) -- yuk (mkHsLet lhs_binds lhs') - (mkHsLet rhs_binds rhs') - src_loc) + (mkHsLet rhs_binds rhs')) where new_id (RuleBndr var) = newTyVarTy openTypeKind `thenM` \ ty -> - returnM (mkLocalId var ty) - new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt var) rn_ty `thenM` \ ty -> - returnM (mkLocalId var ty) + returnM (mkLocalId (unLoc var) ty) + new_id (RuleBndrSig var rn_ty) = tcHsSigType (RuleSigCtxt nl_var) rn_ty `thenM` \ ty -> + returnM (mkLocalId nl_var ty) + where + nl_var = unLoc var ruleCtxt name = ptext SLIT("When checking the transformation rule") <+> doubleQuotes (ftext name) diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 02ed4d5724..291cf84e1c 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -21,10 +21,8 @@ module TcSimplify ( import {-# SOURCE #-} TcUnify( unifyTauTy ) import TcEnv -- temp -import HsSyn ( MonoBinds(..), HsExpr(..), andMonoBinds, andMonoBindList ) -import TcHsSyn ( TcExpr, TcId, - TcMonoBinds, TcDictBinds - ) +import HsSyn ( HsBind(..), LHsBinds, HsExpr(..), LHsExpr ) +import TcHsSyn ( TcId, TcDictBinds, mkHsApp, mkHsTyApp, mkHsDictApp ) import TcRnMonad import Inst ( lookupInst, LookupInstResult(..), @@ -62,10 +60,12 @@ import ErrUtils ( Message ) import VarSet import VarEnv ( TidyEnv ) import FiniteMap +import Bag import Outputable import ListSetOps ( equivClasses ) import Util ( zipEqual, isSingleton ) import List ( partition ) +import SrcLoc ( Located(..) ) import CmdLineOpts \end{code} @@ -591,7 +591,7 @@ inferLoop doc tau_tvs wanteds -- the final qtvs might be empty. See [NO TYVARS] below. inferLoop doc tau_tvs (irreds ++ frees) `thenM` \ (qtvs1, frees1, binds1, irreds1) -> - returnM (qtvs1, frees1, binds `AndMonoBinds` binds1, irreds1) + returnM (qtvs1, frees1, binds `unionBags` binds1, irreds1) \end{code} Example [LOOP] @@ -761,7 +761,7 @@ tcSimplCheck doc get_qtvs givens wanted_lie returnM (varSetElems qtvs', frees, binds, irreds) else check_loop givens' (irreds ++ frees) `thenM` \ (qtvs', frees1, binds1, irreds1) -> - returnM (qtvs', frees1, binds `AndMonoBinds` binds1, irreds1) + returnM (qtvs', frees1, binds `unionBags` binds1, irreds1) \end{code} @@ -844,7 +844,7 @@ restrict_loop doc qtvs wanteds returnM (varSetElems qtvs', binds) else restrict_loop doc qtvs' (irreds ++ frees) `thenM` \ (qtvs1, binds1) -> - returnM (qtvs1, binds `AndMonoBinds` binds1) + returnM (qtvs1, binds `unionBags` binds1) \end{code} @@ -977,7 +977,7 @@ tcSimplifyIPs given_ips wanteds returnM (frees, binds) else simpl_loop givens' (irreds ++ frees) `thenM` \ (frees1, binds1) -> - returnM (frees1, binds `AndMonoBinds` binds1) + returnM (frees1, binds `unionBags` binds1) \end{code} @@ -1007,13 +1007,13 @@ For each method @Inst@ in the @init_lie@ that mentions one of the @LIE@), as well as the @HsBinds@ generated. \begin{code} -bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM TcMonoBinds +bindInstsOfLocalFuns :: [Inst] -> [TcId] -> TcM (LHsBinds TcId) bindInstsOfLocalFuns wanteds local_ids | null overloaded_ids -- Common case = extendLIEs wanteds `thenM_` - returnM EmptyMonoBinds + returnM emptyBag | otherwise = simpleReduceLoop doc try_me wanteds `thenM` \ (frees, binds, irreds) -> @@ -1084,7 +1084,7 @@ data Avail -- ToDo: remove? | Rhs -- Used when there is a RHS - TcExpr -- The RHS + (LHsExpr TcId) -- The RHS [Inst] -- Insts free in the RHS; we need these too | Linear -- Splittable Insts only. @@ -1096,7 +1096,7 @@ data Avail | LinRhss -- Splittable Insts only; this is used only internally -- by extractResults, where a Linear -- is turned into an LinRhss - [TcExpr] -- A supply of suitable RHSs + [LHsExpr TcId] -- A supply of suitable RHSs pprAvails avails = vcat [sep [ppr inst, nest 2 (equals <+> pprAvail avail)] | (inst,avail) <- fmToList avails ] @@ -1124,11 +1124,11 @@ The loop startes extractResults :: Avails -> [Inst] -- Wanted -> TcM (TcDictBinds, -- Bindings - [Inst], -- Irreducible ones - [Inst]) -- Free ones + [Inst], -- Irreducible ones + [Inst]) -- Free ones extractResults avails wanteds - = go avails EmptyMonoBinds [] [] wanteds + = go avails emptyBag [] [] wanteds where go avails binds irreds frees [] = returnM (binds, irreds, frees) @@ -1145,7 +1145,7 @@ extractResults avails wanteds Just (Given id _) -> go avails new_binds irreds frees ws where new_binds | id == instToId w = binds - | otherwise = addBind binds w (HsVar id) + | otherwise = addBind binds w (L (instSpan w) (HsVar id)) -- The sought Id can be one of the givens, via a superclass chain -- and then we definitely don't want to generate an x=x binding! @@ -1157,7 +1157,7 @@ extractResults avails wanteds -> get_root irreds frees avail w `thenM` \ (irreds', frees', root_id) -> split n (instToId split_inst) root_id w `thenM` \ (binds', rhss) -> go (addToFM avails w (LinRhss rhss)) - (binds `AndMonoBinds` binds') + (binds `unionBags` binds') irreds' frees' (split_inst : w : ws) Just (LinRhss (rhs:rhss)) -- Consume one of the Rhss @@ -1199,7 +1199,7 @@ extractResults avails wanteds split :: Int -> TcId -> TcId -> Inst - -> TcM (TcDictBinds, [TcExpr]) + -> TcM (TcDictBinds, [LHsExpr TcId]) -- (split n split_id root_id wanted) returns -- * a list of 'n' expressions, all of which witness 'avail' -- * a bunch of auxiliary bindings to support these expressions @@ -1216,12 +1216,13 @@ split n split_id root_id wanted id = instToId wanted occ = getOccName id loc = getSrcLoc id + span = instSpan wanted - go 1 = returnM (EmptyMonoBinds, [HsVar root_id]) + go 1 = returnM (emptyBag, [L span $ HsVar root_id]) go n = go ((n+1) `div` 2) `thenM` \ (binds1, rhss) -> expand n rhss `thenM` \ (binds2, rhss') -> - returnM (binds1 `AndMonoBinds` binds2, rhss') + returnM (binds1 `unionBags` binds2, rhss') -- (expand n rhss) -- Given ((n+1)/2) rhss, make n rhss, using auxiliary bindings @@ -1234,7 +1235,7 @@ split n split_id root_id wanted returnM (binds', head rhss : rhss') where go rhss = mapAndUnzipM do_one rhss `thenM` \ (binds', rhss') -> - returnM (andMonoBindList binds', concat rhss') + returnM (listToBag binds', concat rhss') do_one rhs = newUnique `thenM` \ uniq -> tcLookupId fstName `thenM` \ fst_id -> @@ -1242,14 +1243,16 @@ split n split_id root_id wanted let x = mkUserLocal occ uniq pair_ty loc in - returnM (VarMonoBind x (mk_app split_id rhs), - [mk_fs_app fst_id ty x, mk_fs_app snd_id ty x]) + returnM (L span (VarBind x (mk_app span split_id rhs)), + [mk_fs_app span fst_id ty x, mk_fs_app span snd_id ty x]) -mk_fs_app id ty var = HsVar id `TyApp` [ty,ty] `HsApp` HsVar var +mk_fs_app span id ty var = L span (HsVar id) `mkHsTyApp` [ty,ty] `mkHsApp` (L span (HsVar var)) -mk_app id rhs = HsApp (HsVar id) rhs +mk_app span id rhs = L span (HsApp (L span (HsVar id)) rhs) -addBind binds inst rhs = binds `AndMonoBinds` VarMonoBind (instToId inst) rhs +addBind binds inst rhs = binds `unionBags` unitBag (L (instLocSrcSpan (instLoc inst)) + (VarBind (instToId inst) rhs)) +instSpan wanted = instLocSrcSpan (instLoc wanted) \end{code} @@ -1280,7 +1283,7 @@ simpleReduceLoop doc try_me wanteds returnM (frees, binds, irreds) else simpleReduceLoop doc try_me (irreds ++ frees) `thenM` \ (frees1, binds1, irreds1) -> - returnM (frees1, binds `AndMonoBinds` binds1, irreds1) + returnM (frees1, binds `unionBags` binds1, irreds1) \end{code} @@ -1507,7 +1510,7 @@ addFree :: Avails -> Inst -> TcM Avails -- addFree avails free = returnM (addToFM avails free IsFree) -addWanted :: Avails -> Inst -> TcExpr -> [Inst] -> TcM Avails +addWanted :: Avails -> Inst -> LHsExpr TcId -> [Inst] -> TcM Avails addWanted avails wanted rhs_expr wanteds = ASSERT2( not (wanted `elemFM` avails), ppr wanted $$ ppr avails ) addAvailAndSCs avails wanted avail @@ -1571,7 +1574,7 @@ addSCs is_loop avails dict Just other -> returnM avails' -- SCs already added Nothing -> addSCs is_loop avails' sc_dict where - sc_sel_rhs = DictApp (TyApp (HsVar sc_sel) tys) [instToId dict] + sc_sel_rhs = mkHsDictApp (mkHsTyApp (L (instSpan dict) (HsVar sc_sel)) tys) [instToId dict] avail = Rhs sc_sel_rhs [dict] avails' = addToFM avails sc_dict avail \end{code} @@ -1735,7 +1738,7 @@ tc_simplify_top is_interactive wanteds mappM (disambigGroup is_interactive) std_oks ) `thenM` \ binds_ambig -> - returnM (binds `andMonoBinds` andMonoBindList binds_ambig) + returnM (binds `unionBags` unionManyBags binds_ambig) ---------------------------------- d1 `cmp_by_tyvar` d2 = get_tv d1 `compare` get_tv d2 @@ -1836,7 +1839,7 @@ disambigGroup is_interactive dicts returnM binds bomb_out = addTopAmbigErrs dicts `thenM_` - returnM EmptyMonoBinds + returnM emptyBag get_default_tys = do { mb_defaults <- getDefaultTys @@ -2113,8 +2116,10 @@ addTopAmbigErrs dicts cmp (_,tvs1) (_,tvs2) = tvs1 `compare` tvs2 report :: [(Inst,[TcTyVar])] -> TcM () - report pairs@((_,tvs) : _) -- The pairs share a common set of ambiguous tyvars + report pairs@((inst,tvs) : _) -- The pairs share a common set of ambiguous tyvars = mkMonomorphismMsg tidy_env dicts `thenM` \ (tidy_env, mono_msg) -> + addSrcSpan (instLocSrcSpan (instLoc inst)) $ + -- the location of the first one will do for the err message addErrTcM (tidy_env, msg $$ mono_msg) where dicts = map fst pairs diff --git a/ghc/compiler/typecheck/TcSplice.hi-boot-6 b/ghc/compiler/typecheck/TcSplice.hi-boot-6 index 4c6483cffe..6c0a291b71 100644 --- a/ghc/compiler/typecheck/TcSplice.hi-boot-6 +++ b/ghc/compiler/typecheck/TcSplice.hi-boot-6 @@ -1,14 +1,13 @@ module TcSplice where tcSpliceExpr :: Name.Name - -> RnHsSyn.RenamedHsExpr + -> HsExpr.LHsExpr Name.Name -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr + -> TcRnTypes.TcM (HsExpr.HsExpr Var.Id) tcBracket :: HsExpr.HsBracket Name.Name -> TcUnify.Expected TcType.TcType - -> TcRnTypes.TcM TcHsSyn.TcExpr - -tcSpliceDecls :: RnHsSyn.RenamedHsExpr - -> TcRnTypes.TcM [RdrHsSyn.RdrNameHsDecl] + -> TcRnTypes.TcM (HsExpr.LHsExpr Var.Id) +tcSpliceDecls :: HsExpr.LHsExpr Name.Name + -> TcRnTypes.TcM [HsDecls.LHsDecl RdrName.RdrName] diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 86f8866fd5..001b913733 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -17,14 +17,12 @@ import qualified Language.Haskell.TH.THSyntax as TH -- THSyntax gives access to internal functions and data types import HscTypes ( HscEnv(..) ) -import HsSyn ( HsBracket(..), HsExpr(..) ) +import HsSyn ( HsBracket(..), HsExpr(..), LHsExpr, LHsDecl ) import Convert ( convertToHsExpr, convertToHsDecls ) -import RnExpr ( rnExpr ) +import RnExpr ( rnLExpr ) import RnEnv ( lookupFixityRn ) -import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl ) -import RnHsSyn ( RenamedHsExpr ) import TcExpr ( tcCheckRho, tcMonoExpr ) -import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) +import TcHsSyn ( mkHsLet, zonkTopLExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) import TcType ( TcType, openTypeKind, mkAppTy, tcSplitSigmaTy ) @@ -34,7 +32,8 @@ import TcHsType ( tcHsSigType ) import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName ) import OccName -import Var ( TyVar, idType ) +import Var ( Id, TyVar, idType ) +import RdrName ( RdrName ) import Module ( moduleUserString, mkModuleName ) import TcRnMonad import IfaceEnv ( lookupOrig ) @@ -48,16 +47,18 @@ import IdInfo ( GlobalIdDetails(..) ) import TysWiredIn ( mkListTy ) import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName ) import ErrUtils ( Message ) +import SrcLoc ( noLoc, unLoc ) import Outputable import Unique ( Unique, Uniquable(..), getKey ) import IOEnv ( IOEnv ) import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) import Module ( moduleUserString ) import Panic ( showException ) -import GHC.Base ( unsafeCoerce#, Int(..) ) -- Should have a better home in the module hierarchy -import Monad ( liftM ) import FastString ( LitString ) import FastTypes ( iBox ) + +import GHC.Base ( unsafeCoerce#, Int(..) ) -- Should have a better home in the module hierarchy +import Monad ( liftM ) \end{code} @@ -68,12 +69,12 @@ import FastTypes ( iBox ) %************************************************************************ \begin{code} -tcSpliceDecls :: RenamedHsExpr -> TcM [RdrNameHsDecl] +tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceExpr :: Name - -> RenamedHsExpr + -> LHsExpr Name -> Expected TcType - -> TcM TcExpr + -> TcM (HsExpr Id) #ifndef GHCI tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) @@ -88,7 +89,7 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %************************************************************************ \begin{code} -tcBracket :: HsBracket Name -> Expected TcType -> TcM TcExpr +tcBracket :: HsBracket Name -> Expected TcType -> TcM (LHsExpr Id) tcBracket brack res_ty = getStage `thenM` \ level -> case bracketOK level of { @@ -111,7 +112,7 @@ tcBracket brack res_ty -- Return the original expression, not the type-decorated one readMutVar pending_splices `thenM` \ pendings -> - returnM (HsBracketOut brack pendings) + returnM (noLoc (HsBracketOut brack pendings)) } tc_bracket :: HsBracket Name -> TcM TcType @@ -156,7 +157,8 @@ tcSpliceExpr name expr res_ty Just next_level -> case level of { - Comp -> tcTopSplice expr res_ty ; + Comp -> do { e <- tcTopSplice expr res_ty ; + returnM (unLoc e) }; Brack _ ps_var lie_var -> -- A splice inside brackets @@ -186,6 +188,7 @@ tcSpliceExpr name expr res_ty -- The recursive call to tcMonoExpr will simply expand the -- inner escape before dealing with the outer one +tcTopSplice :: LHsExpr Name -> Expected TcType -> TcM (LHsExpr Id) tcTopSplice expr res_ty = tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> @@ -199,7 +202,7 @@ tcTopSplice expr res_ty let -- simple_expr :: TH.Exp - expr2 :: RdrNameHsExpr + expr2 :: LHsExpr RdrName expr2 = convertToHsExpr simple_expr in traceTc (text "Got result" <+> ppr expr2) `thenM_` @@ -209,12 +212,12 @@ tcTopSplice expr res_ty -- Rename it, but bale out if there are errors -- otherwise the type checker just gives more spurious errors - checkNoErrs (rnExpr expr2) `thenM` \ (exp3, fvs) -> + checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) -> tcMonoExpr exp3 res_ty -tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr +tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id) -- Type check an expression that is the body of a top-level splice -- (the caller will compile and run it) tcTopSpliceExpr expr meta_ty @@ -230,7 +233,7 @@ tcTopSpliceExpr expr meta_ty tcSimplifyTop lie `thenM` \ const_binds -> -- And zonk it - zonkTopExpr (mkHsLet const_binds expr') + zonkTopLExpr (mkHsLet const_binds expr') \end{code} @@ -276,15 +279,15 @@ tcSpliceDecls expr %************************************************************************ \begin{code} -runMetaE :: TypecheckedHsExpr -- Of type (Q Exp) +runMetaE :: LHsExpr Id -- Of type (Q Exp) -> TcM TH.Exp -- Of type Exp runMetaE e = runMeta e -runMetaD :: TypecheckedHsExpr -- Of type Q [Dec] +runMetaD :: LHsExpr Id -- Of type Q [Dec] -> TcM [TH.Dec] -- Of type [Dec] runMetaD e = runMeta e -runMeta :: TypecheckedHsExpr -- Of type X +runMeta :: LHsExpr Id -- Of type X -> TcM t -- Of type t runMeta expr = do { hsc_env <- getTopEnv @@ -336,9 +339,9 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where %************************************************************************ \begin{code} -showSplice :: String -> TypecheckedHsExpr -> SDoc -> TcM () +showSplice :: String -> LHsExpr Id -> SDoc -> TcM () showSplice what before after - = getSrcLocM `thenM` \ loc -> + = getSrcSpanM `thenM` \ loc -> traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, nest 2 (sep [nest 2 (ppr before), text "======>", @@ -516,4 +519,4 @@ noTH :: LitString -> SDoc -> TcM a noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+> ptext SLIT("in Template Haskell:"), nest 2 d]) -\end{code}
\ No newline at end of file +\end{code} diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index f974252efa..0d29681e92 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -12,15 +12,16 @@ module TcTyClsDecls ( import HsSyn ( TyClDecl(..), HsConDetails(..), HsTyVarBndr(..), ConDecl(..), Sig(..), BangType(..), HsBang(..), - tyClDeclTyVars, getBangType, getBangStrictness + tyClDeclTyVars, getBangType, getBangStrictness, + LTyClDecl, tcdName, LHsTyVarBndr ) -import RnHsSyn ( RenamedTyClDecl, RenamedConDecl ) import BasicTypes ( RecFlag(..), NewOrData(..), StrictnessMark(..) ) import HscTypes ( implicitTyThings ) import BuildTyCl ( buildClass, buildAlgTyCon, buildSynTyCon, buildDataCon ) import TcRnMonad import TcEnv ( TcTyThing(..), TyThing(..), - tcLookup, tcLookupGlobal, tcExtendGlobalEnv, + tcLookupLocated, tcLookupLocatedGlobal, + tcExtendGlobalEnv, tcExtendRecEnv, tcLookupTyVar ) import TcTyDecls ( calcTyConArgVrcs, calcRecFlags, calcCycleErrs ) import TcClassDcl ( tcClassSigs, tcAddDeclCtxt ) @@ -45,6 +46,7 @@ import VarSet ( elemVarSet ) import Name ( Name, getSrcLoc ) import Outputable import Util ( zipLazy, isSingleton, notNull ) +import SrcLoc ( srcLocSpan, Located(..), unLoc ) import ListSetOps ( equivClasses ) import CmdLineOpts ( DynFlag( Opt_GlasgowExts, Opt_Generics, Opt_UnboxStrictFields ) ) \end{code} @@ -100,7 +102,7 @@ The knot-tying parameters: @rec_details_list@ is an alist mapping @Name@s to @TyThing@s. @rec_vrcs@ is a finite map from @Name@s to @ArgVrcs@s. \begin{code} -tcTyAndClassDecls :: [RenamedTyClDecl] +tcTyAndClassDecls :: [LTyClDecl Name] -> TcM TcGblEnv -- Input env extended by types and classes -- and their implicit Ids,DataCons tcTyAndClassDecls decls @@ -108,11 +110,12 @@ tcTyAndClassDecls decls -- See notes with checkCycleErrs checkCycleErrs decls + ; let { udecls = map unLoc decls } ; tyclss <- fixM (\ rec_tyclss -> - do { lcl_things <- mappM getInitialKind decls + do { lcl_things <- mappM getInitialKind udecls -- Extend the local env with kinds, and -- the global env with the knot-tied results - ; let { gbl_things = mkGlobalThings decls rec_tyclss } + ; let { gbl_things = mkGlobalThings udecls rec_tyclss } ; tcExtendRecEnv gbl_things lcl_things $ do -- The local type environment is populated with @@ -151,7 +154,7 @@ tcTyAndClassDecls decls ; tcExtendGlobalEnv implicit_things getGblEnv }} -mkGlobalThings :: [RenamedTyClDecl] -- The decls +mkGlobalThings :: [TyClDecl Name] -- The decls -> [TyThing] -- Knot-tied, in 1-1 correspondence with the decls -> [(Name,TyThing)] -- Driven by the Decls, and treating the TyThings lazily @@ -159,8 +162,10 @@ mkGlobalThings :: [RenamedTyClDecl] -- The decls mkGlobalThings decls things = map mk_thing (decls `zipLazy` things) where - mk_thing (ClassDecl {tcdName = name}, ~(AClass cl)) = (name, AClass cl) - mk_thing (decl, ~(ATyCon tc)) = (tcdName decl, ATyCon tc) + mk_thing (ClassDecl {tcdLName = L _ name}, ~(AClass cl)) + = (name, AClass cl) + mk_thing (decl, ~(ATyCon tc)) + = (tcdName decl, ATyCon tc) \end{code} @@ -190,48 +195,50 @@ getInitialKind :: TyClDecl Name -> TcM (Name, TcTyThing) -- Note the lazy pattern match on the ATyCon etc -- Exactly the same reason as the zipLay above -getInitialKind (TyData {tcdName = name}) +getInitialKind (TyData {tcdLName = L _ name}) = newKindVar `thenM` \ kind -> returnM (name, ARecTyCon kind) -getInitialKind (TySynonym {tcdName = name}) +getInitialKind (TySynonym {tcdLName = L _ name}) = newKindVar `thenM` \ kind -> returnM (name, ARecTyCon kind) -getInitialKind (ClassDecl {tcdName = name}) +getInitialKind (ClassDecl {tcdLName = L _ name}) = newKindVar `thenM` \ kind -> returnM (name, ARecClass kind) ------------------------------------------------------------------------ -kcTyClDecl :: RenamedTyClDecl -> TcM RenamedTyClDecl +kcTyClDecl :: LTyClDecl Name -> TcM (LTyClDecl Name) -kcTyClDecl decl@(TySynonym {tcdSynRhs = rhs}) +kcTyClDecl decl@(L loc d@(TySynonym {tcdSynRhs = rhs})) = do { res_kind <- newKindVar ; kcTyClDeclBody decl res_kind $ \ tvs' -> do { rhs' <- kcCheckHsType rhs res_kind - ; return (decl {tcdTyVars = tvs', tcdSynRhs = rhs'}) } } + ; return (L loc d{tcdTyVars = tvs', tcdSynRhs = rhs'}) } } -kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) +kcTyClDecl decl@(L loc d@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons})) = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> do { ctxt' <- kcHsContext ctxt - ; cons' <- mappM kc_con_decl cons - ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) } + ; cons' <- mappM (wrapLocM kc_con_decl) cons + ; return (L loc d{tcdTyVars = tvs', tcdCtxt = ctxt', tcdCons = cons'}) } where - kc_con_decl (ConDecl name ex_tvs ex_ctxt details loc) + kc_con_decl (ConDecl name ex_tvs ex_ctxt details) = kcHsTyVars ex_tvs $ \ ex_tvs' -> do { ex_ctxt' <- kcHsContext ex_ctxt ; details' <- kc_con_details details - ; return (ConDecl name ex_tvs' ex_ctxt' details' loc)} + ; return (ConDecl name ex_tvs' ex_ctxt' details')} kc_con_details (PrefixCon btys) - = do { btys' <- mappM kc_arg_ty btys ; return (PrefixCon btys') } + = do { btys' <- mappM kc_larg_ty btys ; return (PrefixCon btys') } kc_con_details (InfixCon bty1 bty2) - = do { bty1' <- kc_arg_ty bty1; bty2' <- kc_arg_ty bty2; return (InfixCon bty1' bty2') } + = do { bty1' <- kc_larg_ty bty1; bty2' <- kc_larg_ty bty2; return (InfixCon bty1' bty2') } kc_con_details (RecCon fields) = do { fields' <- mappM kc_field fields; return (RecCon fields') } - kc_field (fld, bty) = do { bty' <- kc_arg_ty bty ; return (fld, bty') } + kc_field (fld, bty) = do { bty' <- kc_larg_ty bty ; return (fld, bty') } + + kc_larg_ty = wrapLocM kc_arg_ty kc_arg_ty (BangType str ty) = do { ty' <- kc_arg_ty_body ty; return (BangType str ty') } kc_arg_ty_body = case new_or_data of @@ -240,29 +247,29 @@ kcTyClDecl decl@(TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdCons = cons}) -- Can't allow an unlifted type for newtypes, because we're effectively -- going to remove the constructor while coercing it to a lifted type. -kcTyClDecl decl@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs}) +kcTyClDecl decl@(L loc d@(ClassDecl {tcdCtxt = ctxt, tcdSigs = sigs})) = kcTyClDeclBody decl liftedTypeKind $ \ tvs' -> do { ctxt' <- kcHsContext ctxt - ; sigs' <- mappM kc_sig sigs - ; return (decl {tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } + ; sigs' <- mappM (wrapLocM kc_sig) sigs + ; return (L loc d{tcdTyVars = tvs', tcdCtxt = ctxt', tcdSigs = sigs'}) } where - kc_sig (Sig nm op_ty loc) = do { op_ty' <- kcHsLiftedSigType op_ty - ; return (Sig nm op_ty' loc) } + kc_sig (Sig nm op_ty) = do { op_ty' <- kcHsLiftedSigType op_ty + ; return (Sig nm op_ty') } kc_sig other_sig = return other_sig -kcTyClDecl decl@(ForeignType {}) +kcTyClDecl decl@(L _ (ForeignType {})) = return decl -kcTyClDeclBody :: RenamedTyClDecl -> TcKind - -> ([HsTyVarBndr Name] -> TcM a) +kcTyClDeclBody :: LTyClDecl Name -> TcKind + -> ([LHsTyVarBndr Name] -> TcM a) -> TcM a -- Extend the env with bindings for the tyvars, taken from -- the kind of the tycon/class. Give it to the thing inside, and -- check the result kind matches kcTyClDeclBody decl res_kind thing_inside = tcAddDeclCtxt decl $ - kcHsTyVars (tyClDeclTyVars decl) $ \ kinded_tvs -> - do { tc_ty_thing <- tcLookup (tcdName decl) + kcHsTyVars (tyClDeclTyVars (unLoc decl)) $ \ kinded_tvs -> + do { tc_ty_thing <- tcLookupLocated (tcdLName (unLoc decl)) ; let { tc_kind = case tc_ty_thing of ARecClass k -> k ARecTyCon k -> k @@ -271,7 +278,7 @@ kcTyClDeclBody decl res_kind thing_inside res_kind kinded_tvs) ; thing_inside kinded_tvs } -kindedTyVarKind (KindedTyVar _ k) = k +kindedTyVarKind (L _ (KindedTyVar _ k)) = k \end{code} @@ -283,13 +290,13 @@ kindedTyVarKind (KindedTyVar _ k) = k \begin{code} tcTyClDecl :: (Name -> ArgVrcs) -> (Name -> RecFlag) - -> RenamedTyClDecl -> TcM TyThing + -> LTyClDecl Name -> TcM TyThing tcTyClDecl calc_vrcs calc_isrec decl - = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec decl) + = tcAddDeclCtxt decl (tcTyClDecl1 calc_vrcs calc_isrec (unLoc decl)) tcTyClDecl1 calc_vrcs calc_isrec - (TySynonym {tcdName = tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) + (TySynonym {tcdLName = L _ tc_name, tcdTyVars = tvs, tcdSynRhs = rhs_ty}) = tcTyVarBndrs tvs $ \ tvs' -> do { rhs_ty' <- tcHsKindedType rhs_ty ; return (ATyCon (buildSynTyCon tc_name tvs' rhs_ty' arg_vrcs)) } @@ -298,12 +305,12 @@ tcTyClDecl1 calc_vrcs calc_isrec tcTyClDecl1 calc_vrcs calc_isrec (TyData {tcdND = new_or_data, tcdCtxt = ctxt, tcdTyVars = tvs, - tcdName = tc_name, tcdCons = cons}) + tcdLName = L _ tc_name, tcdCons = cons}) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt ; want_generic <- doptM Opt_Generics ; tycon <- fixM (\ tycon -> do - { cons' <- mappM (tcConDecl new_or_data tycon tvs' ctxt') cons + { cons' <- mappM (addLocM (tcConDecl new_or_data tycon tvs' ctxt')) cons ; buildAlgTyCon new_or_data tc_name tvs' ctxt' (DataCons cons') arg_vrcs is_rec (want_generic && canDoGenerics cons') @@ -315,12 +322,12 @@ tcTyClDecl1 calc_vrcs calc_isrec is_rec = calc_isrec tc_name tcTyClDecl1 calc_vrcs calc_isrec - (ClassDecl {tcdName = class_name, tcdTyVars = tvs, + (ClassDecl {tcdLName = L _ class_name, tcdTyVars = tvs, tcdCtxt = ctxt, tcdMeths = meths, tcdFDs = fundeps, tcdSigs = sigs} ) = tcTyVarBndrs tvs $ \ tvs' -> do { ctxt' <- tcHsKindedContext ctxt - ; fds' <- mappM tc_fundep fundeps + ; fds' <- mappM (addLocM tc_fundep) fundeps ; sig_stuff <- tcClassSigs class_name sigs meths ; clas <- fixM (\ clas -> let -- This little knot is just so we can get @@ -340,25 +347,25 @@ tcTyClDecl1 calc_vrcs calc_isrec tcTyClDecl1 calc_vrcs calc_isrec - (ForeignType {tcdName = tc_name, tcdExtName = tc_ext_name}) + (ForeignType {tcdLName = L _ tc_name, tcdExtName = tc_ext_name}) = returnM (ATyCon (mkForeignTyCon tc_name tc_ext_name liftedTypeKind 0 [])) ----------------------------------- tcConDecl :: NewOrData -> TyCon -> [TyVar] -> ThetaType - -> RenamedConDecl -> TcM DataCon + -> ConDecl Name -> TcM DataCon tcConDecl new_or_data tycon tyvars ctxt - (ConDecl name ex_tvs ex_ctxt details src_loc) - = addSrcLoc src_loc $ - tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do + (ConDecl name ex_tvs ex_ctxt details) + = tcTyVarBndrs ex_tvs $ \ ex_tvs' -> do { ex_ctxt' <- tcHsKindedContext ex_ctxt ; unbox_strict <- doptM Opt_UnboxStrictFields ; let tc_datacon field_lbls btys - = do { arg_tys <- mappM (tcHsKindedType . getBangType) btys - ; buildDataCon name - (argStrictness unbox_strict tycon btys arg_tys) - field_lbls + = do { let { ubtys = map unLoc btys } + ; arg_tys <- mappM (tcHsKindedType . getBangType) ubtys + ; buildDataCon (unLoc name) + (argStrictness unbox_strict tycon ubtys arg_tys) + (map unLoc field_lbls) tyvars ctxt ex_tvs' ex_ctxt' arg_tys tycon } ; case details of @@ -404,7 +411,7 @@ Validity checking is done once the mutually-recursive knot has been tied, so we can look at things freely. \begin{code} -checkCycleErrs :: [TyClDecl Name] -> TcM () +checkCycleErrs :: [LTyClDecl Name] -> TcM () checkCycleErrs tyclss | null syn_cycles && null cls_cycles = return () @@ -416,12 +423,12 @@ checkCycleErrs tyclss where (syn_cycles, cls_cycles) = calcCycleErrs tyclss -checkValidTyCl :: RenamedTyClDecl -> TcM () +checkValidTyCl :: LTyClDecl Name -> TcM () -- We do the validity check over declarations, rather than TyThings -- only so that we can add a nice context with tcAddDeclCtxt checkValidTyCl decl = tcAddDeclCtxt decl $ - do { thing <- tcLookupGlobal (tcdName decl) + do { thing <- tcLookupLocatedGlobal (tcdLName (unLoc decl)) ; traceTc (text "Validity of" <+> ppr thing) ; case thing of ATyCon tc -> checkValidTyCon tc @@ -575,12 +582,12 @@ badGenericMethodType op op_ty ptext SLIT("You can only use type variables, arrows, and tuples")]) recSynErr tcs - = addSrcLoc (getSrcLoc (head tcs)) $ + = addSrcSpan (srcLocSpan (getSrcLoc (head tcs))) $ addErr (sep [ptext SLIT("Cycle in type synonym declarations:"), nest 2 (vcat (map ppr_thing tcs))]) recClsErr clss - = addSrcLoc (getSrcLoc (head clss)) $ + = addSrcSpan (srcLocSpan (getSrcLoc (head clss))) $ addErr (sep [ptext SLIT("Cycle in class declarations (via superclasses):"), nest 2 (vcat (map ppr_thing clss))]) diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 6e880cbcc9..824e95c54f 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -20,7 +20,7 @@ module TcTyDecls( #include "HsVersions.h" import TypeRep ( Type(..), TyNote(..), PredType(..) ) -- friend -import HsSyn ( TyClDecl(..), HsPred(..) ) +import HsSyn ( TyClDecl(..), HsPred(..), LTyClDecl ) import RnHsSyn ( extractHsTyNames ) import Type ( predTypeRep ) import BuildTyCl ( newTyConRhs ) @@ -37,6 +37,7 @@ import NameEnv import NameSet import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR ) import BasicTypes ( RecFlag(..) ) +import SrcLoc ( Located(..) ) import Outputable \end{code} @@ -106,18 +107,25 @@ synTyConsOfType ty ---------------------------------------- END NOTE ] \begin{code} -calcCycleErrs :: [TyClDecl Name] -> ([[Name]], -- Recursive type synonym groups +calcCycleErrs :: [LTyClDecl Name] -> ([[Name]], -- Recursive type synonym groups [[Name]]) -- Ditto classes calcCycleErrs decls = (findCyclics syn_edges, findCyclics cls_edges) where --------------- Type synonyms ---------------------- - syn_edges = [ (name, mk_syn_edges rhs) | TySynonym { tcdName = name, tcdSynRhs = rhs } <- decls ] - mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), not (isTyVarName tc) ] + syn_edges = [ (name, mk_syn_edges rhs) | + L _ (TySynonym { tcdLName = L _ name, + tcdSynRhs = rhs }) <- decls ] + + mk_syn_edges rhs = [ tc | tc <- nameSetToList (extractHsTyNames rhs), + not (isTyVarName tc) ] --------------- Classes ---------------------- - cls_edges = [ (name, mk_cls_edges ctxt) | ClassDecl { tcdName = name, tcdCtxt = ctxt } <- decls ] - mk_cls_edges ctxt = [ cls | HsClassP cls _ <- ctxt ] + cls_edges = [ (name, mk_cls_edges ctxt) | + L _ (ClassDecl { tcdLName = L _ name, + tcdCtxt = L _ ctxt }) <- decls ] + + mk_cls_edges ctxt = [ cls | L _ (HsClassP cls _) <- ctxt ] \end{code} diff --git a/ghc/compiler/typecheck/TcUnify.lhs b/ghc/compiler/typecheck/TcUnify.lhs index 85d89d454b..123491042c 100644 --- a/ghc/compiler/typecheck/TcUnify.lhs +++ b/ghc/compiler/typecheck/TcUnify.lhs @@ -28,7 +28,7 @@ module TcUnify ( import HsSyn ( HsExpr(..) ) -import TcHsSyn ( mkHsLet, +import TcHsSyn ( mkHsLet, mkHsDictLam, ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) ) import TypeRep ( Type(..), PredType(..), TyNote(..), openKindCon, isSuperKind ) @@ -58,6 +58,7 @@ import VarSet ( emptyVarSet, unitVarSet, unionVarSet, elemVarSet, varSetElems ) import VarEnv import Name ( isSystemName ) import ErrUtils ( Message ) +import SrcLoc ( noLoc ) import BasicTypes ( Boxity, Arity, isBoxed ) import Util ( equalLength, lengthExceeds, notNull ) import Outputable @@ -441,7 +442,7 @@ tcSub_fun exp_arg exp_res act_arg act_res | otherwise = mkCoercion co_fn co_fn e = DictLam [arg_id] - (co_fn_res <$> (HsApp e (co_fn_arg <$> (HsVar arg_id)))) + (noLoc (co_fn_res <$> (HsApp (noLoc e) (noLoc (co_fn_arg <$> HsVar arg_id))))) -- Slight hack; using a "DictLam" to get an ordinary simple lambda -- HsVar arg_id :: HsExpr exp_arg -- co_fn_arg $it :: HsExpr act_arg @@ -521,7 +522,7 @@ tcGen expected_ty extra_tvs thing_inside -- We expect expected_ty to be a forall -- It's a bit out of place here, but using AbsBind involves inventing -- a couple of new names which seems worse. dict_ids = map instToId dicts - co_fn e = TyLam zonked_tvs (DictLam dict_ids (mkHsLet inst_binds e)) + co_fn e = TyLam zonked_tvs (mkHsDictLam dict_ids (mkHsLet inst_binds (noLoc e))) in returnM (mkCoercion co_fn, result) where diff --git a/ghc/compiler/types/Generics.lhs b/ghc/compiler/types/Generics.lhs index 3219c99a47..dc027164b2 100644 --- a/ghc/compiler/types/Generics.lhs +++ b/ghc/compiler/types/Generics.lhs @@ -9,12 +9,13 @@ import HsSyn import Type ( Type, isUnLiftedType, tyVarsOfType, tyVarsOfTypes, isTyVarTy, getTyVar_maybe, funTyCon ) +import TcHsSyn ( mkSimpleHsAlt ) import TcType ( tcSplitTyConApp_maybe, tcSplitSigmaTy, tcSplitSigmaTy, isTauTy ) import DataCon ( DataCon, dataConOrigArgTys, isExistentialDataCon, dataConSourceArity ) import TyCon ( TyCon, tyConName, tyConDataCons, - tyConHasGenerics, isBoxedTupleTyCon + isBoxedTupleTyCon ) import Name ( nameModuleName, nameOccName, getSrcLoc ) import OccName ( mkGenOcc1, mkGenOcc2 ) @@ -25,8 +26,9 @@ import VarSet ( varSetElems ) import Id ( Id, idType ) import PrelNames -import SrcLoc ( generatedSrcLoc ) +import SrcLoc ( srcLocSpan, noLoc, Located(..) ) import Util ( takeList ) +import Bag import Outputable import FastString @@ -246,18 +248,18 @@ canDoGenerics data_cons \begin{code} type US = Int -- Local unique supply, just a plain Int -type FromAlt = (Pat RdrName, HsExpr RdrName) +type FromAlt = (LPat RdrName, LHsExpr RdrName) -mkTyConGenericBinds :: TyCon -> MonoBinds RdrName +mkTyConGenericBinds :: TyCon -> LHsBinds RdrName mkTyConGenericBinds tycon - = FunMonoBind from_RDR False {- Not infix -} - [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts] - loc - `AndMonoBinds` - FunMonoBind to_RDR False - [mkSimpleHsAlt to_pat to_body] loc + = unitBag (L loc (FunBind (L loc from_RDR) False {- Not infix -} + [mkSimpleHsAlt pat rhs | (pat,rhs) <- from_alts])) + + `unionBags` + unitBag (L loc (FunBind (L loc to_RDR) False + [mkSimpleHsAlt to_pat to_body])) where - loc = getSrcLoc tycon + loc = srcLocSpan (getSrcLoc tycon) datacons = tyConDataCons tycon (from_RDR, to_RDR) = mkGenericNames tycon @@ -272,8 +274,8 @@ mkTyConGenericBinds tycon mk_sum_stuff :: US -- Base for generating unique names -> [DataCon] -- The data constructors - -> ([FromAlt], -- Alternatives for the T->Trep "from" function - InPat RdrName, HsExpr RdrName) -- Arg and body of the Trep->T "to" function + -> ([FromAlt], -- Alternatives for the T->Trep "from" function + InPat RdrName, LHsExpr RdrName) -- Arg and body of the Trep->T "to" function -- For example, given -- data T = C | D Int Int Int @@ -294,18 +296,17 @@ mk_sum_stuff us [datacon] us' = us + n_args datacon_rdr = getRdrName datacon - app_exp = mkHsVarApps datacon_rdr datacon_vars - from_alt = (mkConPat datacon_rdr datacon_vars, from_alt_rhs) + app_exp = nlHsVarApps datacon_rdr datacon_vars + from_alt = (nlConVarPat datacon_rdr datacon_vars, from_alt_rhs) (_, from_alt_rhs, to_pat, to_body_fn) = mk_prod_stuff us' datacon_vars mk_sum_stuff us datacons = (wrap inlDataCon_RDR l_from_alts ++ wrap inrDataCon_RDR r_from_alts, - VarPat to_arg, - HsCase (HsVar to_arg) - [mkSimpleHsAlt (ConPatIn inlDataCon_RDR (PrefixCon [l_to_pat])) l_to_body, - mkSimpleHsAlt (ConPatIn inrDataCon_RDR (PrefixCon [r_to_pat])) r_to_body] - generatedSrcLoc) + nlVarPat to_arg, + noLoc (HsCase (nlHsVar to_arg) + [mkSimpleHsAlt (nlConPat inlDataCon_RDR [l_to_pat]) l_to_body, + mkSimpleHsAlt (nlConPat inrDataCon_RDR [r_to_pat]) r_to_body])) where (l_datacons, r_datacons) = splitInHalf datacons (l_from_alts, l_to_pat, l_to_body) = mk_sum_stuff us' l_datacons @@ -316,7 +317,7 @@ mk_sum_stuff us datacons wrap :: RdrName -> [FromAlt] -> [FromAlt] -- Wrap an application of the Inl or Inr constructor round each alternative - wrap dc alts = [(pat, HsApp (HsVar dc) rhs) | (pat,rhs) <- alts] + wrap dc alts = [(pat, noLoc (HsApp (nlHsVar dc) rhs)) | (pat,rhs) <- alts] ---------------------------------------------------- @@ -327,9 +328,9 @@ mk_prod_stuff :: US -- Base for unique names -- They are bound enclosing from_rhs -- Please bind these in the to_body_fn -> (US, -- Depleted unique-name supply - HsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids + LHsExpr RdrName, -- from-rhs: puts together the representation from the arg_ids InPat RdrName, -- to_pat: - HsExpr RdrName -> HsExpr RdrName) -- to_body_fn: takes apart the representation + LHsExpr RdrName -> LHsExpr RdrName) -- to_body_fn: takes apart the representation -- For example: -- mk_prod_stuff abc [a,b,c] = ( a :*: (b :*: c), @@ -344,9 +345,9 @@ mk_prod_stuff :: US -- Base for unique names mk_prod_stuff us [] -- Unit case = (us+1, - HsVar genUnitDataCon_RDR, - SigPatIn (VarPat (mkGenericLocal us)) - (HsTyVar (getRdrName genUnitTyConName)), + nlHsVar genUnitDataCon_RDR, + noLoc (SigPatIn (nlVarPat (mkGenericLocal us)) + (noLoc (HsTyVar (getRdrName genUnitTyConName)))), -- Give a signature to the pattern so we get -- data S a = Nil | S a -- toS = \x -> case x of { Inl (g :: Unit) -> Nil @@ -357,21 +358,20 @@ mk_prod_stuff us [] -- Unit case \x -> x) mk_prod_stuff us [arg_var] -- Singleton case - = (us, HsVar arg_var, VarPat arg_var, \x -> x) + = (us, nlHsVar arg_var, nlVarPat arg_var, \x -> x) mk_prod_stuff us arg_vars -- Two or more = (us'', - HsVar crossDataCon_RDR `HsApp` l_alt_rhs `HsApp` r_alt_rhs, - VarPat to_arg, - \x -> HsCase (HsVar to_arg) - [mkSimpleHsAlt (ConPatIn crossDataCon_RDR (PrefixCon [l_to_pat, r_to_pat])) - (l_to_body_fn (r_to_body_fn x))] generatedSrcLoc) + nlHsApps crossDataCon_RDR [l_alt_rhs, r_alt_rhs], + nlVarPat to_arg, + \x -> noLoc (HsCase (nlHsVar to_arg) + [mkSimpleHsAlt pat (l_to_body_fn (r_to_body_fn x))])) where to_arg = mkGenericLocal us (l_arg_vars, r_arg_vars) = splitInHalf arg_vars (us', l_alt_rhs, l_to_pat, l_to_body_fn) = mk_prod_stuff (us+1) l_arg_vars (us'', r_alt_rhs, r_to_pat, r_to_body_fn) = mk_prod_stuff us' r_arg_vars - + pat = nlConPat crossDataCon_RDR [l_to_pat, r_to_pat] splitInHalf :: [a] -> ([a],[a]) splitInHalf list = (left, right) @@ -448,9 +448,9 @@ By the time the type checker has done its stuff we'll get op = \b. \dict::Ord b. toOp b (op Trep b dict) \begin{code} -mkGenericRhs :: Id -> TyVar -> TyCon -> HsExpr RdrName +mkGenericRhs :: Id -> TyVar -> TyCon -> LHsExpr RdrName mkGenericRhs sel_id tyvar tycon - = HsApp (toEP bimap) (HsVar (getRdrName sel_id)) + = mkHsApp (toEP bimap) (nlHsVar (getRdrName sel_id)) where -- Initialising the "Environment" with the from/to functions -- on the datatype (actually tycon) in question @@ -466,18 +466,18 @@ mkGenericRhs sel_id tyvar tycon -- Now we probably have a tycon in front -- of us, quite probably a FunTyCon. - ep = EP (HsVar from_RDR) (HsVar to_RDR) + ep = EP (nlHsVar from_RDR) (nlHsVar to_RDR) bimap = generate_bimap (tyvar, ep, local_tvs) final_ty type EPEnv = (TyVar, -- The class type variable - EP (HsExpr RdrName), -- The EP it maps to + EP (LHsExpr RdrName), -- The EP it maps to [TyVar] -- Other in-scope tyvars; they have an identity EP ) ------------------- generate_bimap :: EPEnv -> Type - -> EP (HsExpr RdrName) + -> EP (LHsExpr RdrName) -- Top level case - splitting the TyCon. generate_bimap env@(tv,ep,local_tvs) ty = case getTyVar_maybe ty of @@ -487,7 +487,7 @@ generate_bimap env@(tv,ep,local_tvs) ty Nothing -> bimapApp env (tcSplitTyConApp_maybe ty) ------------------- -bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (HsExpr RdrName) +bimapApp :: EPEnv -> Maybe (TyCon, [Type]) -> EP (LHsExpr RdrName) bimapApp env Nothing = panic "TcClassDecl: Type Application!" bimapApp env (Just (tycon, ty_args)) | tycon == funTyCon = bimapArrow arg_eps @@ -503,32 +503,30 @@ bimapApp env (Just (tycon, ty_args)) ------------------- -- bimapArrow :: [EP a a', EP b b'] -> EP (a->b) (a'->b') bimapArrow [ep1, ep2] - = EP { fromEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] from_body, - toEP = mk_hs_lam [VarPat a_RDR, VarPat b_RDR] to_body } + = EP { fromEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] from_body, + toEP = mkHsLam [nlVarPat a_RDR, nlVarPat b_RDR] to_body } where - from_body = fromEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ toEP ep1 `HsApp` HsVar b_RDR)) - to_body = toEP ep2 `HsApp` (HsPar $ HsVar a_RDR `HsApp` (HsPar $ fromEP ep1 `HsApp` HsVar b_RDR)) + from_body = fromEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ toEP ep1 `mkHsApp` nlHsVar b_RDR)) + to_body = toEP ep2 `mkHsApp` (mkHsPar $ nlHsVar a_RDR `mkHsApp` (mkHsPar $ fromEP ep1 `mkHsApp` nlHsVar b_RDR)) ------------------- bimapTuple eps - = EP { fromEP = mk_hs_lam [tuple_pat] from_body, - toEP = mk_hs_lam [tuple_pat] to_body } + = EP { fromEP = mkHsLam [noLoc tuple_pat] (noLoc from_body), + toEP = mkHsLam [noLoc tuple_pat] (noLoc to_body) } where names = takeList eps gs_RDR - tuple_pat = TuplePat (map VarPat names) Boxed + tuple_pat = TuplePat (map nlVarPat names) Boxed eps_w_names = eps `zip` names - to_body = ExplicitTuple [toEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed - from_body = ExplicitTuple [fromEP ep `HsApp` HsVar g | (ep,g) <- eps_w_names] Boxed + to_body = ExplicitTuple [toEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed + from_body = ExplicitTuple [fromEP ep `mkHsApp` nlHsVar g | (ep,g) <- eps_w_names] Boxed ------------------- a_RDR = mkVarUnqual FSLIT("a") b_RDR = mkVarUnqual FSLIT("b") gs_RDR = [ mkVarUnqual (mkFastString ("g"++show i)) | i <- [(1::Int) .. ] ] -mk_hs_lam pats body = HsPar (HsLam (mkSimpleMatch pats body placeHolderType generatedSrcLoc)) - -idEP :: EP (HsExpr RdrName) +idEP :: EP (LHsExpr RdrName) idEP = EP idexpr idexpr where - idexpr = mk_hs_lam [VarPat a_RDR] (HsVar a_RDR) + idexpr = mkHsLam [nlVarPat a_RDR] (nlHsVar a_RDR) \end{code} diff --git a/ghc/compiler/utils/Bag.lhs b/ghc/compiler/utils/Bag.lhs index ed9a5407fb..4ee8b0fafb 100644 --- a/ghc/compiler/utils/Bag.lhs +++ b/ghc/compiler/utils/Bag.lhs @@ -11,13 +11,15 @@ module Bag ( mapBag, elemBag, filterBag, partitionBag, concatBag, foldBag, foldrBag, foldlBag, - isEmptyBag, consBag, snocBag, - listToBag, bagToList + isEmptyBag, isSingletonBag, consBag, snocBag, + listToBag, bagToList, + mapBagM, mapAndUnzipBagM ) where #include "HsVersions.h" import Outputable +import Util ( isSingleton ) import List ( partition ) \end{code} @@ -26,10 +28,8 @@ import List ( partition ) data Bag a = EmptyBag | UnitBag a - | TwoBags (Bag a) (Bag a) -- The ADT guarantees that at least - -- one branch is non-empty - | ListBag [a] -- The list is non-empty - | ListOfBags [Bag a] -- The list is non-empty + | TwoBags (Bag a) (Bag a) -- INVARIANT: neither branch is empty + | ListBag [a] -- INVARIANT: the list is non-empty emptyBag = EmptyBag unitBag = UnitBag @@ -40,13 +40,13 @@ elemBag x EmptyBag = False elemBag x (UnitBag y) = x==y elemBag x (TwoBags b1 b2) = x `elemBag` b1 || x `elemBag` b2 elemBag x (ListBag ys) = any (x ==) ys -elemBag x (ListOfBags bs) = any (x `elemBag`) bs -unionManyBags [] = EmptyBag -unionManyBags xs = ListOfBags xs +unionManyBags :: [Bag a] -> Bag a +unionManyBags xs = foldr unionBags EmptyBag xs -- This one is a bit stricter! The bag will get completely evaluated. +unionBags :: Bag a -> Bag a -> Bag a unionBags EmptyBag b = b unionBags b EmptyBag = b unionBags b1 b2 = TwoBags b1 b2 @@ -57,11 +57,14 @@ snocBag :: Bag a -> a -> Bag a consBag elt bag = (unitBag elt) `unionBags` bag snocBag bag elt = bag `unionBags` (unitBag elt) -isEmptyBag EmptyBag = True -isEmptyBag (UnitBag x) = False -isEmptyBag (TwoBags b1 b2) = isEmptyBag b1 && isEmptyBag b2 -- Paranoid, but safe -isEmptyBag (ListBag xs) = null xs -- Paranoid, but safe -isEmptyBag (ListOfBags bs) = all isEmptyBag bs +isEmptyBag EmptyBag = True +isEmptyBag other = False -- NB invariants + +isSingletonBag :: Bag a -> Bool +isSingletonBag EmptyBag = False +isSingletonBag (UnitBag x) = True +isSingletonBag (TwoBags b1 b2) = False -- Neither is empty +isSingletonBag (ListBag xs) = isSingleton xs filterBag :: (a -> Bool) -> Bag a -> Bag a filterBag pred EmptyBag = EmptyBag @@ -71,17 +74,12 @@ filterBag pred (TwoBags b1 b2) = sat1 `unionBags` sat2 sat1 = filterBag pred b1 sat2 = filterBag pred b2 filterBag pred (ListBag vs) = listToBag (filter pred vs) -filterBag pred (ListOfBags bs) = ListOfBags sats - where - sats = [filterBag pred b | b <- bs] concatBag :: Bag (Bag a) -> Bag a - concatBag EmptyBag = EmptyBag concatBag (UnitBag b) = b -concatBag (TwoBags b1 b2) = concatBag b1 `TwoBags` concatBag b2 -concatBag (ListBag bs) = ListOfBags bs -concatBag (ListOfBags bbs) = ListOfBags (map concatBag bbs) +concatBag (TwoBags b1 b2) = concatBag b1 `unionBags` concatBag b2 +concatBag (ListBag bs) = unionManyBags bs partitionBag :: (a -> Bool) -> Bag a -> (Bag a {- Satisfy predictate -}, Bag a {- Don't -}) @@ -94,9 +92,6 @@ partitionBag pred (TwoBags b1 b2) = (sat1 `unionBags` sat2, fail1 `unionBags` fa partitionBag pred (ListBag vs) = (listToBag sats, listToBag fails) where (sats,fails) = partition pred vs -partitionBag pred (ListOfBags bs) = (ListOfBags sats, ListOfBags fails) - where - (sats, fails) = unzip [partitionBag pred b | b <- bs] foldBag :: (r -> r -> r) -- Replace TwoBags with this; should be associative @@ -110,7 +105,6 @@ foldBag t u e EmptyBag = e foldBag t u e (UnitBag x) = u x foldBag t u e (TwoBags b1 b2) = (foldBag t u e b1) `t` (foldBag t u e b2) foldBag t u e (ListBag xs) = foldr (t.u) e xs -foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag e u t b `t` r) e bs -} -- More tail-recursive definition, exploiting associativity of "t" @@ -118,7 +112,6 @@ foldBag t u e EmptyBag = e foldBag t u e (UnitBag x) = u x `t` e foldBag t u e (TwoBags b1 b2) = foldBag t u (foldBag t u e b2) b1 foldBag t u e (ListBag xs) = foldr (t.u) e xs -foldBag t u e (ListOfBags bs) = foldr (\b r -> foldBag t u r b) e bs foldrBag :: (a -> r -> r) -> r -> Bag a @@ -128,7 +121,6 @@ foldrBag k z EmptyBag = z foldrBag k z (UnitBag x) = k x z foldrBag k z (TwoBags b1 b2) = foldrBag k (foldrBag k z b2) b1 foldrBag k z (ListBag xs) = foldr k z xs -foldrBag k z (ListOfBags bs) = foldr (\b r -> foldrBag k r b) z bs foldlBag :: (r -> a -> r) -> r -> Bag a @@ -138,7 +130,6 @@ foldlBag k z EmptyBag = z foldlBag k z (UnitBag x) = k z x foldlBag k z (TwoBags b1 b2) = foldlBag k (foldlBag k z b1) b2 foldlBag k z (ListBag xs) = foldl k z xs -foldlBag k z (ListOfBags bs) = foldl (\r b -> foldlBag k r b) z bs mapBag :: (a -> b) -> Bag a -> Bag b @@ -146,8 +137,22 @@ mapBag f EmptyBag = EmptyBag mapBag f (UnitBag x) = UnitBag (f x) mapBag f (TwoBags b1 b2) = TwoBags (mapBag f b1) (mapBag f b2) mapBag f (ListBag xs) = ListBag (map f xs) -mapBag f (ListOfBags bs) = ListOfBags (map (mapBag f) bs) +mapBagM :: Monad m => (a -> m b) -> Bag a -> m (Bag b) +mapBagM f EmptyBag = return EmptyBag +mapBagM f (UnitBag x) = do { r <- f x; return (UnitBag r) } +mapBagM f (TwoBags b1 b2) = do { r1 <- mapBagM f b1; r2 <- mapBagM f b2; return (TwoBags r1 r2) } +mapBagM f (ListBag xs) = do { rs <- mapM f xs; return (ListBag rs) } + +mapAndUnzipBagM :: Monad m => (a -> m (b,c)) -> Bag a -> m (Bag b, Bag c) +mapAndUnzipBagM f EmptyBag = return (EmptyBag, EmptyBag) +mapAndUnzipBagM f (UnitBag x) = do { (r,s) <- f x; return (UnitBag r, UnitBag s) } +mapAndUnzipBagM f (TwoBags b1 b2) = do { (r1,s1) <- mapAndUnzipBagM f b1 + ; (r2,s2) <- mapAndUnzipBagM f b2 + ; return (TwoBags r1 r2, TwoBags s1 s2) } +mapAndUnzipBagM f (ListBag xs) = do { ts <- mapM f xs + ; let (rs,ss) = unzip ts + ; return (ListBag rs, ListBag ss) } listToBag :: [a] -> Bag a listToBag [] = EmptyBag @@ -163,6 +168,4 @@ instance (Outputable a) => Outputable (Bag a) where ppr (UnitBag a) = ppr a ppr (TwoBags b1 b2) = hsep [ppr b1 <> comma, ppr b2] ppr (ListBag as) = interpp'SP as - ppr (ListOfBags bs) = brackets (interpp'SP bs) - \end{code} diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index e11941721f..6e98c2fbcb 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -62,10 +62,7 @@ import Panic import DATA_WORD ( Word32 ) import IO ( Handle, stderr, stdout, hFlush ) -import Char ( chr ) -#if __GLASGOW_HASKELL__ < 410 -import Char ( ord, isDigit ) -#endif +import Char ( chr, ord ) \end{code} @@ -391,45 +388,16 @@ class Outputable a => OutputableBndr a where %************************************************************************ \begin{code} -#if __GLASGOW_HASKELL__ < 410 --- Assume we have only 8-bit Chars. - -pprHsChar :: Int -> SDoc -pprHsChar c = char '\'' <> text (showCharLit c "") <> char '\'' - -pprHsString :: FastString -> SDoc -pprHsString fs = doubleQuotes (text (foldr showCharLit "" (unpackIntFS fs))) - -showCharLit :: Int -> String -> String -showCharLit c rest - | c == ord '\"' = "\\\"" ++ rest - | c == ord '\'' = "\\\'" ++ rest - | c == ord '\\' = "\\\\" ++ rest - | c >= 0x20 && c <= 0x7E = chr c : rest - | c == ord '\a' = "\\a" ++ rest - | c == ord '\b' = "\\b" ++ rest - | c == ord '\f' = "\\f" ++ rest - | c == ord '\n' = "\\n" ++ rest - | c == ord '\r' = "\\r" ++ rest - | c == ord '\t' = "\\t" ++ rest - | c == ord '\v' = "\\v" ++ rest - | otherwise = ('\\':) $ shows (fromIntegral c :: Word32) $ case rest of - d:_ | isDigit d -> "\\&" ++ rest - _ -> rest - -#else -- We have 31-bit Chars and will simply use Show instances -- of Char and String. -pprHsChar :: Int -> SDoc -pprHsChar c | c > 0x10ffff = char '\\' <> text (show (fromIntegral c :: Word32)) - | otherwise = text (show (chr c)) +pprHsChar :: Char -> SDoc +pprHsChar c | c > '\x10ffff' = char '\\' <> text (show (fromIntegral (ord c) :: Word32)) + | otherwise = text (show c) pprHsString :: FastString -> SDoc pprHsString fs = text (show (unpackFS fs)) -#endif - instance Show FastString where showsPrec p fs = showsPrecSDoc p (ppr fs) \end{code} diff --git a/ghc/compiler/utils/Pretty.lhs b/ghc/compiler/utils/Pretty.lhs index a3cb5325cf..6f3f1ea71e 100644 --- a/ghc/compiler/utils/Pretty.lhs +++ b/ghc/compiler/utils/Pretty.lhs @@ -492,7 +492,7 @@ no occurrences of @Union@ or @NoDoc@ represents just one layout. data Doc = Empty -- empty | NilAbove Doc -- text "" $$ x - | TextBeside TextDetails INT Doc -- text s <> x + | TextBeside !TextDetails INT Doc -- text s <> x | Nest INT Doc -- nest k x | Union Doc Doc -- ul `union` ur | NoDoc -- The empty set of documents @@ -1016,6 +1016,8 @@ spaces n = ' ' : spaces (n MINUS ILIT(1)) pprCols = (120 :: Int) -- could make configurable printDoc :: Mode -> Handle -> Doc -> IO () +printDoc LeftMode hdl doc + = do { printLeftRender hdl doc; hFlush hdl } printDoc mode hdl doc = do { fullRender mode pprCols 1.5 put done doc ; hFlush hdl } @@ -1027,6 +1029,22 @@ printDoc mode hdl doc done = hPutChar hdl '\n' +-- basically a specialised version of fullRender for LeftMode with IO output. +printLeftRender :: Handle -> Doc -> IO () +printLeftRender hdl doc = lay (reduceDoc doc) + where + lay NoDoc = cant_fail + lay (Union p q) = lay (first p q) + lay (Nest k p) = lay p + lay Empty = hPutChar hdl '\n' + lay (NilAbove p) = hPutChar hdl '\n' >> lay p + lay (TextBeside s sl p) = put s >> lay p + + put (Chr c) = hPutChar hdl c + put (Str s) = hPutStr hdl s + put (PStr s) = hPutFS hdl s + put (LStr s l) = hPutLitString hdl s l + #if __GLASGOW_HASKELL__ < 503 hPutBuf = hPutBufFull #endif |