diff options
Diffstat (limited to 'ghc/compiler')
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 |