{-# NOINLINE name #-}
#endif
+#if __GLASGOW_HASKELL__ >= 620
+#define UNBOX_FIELD !!
+#else
+#define UNBOX_FIELD !
+#endif
+
#define COMMA ,
#ifdef DEBUG
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
utils/Digraph_HC_OPTS = -fglasgow-exts
+basicTypes/SrcLoc_HC_OPTS = -funbox-strict-fields
+
ifeq "$(bootstrapped)" "YES"
utils/Binary_HC_OPTS = -funbox-strict-fields
endif
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
# -----------------------------------------------------------------------------
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
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
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)
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
\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
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 )
-- 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)
%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+% (c) The University of Glasgow, 1992-2003
%
%************************************************************************
%* *
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}
%************************************************************************
\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
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>")
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}
%************************************************************************
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
= 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}
import Outputable
import List ( partition )
+import Char ( ord )
\end{code}
%************************************************************************
| 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}
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,
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
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
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
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
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)
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}
(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]
\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)
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)
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
\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
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 -}
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]
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
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
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
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
\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
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
-- 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
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}
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 )
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.
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}
-- 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"
; 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.
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,
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
%************************************************************************
\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
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}
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 )
import CoreUtils ( mkIfThenElse, bindNonRec, exprType )
import Id ( Id, idType )
+import Name ( Name )
import PrelInfo ( pAT_ERROR_ID )
import DataCon ( dataConWrapId )
import TysWiredIn ( tupleCon )
import VarSet ( IdSet, mkVarSet, varSetElems,
intersectVarSet, minusVarSet,
unionVarSet, unionVarSets, elemVarSet )
-import SrcLoc ( SrcLoc )
+import SrcLoc ( Located(..), unLoc, noLoc, getLoc )
\end{code}
\begin{code}
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)
\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}
-- 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
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
core_cmd
in
returnDs (bindCmdEnv meth_ids proc_code)
-
\end{code}
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
-- 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
-- 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
-- ---> 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
-- ---> 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
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
-- 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
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
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
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.
= 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,
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
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
-- -----------------------------------
-- 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,
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') ->
-> 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))
-- 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
-- --------------------------
-- 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') ->
`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)
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
-- 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
-- ---> 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 []
-- 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
-- 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
-- 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
:: 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
-> 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)
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
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
\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.
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
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 )
import Subst ( substTyWith )
import TysWiredIn ( voidTy )
import Outputable
+import SrcLoc ( Located(..) )
import Maybe ( isJust )
+import Bag ( Bag, bagToList )
+
+import Monad ( foldM )
\end{code}
%************************************************************************
%************************************************************************
\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
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)
-- 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
-- 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
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)
])
| otherwise
- = getSrcLocDs `thenDs` \ l ->
+ = getSrcSpanDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
__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 ;
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
\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
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
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}
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
-- 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.
%************************************************************************
\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
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}
\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 ->
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)
-- 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}
% ~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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}
= 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)
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 _)
\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 ""
\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
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 ->
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
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
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}
#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}
%--------------------------------------------------------------------
-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
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])
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}
\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}
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(..) )
import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
checkDotnetResName )
import BasicTypes ( Activation( NeverActive ) )
+import SrcLoc ( Located(..), unLoc )
import Outputable
import Maybe ( fromJust )
import FastString
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, [])
= 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)
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` \_ ->
#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
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.
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) ->
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)
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}
%************************************************************************
\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
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}
#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
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}
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
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 ->
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)
= 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}
(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}
\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))
= 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
--
-- [:e | qss:] = <<[:e | qss:]>> () [:():]
--
-dsPArrComp :: [TypecheckedStmt]
+dsPArrComp :: [Stmt Id]
-> Type -- Don't use; called with `undefined' below
-> DsM CoreExpr
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
--
-- <<[: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
-- 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
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])
--
--
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 ->
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])
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
-- 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
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
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 )
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 --------------------
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.
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 } ;
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]
-}
-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 ;
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!
; 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
-- 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)] }
-- 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
-- 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
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"
-- 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
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') }
-----------------------------------------------------------------------------
-- 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
-- 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) }}
; 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) }
-- 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"
-- 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"
-- 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 }
----------------------------------------------------------
-- 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
----------------------------------------------------------
-- 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;
-- * 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
occNameLit :: Name -> DsM (Core String)
occNameLit n = coreStringLit (occNameUserString (nameOccName n))
-void = placeHolderType
-
-string :: String -> HsExpr Id
-string s = HsLit (HsString (mkFastString s))
-
-- %*********************************************************************
-- %* *
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
--------------- 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]
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)
-
newTyVarsDs,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs,
- getSrcLocDs, putSrcLocDs,
+ getSrcSpanDs, putSrcSpanDs,
getModuleDs,
newUnique,
UniqSupply, newUniqueSupply,
#include "HsVersions.h"
-import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
import TcRnMonad
+import HsSyn ( HsExpr, HsMatchContext, Pat )
import IfaceEnv ( tcIfaceGlobal )
import HscTypes ( TyThing(..), TypeEnv, HscEnv,
IsBootInterface,
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 )
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
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
-- 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)
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
\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
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)) }
\begin{code}
data DsMatchContext
- = DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
+ = DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan
| NoMatchContext
deriving ()
\end{code}
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
lengthPName, indexPName )
import Outputable
import UnicodeUtil ( intsToUtf8, stringToUtf8 )
+import SrcLoc ( Located(..), unLoc, noLoc )
import Util ( isSingleton, notNull, zipEqual )
import ListSetOps ( assocDefault )
import FastString
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
%************************************************************************
\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
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}
-- 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}
-> 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)))
%************************************************************************
\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
| lengthFS str == 1
= let
- the_char = mkCharExpr (headIntFS str)
+ the_char = mkCharExpr (headFS str)
in
returnDs (mkConsExpr charTy the_char (mkNilExpr charTy))
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)
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}
__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 ;
matchSimply
:: CoreSyn.CoreExpr
-> HsExpr.HsMatchContext Var.Id
- -> TcHsSyn.TypecheckedPat
+ -> HsPat.LPat Var.Id
-> CoreSyn.CoreExpr
-> CoreSyn.CoreExpr
-> DsMonad.DsM CoreSyn.CoreExpr
matchSinglePat
:: CoreSyn.CoreExpr
-> DsMonad.DsMatchContext
- -> TcHsSyn.TypecheckedPat
+ -> HsPat.LPat Var.Id
-> DsUtils.MatchResult
-> DsMonad.DsM DsUtils.MatchResult
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 )
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}
| 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,
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
--
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[] }
-- 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
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)
-- 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
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...
= -- 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
-- 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
\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}
\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}
\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}
This is actually local to @matchWrapper@.
\begin{code}
-flattenMatches :: TypecheckedMatchContext
- -> [TypecheckedMatch]
+flattenMatches :: HsMatchContext Name
+ -> [LMatch Id]
-> DsM (Type, [EquationInfo])
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}
import CoreFVs ( exprFreeVars )
import VarEnv ( emptySubstEnv )
import ListSetOps ( equivClassesByUniq )
+import SrcLoc ( unLoc )
import Unique ( Uniquable(..) )
\end{code}
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)
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]
import DsMonad
import DsUtils
-import HsSyn ( HsLit(..), Pat(..), HsExpr(..) )
-import TcHsSyn ( TypecheckedPat )
+import HsSyn
import Id ( Id )
import CoreSyn
import TyCon ( tyConDataCons )
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
(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
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)
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
= ( \ (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)
| 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
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(..) )
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)
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
= 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
mkDummyLiteral :: PrimRep -> Literal
mkDummyLiteral pr
= case pr of
- CharRep -> MachChar 0
+ CharRep -> MachChar (chr 0)
IntRep -> MachInt 0
WordRep -> MachWord 0
DoubleRep -> MachDouble 0
{-# 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
--
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(..) )
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(..) )
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
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
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)
| 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
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
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
| 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])
-----------------------------------------------------------
-- 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
void :: Type.Type
void = placeHolderType
-loc0 :: SrcLoc
-loc0 = generatedSrcLoc
+loc0 :: SrcSpan
+loc0 = srcLocSpan generatedSrcLoc
--------------------------------------------------------------------
-- Turning Name back into RdrName
%
\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 ->
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.
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),
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
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
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}
\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,
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
import CStrings ( CLabelString )
import Outputable
import Util ( count )
-import SrcLoc ( SrcLoc )
+import SrcLoc ( Located(..), unLoc )
import FastString
\end{code}
%************************************************************************
\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)
-- 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}
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}
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
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
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
-- 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}
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
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
= 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))
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}
%************************************************************************
\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 -- !
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)
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
%************************************************************************
\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) ]
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}
-- * 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
--
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
%************************************************************************
\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
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}
__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 ;
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
-- 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 )
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}
%************************************************************************
%* *
- 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.
-- 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
-- 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}
\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.
\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}
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)]
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
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
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
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
= 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)
= 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
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
\begin{code}
type HsCmd id = HsExpr id
+type LHsCmd id = LHsExpr id
+
data HsArrAppType = HsHigherOrderApp | HsFirstOrderApp
\end{code}
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)
%************************************************************************
\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}
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)]
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}
%************************************************************************
\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
-- 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
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}
%************************************************************************
%************************************************************************
\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
\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}
import Module ( ModuleName )
import Outputable
import FastString
-import SrcLoc ( SrcLoc )
+import SrcLoc ( Located(..) )
import Char ( isAlpha )
\end{code}
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)
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}
%************************************************************************
%************************************************************************
\begin{code}
+type LIE name = Located (IE name)
+
data IE name
= IEVar name
| IEThingAbs name -- Class/Type (can't tell)
\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,
\begin{code}
module HsPat (
- Pat(..), InPat, OutPat,
+ Pat(..), InPat, OutPat, LPat,
HsConDetails(..), hsConArgs,
patsAreAllCons, isConPat, isSigPat,
patsAreAllLits, isLitPat,
collectPatBinders, collectPatsBinders,
+ collectLocatedPatBinders, collectLocatedPatsBinders,
collectSigTysFromPat, collectSigTysFromPats
) where
-- 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 )
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
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)
\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]
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)
\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}
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
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
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
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}
-
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"
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
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
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}
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}
-
\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"
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}
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!
--
| 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
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
-- 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
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
= 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}
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
| 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)
-- (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]
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
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)
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 )
opt_UF_DearOp,
-- misc opts
+ opt_ErrorSpans,
opt_InPackage,
opt_EmitCExternDecls,
opt_EnsureSplittableC,
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}
%************************************************************************
"fext-core",
"frule-check",
"frules-off",
- "fcpr-off"
+ "fcpr-off",
+ "ferror-spans"
]
|| any (flip prefixMatch f) [
"fcontext-stack",
\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,
#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
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
#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 )
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 )
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 )
import CmdLineOpts
import DriverPhases ( isExtCoreFilename )
-import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass )
+import ErrUtils ( dumpIfSet, dumpIfSet_dyn, showPass, printError )
import UniqSupply ( mkSplitUniqSupply )
import Outputable
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 {
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 } ;
\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
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;
= 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
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
#ifdef GHCI
compileExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
- -> TypecheckedHsExpr
+ -> LHsExpr Id
-> IO HValue
compileExpr hsc_env this_mod rdr_env type_env tc_expr
import HsSyn
import Outputable
+import SrcLoc ( unLoc, Located(..) )
import Char ( isSpace )
+import Bag ( bagToList )
import Util ( count )
\end{code}
%************************************************************************
\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
("SpecialisedBinds ", bind_specs)
])
where
+ decls = map unLoc ldecls
+
pp_val (str, 0) = empty
pp_val (str, n)
| not short = hcat [text str, int n]
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)
(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
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)
import PrelNames ( isBuiltInSyntaxName )
import Maybes ( orElse )
import Outputable
-import SrcLoc ( SrcLoc )
+import SrcLoc ( SrcSpan )
import UniqSupply ( UniqSupply )
import Maybe ( fromJust )
import FastString ( FastString )
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)
import CmdLineOpts
import FastString
import StringBuffer
+import ErrUtils ( mkLocMessage )
import SrcLoc
import Outputable
import Panic ( GhcException(..) )
}
%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 ] }
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
import CmdLineOpts ( opt_EnsureSplittableC )
import Outputable ( assertPanic )
+import Char ( ord )
+
-- DEBUGGING ONLY
--import TRACE ( trace )
--import Outputable ( showSDoc )
\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"
import Util ( notNull )
import FastString
import FastTypes
+import Char
#include "NCG.h"
\end{code}
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"
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
{
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
import DATA_BITS
import Char
import Ratio
-import TRACE
+--import TRACE
}
$whitechar = [\ \t\n\r\f\v\xa0]
-- -----------------------------------------------------------------------------
-- The token type
-data Token = T SrcLoc{-start-} SrcLoc{-end-} Token__
-
-data Token__
+data Token
= ITas -- Haskell keywords
| ITcase
| ITclass
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.
-- -----------------------------------------------------------------------------
-- 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
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
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) ->
_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
(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
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
-- 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
-- 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 : _ |
-- 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
-- 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
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
-- 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
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
_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
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],
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)
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)
mkPState buf loc flags =
PState {
buffer = buf,
- last_loc = loc,
+ last_loc = mkSrcSpan loc loc,
last_len = 0,
loc = loc,
extsBitmap = fromIntegral bitmap,
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} ->
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
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
}
+++ /dev/null
-{- -*-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
-}
--- /dev/null
+-- -*-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))
+}
import TyCon ( TyCon, tyConName )
import FastString
import Outputable
+import Char
#include "../HsVersions.h"
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 }
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 }
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)
-- 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
\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,
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
, 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
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}
%************************************************************************
\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
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}
*** 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}
%************************************************************************
-- 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
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 = [] }
| 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)
-- 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.}
%* *
%************************************************************************
\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
--
-- 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}
%************************************************************************
-- 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
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.
-- 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
--
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)
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
--
--
-- 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)
(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
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}
\begin{code}
module RnBinds (
- rnTopMonoBinds, rnMonoBinds, rnMonoBindsAndThen,
+ rnTopBinds, rnBinds, rnBindsAndThen,
rnMethodBinds, renameSigs, checkSigs
) where
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,
)
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
%************************************************************************
%* *
-%* analysing polymorphic bindings (HsBinds, Bind, MonoBinds) *
+%* analysing polymorphic bindings (HsBindGroup, HsBind)
%* *
%************************************************************************
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}
%************************************************************************
\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) ->
-- 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}
%* *
%************************************************************************
{\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
(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
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
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
@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:
\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
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}
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
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
-- 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}
%************************************************************************
\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"))
\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,
checkDupNames, mapFvRn,
warnUnusedMatches, warnUnusedModules, warnUnusedImports,
warnUnusedTopBinds, warnUnusedLocalBinds,
- dataTcOccs, unknownNameErr
+ dataTcOccs, unknownNameErr,
) where
#include "HsVersions.h"
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,
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}
%*********************************************************
\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
-- 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}
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.
-- 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
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 )
-- 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
-- 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
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
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
; 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
| 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}
--------------------------------
-- 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}
%*********************************************************
\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
-------------------------------------
-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)
= 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
-------------------------------------
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}
-------------------------
-- 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"
= 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)
\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,
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}
************************************************************************
\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 ->
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) ->
%************************************************************************
\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}
%************************************************************************
%************************************************************************
\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
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 ->
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
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
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) ->
%************************************************************************
\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) ->
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}
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
-- 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
\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}
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}
%************************************************************************
\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)
%************************************************************************
\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
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` \ _ ->
-- 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
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
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}
----------------------------------------------------
-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
----------------------------------------------------
-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)
-- 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)
----------------------------------------------------
-segsToStmts :: [Segment [RenamedStmt]] -> ([RenamedStmt], FreeVars)
+segsToStmts :: [Segment [LStmt Name]] -> ([LStmt Name], FreeVars)
segsToStmts [] = ([], emptyFVs)
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
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)
---------------------------
-- 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)
-- 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
\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 &&
-- 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
%************************************************************************
\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)
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}
%************************************************************************
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
\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
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}
%* *
%************************************************************************
-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}
#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 )
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 )
%************************************************************************
\begin{code}
-rnImports :: [RdrNameImportDecl]
+rnImports :: [LImportDecl RdrName]
-> RnM (GlobalRdrEnv, ImportAvails)
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
-- 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
-- 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),
%* *
%*********************************************************
-@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 ****
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}
\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
= 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
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
-- 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])]
\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
-- 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 ;
-- 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
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 ;
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)
}
-- 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
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") ]
__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)
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)
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,
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 )
\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,
-- 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
-- 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,
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 }
%*********************************************************
\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)
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
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}
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
%*********************************************************
\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}
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
%*********************************************************
\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
%*********************************************************
\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 (
--
-- 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}
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}
%*********************************************************
\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
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
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
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,
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' ->
-- 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_`
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
%*********************************************************
\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
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
%*********************************************************
\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' ->
\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
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}
%*********************************************************
\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)
-- 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
= 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)
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
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
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
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)
%*********************************************************
\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}
\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
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
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)
= 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"
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
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
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
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
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) ->
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))]
$$
= (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]
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`
| 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
= 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
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
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
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}
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)
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
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
| 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 ->
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)])
= 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}
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}
%************************************************************************
\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
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
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
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)
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)
\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 ->
-- 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 ->
import {-# SOURCE #-} TcExpr( tcCheckRho )
import HsSyn
-import TcHsSyn ( TcCmdTop, TcExpr, TcPat, mkHsLet )
+import TcHsSyn ( mkHsLet )
import TcMatches ( TcStmtCtxt(..), tcMatchPats, matchCtxt, tcStmts,
TcMatchCtxt(..), tcMatchesCase )
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 )
%************************************************************************
\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
---------------------------------------
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
; 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.
-------------------------------------------
-- 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
-------------------------------------------
-- 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)
; 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
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
-- ----------------------------------------------
-- 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
-- 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
-- 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}
\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
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 )
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 )
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,
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
-- 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
-- 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
\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
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)
-- 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) ->
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
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
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
(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}
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
-- 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
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)
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.
\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}
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
-- 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
= 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
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))
| 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 ->
(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)
-- 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
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}
{-# 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
-- 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 ->
-- 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}
%************************************************************************
#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
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 )
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}
\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
= 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
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
(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
-- 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]
-- (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 ->
[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
\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
-> 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)
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
-- 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 ->
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
= (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
-- 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)
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))
-- 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)
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
(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
-- 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
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
\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}
\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 }
(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
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 [] = []
(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)
-- 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 ->
%************************************************************************
\begin{code}
-tcAddDeclCtxt decl thing_inside
- = addSrcLoc (tcdLoc decl) $
+tcAddDeclCtxt (L loc decl) thing_inside
+ = addSrcSpan loc $
addErrCtxt ctxt $
thing_inside
where
#include "HsVersions.h"
-import HsSyn ( DefaultDecl(..) )
+import HsSyn ( DefaultDecl(..), LDefaultDecl )
import Name ( Name )
import TcRnMonad
import TcEnv ( tcLookupClass )
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.
-- 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 ->
returnM (Just tau_tys)
-tcDefaults decls@(DefaultDecl _ loc : _) =
- addSrcLoc loc $
+tcDefaults decls@(L locn (DefaultDecl _) : _) =
+ addSrcSpan locn $
failWithTc (dupDefaultDeclErr decls)
$$ 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)
#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 )
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 )
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 )
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}
%************************************************************************
%************************************************************************
\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
-- 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
; 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
; 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}
all those.
\begin{code}
-makeDerivEqns :: [RenamedTyClDecl]
+makeDerivEqns :: [LTyClDecl Name]
-> TcM ([DerivEqn], -- Ordinary derivings
[InstInfo]) -- Special newtype derivings
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
------------------------------------------------------------------
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
\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
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))
-- 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}
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
-- Global environment
tcExtendGlobalEnv,
tcExtendGlobalValEnv,
- tcLookupGlobal,
+ tcLookupLocatedGlobal, tcLookupGlobal,
tcLookupGlobalId, tcLookupTyCon, tcLookupClass, tcLookupDataCon,
+ tcLookupLocatedGlobalId, tcLookupLocatedTyCon,
+ tcLookupLocatedClass, tcLookupLocatedDataCon,
getInGlobalScope,
tcExtendTyVarKindEnv,
tcExtendTyVarEnv, tcExtendTyVarEnv2,
tcExtendLocalValEnv, tcExtendLocalValEnv2,
- tcLookup, tcLookupLocalIds,
+ tcLookup, tcLookupLocated, tcLookupLocalIds,
tcLookupId, tcLookupTyVar,
lclEnvElts, getInLocalScope, findGlobals,
#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 )
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}
%* *
%************************************************************************
+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
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}
%************************************************************************
%************************************************************************
\begin{code}
+tcLookupLocated :: Located Name -> TcM TcTyThing
+tcLookupLocated = addLocM tcLookup
+
tcLookup :: Name -> TcM TcTyThing
tcLookup name
= getLclEnv `thenM` \ local_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
%************************************************************************
\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
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
__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) ;
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)
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 )
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(..) )
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 )
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}
%************************************************************************
\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_`
= 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
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')
%************************************************************************
\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)
%************************************************************************
\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}
-- 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' ->
-- 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' ->
-- 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' ->
\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
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' ->
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')
= 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')
= 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}
%************************************************************************
%************************************************************************
\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
-- 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:
--
-- 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
%************************************************************************
\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' ->
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' ->
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' ->
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' ->
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' ->
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
#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}
%************************************************************************
\begin{code}
-tcMonoExpr other _ = pprPanic "tcMonoExpr" (ppr other)
+tc_expr other _ = pprPanic "tcMonoExpr" (ppr other)
\end{code}
\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
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
\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) $
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
-- 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))
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}
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)
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
%************************************************************************
\begin{code}
-tcCheckRhos :: [RenamedHsExpr] -> [TcType] -> TcM [TcExpr]
+tcCheckRhos :: [LHsExpr Name] -> [TcType] -> TcM [LHsExpr TcId]
tcCheckRhos [] [] = returnM []
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)
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:"))
<+> 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
#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,
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}
%************************************************************************
%************************************************************************
\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
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}
%************************************************************************
\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_`
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 ----------------------
#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,
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
)
import Outputable
import FastString
import OccName
+import Bag
\end{code}
%************************************************************************
\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)
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
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}
%************************************************************************
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
| 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,
= ([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
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
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}
%************************************************************************
\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
----- 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}
%************************************************************************
(p.~147).
\begin{code}
-gen_Ix_binds :: TyCon -> RdrNameMonoBinds
+gen_Ix_binds :: TyCon -> LHsBinds RdrName
gen_Ix_binds tycon
= if isEnumerationTyCon 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...
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}
%************************************************************************
\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
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
-- 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
-- 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...
([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
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)
-- 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
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}
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}
\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
= 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)
%* *
%************************************************************************
-@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)
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
-----------------------------------------------------------------------
-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
\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}
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_"
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}
\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,
-- re-exported from TcMonad
TcId, TcIdSet,
- zonkTopBinds, zonkTopDecls, zonkTopExpr,
+ zonkTopDecls, zonkTopExpr, zonkTopLExpr,
zonkId, zonkTopBndrs
) where
-- others:
import Id ( idType, setIdType, Id )
-import DataCon ( dataConWrapId )
import TcRnMonad
import Type ( Type )
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}
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)
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
\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 ->
%************************************************************************
\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}
%************************************************************************
\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))
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 ->
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)
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 ->
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
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)
%************************************************************************
\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 ->
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,
\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
-- 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}
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
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}
%************************************************************************
\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) $
-- 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}
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
= 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}
\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
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:
--
-- 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' ->
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' ->
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'
---------------------------
--
-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
-- 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 ->
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)
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)
~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
\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
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}
\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)
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' ->
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
-- 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
\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
\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
-- 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}
#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 )
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}
\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 $
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 ->
\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"
-- 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
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
%************************************************************************
\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
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
-- 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) ==============
\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
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] (
-- 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)
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'
= -- 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_`
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
-- 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, _)
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
\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
-- friends:
-import HsSyn ( HsType )
+import HsSyn ( LHsType )
import TypeRep ( Type(..), PredType(..), TyNote(..), -- Friend; can see representation
Kind, ThetaType
)
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 )
import CmdLineOpts ( dopt, DynFlag(..) )
import Util ( nOfThem, isSingleton, equalLength, notNull )
import ListSetOps ( removeDups )
+import SrcLoc ( unLoc )
import Outputable
\end{code}
-- 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)]
__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] ;
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]
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(..) )
import Bag
import Util ( isSingleton, notNull )
import Outputable
+import SrcLoc ( Located(..), noLoc )
import List ( nub )
\end{code}
\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
\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
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 }
@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,
\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}
\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
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
-- 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 $
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}
\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
-- 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 ->
-- 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
-- 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
\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' ->
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
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 ->
-- 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)
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
-- 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)
-- 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}
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}
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)
#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 )
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 )
import PrelNames ( eqStringName, eqName, geName, negateName, minusName,
integralClassName )
import BasicTypes ( isBoxed )
+import SrcLoc ( Located(..), noLoc, unLoc )
import Bag
import Outputable
import FastString
\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
-- 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}
%************************************************************************
\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}
%************************************************************************
\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 ->
-- 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)
%************************************************************************
\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.
%************************************************************************
\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 ->
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
(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
%************************************************************************
\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
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?)
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
\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
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
-- 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)
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}
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,
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,
)
#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(..) )
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 )
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}
\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,
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.
#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]
--
\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]
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,
-- 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 []
} ;
-- 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
-- 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)
\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;
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
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}
%************************************************************************
\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
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 } ;
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
} ;
-- 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
-- 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,
-- 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)
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}
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)
})
import TcRnTypes -- Re-export all
import IOEnv -- Re-export all
-import HsSyn ( MonoBinds(..) )
import HscTypes ( HscEnv(..), ModGuts(..), ModIface(..),
TyThing, Dependencies(..), TypeEnv, emptyTypeEnv,
ExternalPackageState(..), HomePackageTable,
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 )
tcg_exports = [],
tcg_imports = init_imports,
tcg_dus = emptyDUs,
- tcg_binds = EmptyMonoBinds,
+ tcg_binds = emptyBag,
tcg_deprecs = NoDeprecs,
tcg_insts = [],
tcg_rules = [],
} ;
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,
%************************************************************************
\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}
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)
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.
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}
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,
#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,
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 )
-- 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}
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
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
| 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
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")
#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 )
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 ->
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)
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(..),
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}
-- 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]
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}
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}
returnM (frees, binds)
else
simpl_loop givens' (irreds ++ frees) `thenM` \ (frees1, binds1) ->
- returnM (frees1, binds `AndMonoBinds` binds1)
+ returnM (frees1, binds `unionBags` binds1)
\end{code}
@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) ->
-- 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.
| 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 ]
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)
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!
-> 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
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
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
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 ->
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}
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}
--
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
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}
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
returnM binds
bomb_out = addTopAmbigErrs dicts `thenM_`
- returnM EmptyMonoBinds
+ returnM emptyBag
get_default_tys
= do { mb_defaults <- getDefaultTys
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
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]
-- 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 )
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 )
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}
%************************************************************************
\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)
%************************************************************************
\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 {
-- 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
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
-- 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 ->
let
-- simple_expr :: TH.Exp
- expr2 :: RdrNameHsExpr
+ expr2 :: LHsExpr RdrName
expr2 = convertToHsExpr simple_expr
in
traceTc (text "Got result" <+> ppr expr2) `thenM_`
-- 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
tcSimplifyTop lie `thenM` \ const_binds ->
-- And zonk it
- zonkTopExpr (mkHsLet const_binds expr')
+ zonkTopLExpr (mkHsLet const_binds expr')
\end{code}
%************************************************************************
\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
%************************************************************************
\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 "======>",
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}
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 )
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}
@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
-- 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
; 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
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}
-- 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
-- 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
res_kind kinded_tvs)
; thing_inside kinded_tvs }
-kindedTyVarKind (KindedTyVar _ k) = k
+kindedTyVarKind (L _ (KindedTyVar _ k)) = k
\end{code}
\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)) }
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')
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
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
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 ()
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
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))])
#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 )
import NameSet
import Digraph ( SCC(..), stronglyConnComp, stronglyConnCompR )
import BasicTypes ( RecFlag(..) )
+import SrcLoc ( Located(..) )
import Outputable
\end{code}
---------------------------------------- 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}
import HsSyn ( HsExpr(..) )
-import TcHsSyn ( mkHsLet,
+import TcHsSyn ( mkHsLet, mkHsDictLam,
ExprCoFn, idCoercion, isIdCoercion, mkCoercion, (<.>), (<$>) )
import TypeRep ( Type(..), PredType(..), TyNote(..), openKindCon, isSuperKind )
import VarEnv
import Name ( isSystemName )
import ErrUtils ( Message )
+import SrcLoc ( noLoc )
import BasicTypes ( Boxity, Arity, isBoxed )
import Util ( equalLength, lengthExceeds, notNull )
import Outputable
| 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
-- 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
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 )
import Id ( Id, idType )
import PrelNames
-import SrcLoc ( generatedSrcLoc )
+import SrcLoc ( srcLocSpan, noLoc, Located(..) )
import Util ( takeList )
+import Bag
import Outputable
import FastString
\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
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
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
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]
----------------------------------------------------
-- 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),
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
\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)
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
-- 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
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
-------------------
-- 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}
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}
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
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
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
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 -})
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
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"
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
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
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
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
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}
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}
%************************************************************************
\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}
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
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 }
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
projects / ghc-hetmet.git / commitdiff