Commit 3f885dcb authored by simonpj's avatar simonpj
Browse files

[project @ 2004-04-06 09:29:49 by simonpj]

The "rebindable-syntax" stuff wasn't dealing with the new location
information correctly.  This commit fixes the problem, and thereby
makes mdofail004 work right.  Maybe others too.
parent 09bdc279
......@@ -665,7 +665,7 @@ dsRecStmt m_ty ds_meths stmts later_vars rec_vars rec_rets
| otherwise = noLoc $ LazyPat (noLoc $ TuplePat (map nlVarPat vars) Boxed)
body = noLoc $ HsDo DoExpr (stmts ++ [return_stmt])
[(n, nlHsVar id) | (n,id) <- ds_meths] -- A bit of a hack
[(n, HsVar id) | (n,id) <- ds_meths] -- A bit of a hack
(mkAppTy m_ty tup_ty)
Var return_id = lookupReboundName ds_meths returnMName
......
......@@ -36,7 +36,7 @@ module DsUtils (
#include "HsVersions.h"
import {-# SOURCE #-} Match ( matchSimply )
import {-# SOURCE #-} DsExpr( dsLExpr )
import {-# SOURCE #-} DsExpr( dsExpr )
import HsSyn
import TcHsSyn ( hsPatType )
......@@ -95,9 +95,9 @@ dsReboundNames rebound_ids
where
-- The cheapo special case can happen when we
-- make an intermediate HsDo when desugaring a RecStmt
mk_bind (std_name, L _ (HsVar id)) = return ([], (std_name, id))
mk_bind (std_name, HsVar id) = return ([], (std_name, id))
mk_bind (std_name, expr)
= dsLExpr expr `thenDs` \ rhs ->
= dsExpr expr `thenDs` \ rhs ->
newSysLocalDs (exprType rhs) `thenDs` \ id ->
return ([NonRec id rhs], (std_name, id))
......
......@@ -222,7 +222,7 @@ Table of bindings of names used in rebindable syntax.
This gets filled in by the renamer.
\begin{code}
type ReboundNames id = [(Name, LHsExpr id)]
type ReboundNames id = [(Name, HsExpr id)]
-- * Before the renamer, this list is empty
--
-- * After the renamer, it takes the form [(std_name, HsVar actual_name)]
......
......@@ -499,9 +499,9 @@ lookupSyntaxNames std_names
-- Get the similarly named thing from the local environment
mappM (lookupOccRn . mkRdrUnqual . nameOccName) std_names `thenM` \ usr_names ->
returnM (std_names `zip` map nlHsVar usr_names, mkFVs usr_names)
returnM (std_names `zip` map HsVar usr_names, mkFVs usr_names)
where
normal_case = returnM (std_names `zip` map nlHsVar std_names, emptyFVs)
normal_case = returnM (std_names `zip` map HsVar std_names, emptyFVs)
\end{code}
......
......@@ -83,7 +83,7 @@ import TysWiredIn ( floatDataCon, doubleDataCon )
import PrelNames ( integerTyConName, fromIntegerName, fromRationalName, rationalTyConName )
import BasicTypes( IPName(..), mapIPName, ipNameName )
import UniqSupply( uniqsFromSupply )
import SrcLoc ( mkSrcSpan, noLoc, Located(..) )
import SrcLoc ( mkSrcSpan, noLoc, unLoc, Located(..) )
import CmdLineOpts( DynFlags, DynFlag( Opt_AllowUndecidableInstances ), dopt )
import Maybes ( isJust )
import Outputable
......@@ -393,10 +393,10 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
-- Reason: tcSyntaxName does unification
-- which is very inconvenient in tcSimplify
-- ToDo: noLoc sadness
= tcSyntaxName orig expected_ty (fromIntegerName, noLoc (HsVar fi)) `thenM` \ (_,expr) ->
mkIntegerLit i `thenM` \ integer_lit ->
returnM (mkHsApp expr integer_lit)
= tcSyntaxName orig expected_ty (fromIntegerName, HsVar fi) `thenM` \ (_,expr) ->
mkIntegerLit i `thenM` \ integer_lit ->
returnM (mkHsApp (noLoc expr) integer_lit)
-- The mkHsApp will get the loc from the literal
| Just expr <- shortCutIntLit i expected_ty
= returnM expr
......@@ -405,9 +405,10 @@ newOverloadedLit orig lit@(HsIntegral i fi) expected_ty
newOverloadedLit orig lit@(HsFractional r fr) expected_ty
| fr /= fromRationalName -- c.f. HsIntegral case
= tcSyntaxName orig expected_ty (fromRationalName, noLoc (HsVar fr)) `thenM` \ (_,expr) ->
mkRatLit r `thenM` \ rat_lit ->
returnM (mkHsApp expr rat_lit)
= tcSyntaxName orig expected_ty (fromRationalName, HsVar fr) `thenM` \ (_,expr) ->
mkRatLit r `thenM` \ rat_lit ->
returnM (mkHsApp (noLoc expr) rat_lit)
-- The mkHsApp will get the loc from the literal
| Just expr <- shortCutFracLit r expected_ty
= returnM expr
......@@ -805,41 +806,42 @@ just use the expression inline.
\begin{code}
tcSyntaxName :: InstOrigin
-> TcType -- Type to instantiate it at
-> (Name, LHsExpr Name) -- (Standard name, user name)
-> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
-> (Name, HsExpr Name) -- (Standard name, user name)
-> TcM (Name, HsExpr 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, L span (HsVar user_nm))
tcSyntaxName orig ty (std_nm, HsVar user_nm)
| std_nm == user_nm
= addSrcSpan span (tcStdSyntaxName orig ty std_nm)
= tcStdSyntaxName orig ty std_nm
tcSyntaxName orig ty (std_nm, user_nm_expr)
= tcLookupId std_nm `thenM` \ std_id ->
let
-- C.f. newMethodAtLoc
([tv], _, tau) = tcSplitSigmaTy (idType std_id)
tau1 = substTyWith [tv] [ty] tau
sigma1 = substTyWith [tv] [ty] tau
-- Actually, the "tau-type" might be a sigma-type in the
-- case of locally-polymorphic methods.
in
addErrCtxtM (syntaxNameCtxt user_nm_expr orig tau1) $
addErrCtxtM (syntaxNameCtxt user_nm_expr orig sigma1) $
-- Check that the user-supplied thing has the
-- same type as the standard one
tcCheckSigma user_nm_expr tau1 `thenM` \ expr ->
returnM (std_nm, expr)
-- same type as the standard one.
-- Tiresome jiggling because tcCheckSigma takes a located expression
getSrcSpanM `thenM` \ span ->
tcCheckSigma (L span user_nm_expr) sigma1 `thenM` \ expr ->
returnM (std_nm, unLoc expr)
tcStdSyntaxName :: InstOrigin
-> TcType -- Type to instantiate it at
-> Name -- Standard name
-> TcM (Name, LHsExpr TcId) -- (Standard name, suitable expression)
-> TcM (Name, HsExpr TcId) -- (Standard name, suitable expression)
tcStdSyntaxName orig ty std_nm
= newMethodFromName orig ty std_nm `thenM` \ id ->
getSrcSpanM `thenM` \ span ->
returnM (std_nm, L span (HsVar id))
returnM (std_nm, HsVar id)
syntaxNameCtxt name orig ty tidy_env
= getInstLoc orig `thenM` \ inst_loc ->
......
......@@ -566,7 +566,7 @@ zonkReboundNames :: ZonkEnv -> ReboundNames Id -> TcM (ReboundNames Id)
zonkReboundNames env prs
= mapM zonk prs
where
zonk (n, e) = zonkLExpr env e `thenM` \ new_e ->
zonk (n, e) = zonkExpr env e `thenM` \ new_e ->
returnM (n, new_e)
......
......@@ -38,7 +38,7 @@ import DataCon ( DataCon, dataConFieldLabels, dataConSourceArity )
import PrelNames ( eqStringName, eqName, geName, negateName, minusName,
integralClassName )
import BasicTypes ( isBoxed )
import SrcLoc ( Located(..), noLoc, unLoc )
import SrcLoc ( Located(..), noLoc, unLoc, noLoc )
import Bag
import Outputable
import FastString
......@@ -274,8 +274,8 @@ tc_pat tc_bndr pat@(NPatIn over_lit mb_neg) pat_ty
Nothing -> returnM pos_lit_expr -- Positive literal
Just neg -> -- Negative literal
-- The 'negate' is re-mappable syntax
tcSyntaxName origin pat_ty' (negateName, noLoc (HsVar neg)) `thenM` \ (_, neg_expr) ->
returnM (mkHsApp neg_expr pos_lit_expr)
tcSyntaxName origin pat_ty' (negateName, HsVar neg) `thenM` \ (_, neg_expr) ->
returnM (mkHsApp (noLoc neg_expr) pos_lit_expr)
) `thenM` \ lit_expr ->
let
......@@ -310,7 +310,7 @@ tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name)
newMethodFromName origin pat_ty' geName `thenM` \ ge ->
-- The '-' part is re-mappable syntax
tcSyntaxName origin pat_ty' (minusName, noLoc (HsVar minus_name)) `thenM` \ (_, minus_expr) ->
tcSyntaxName origin pat_ty' (minusName, 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?)
......@@ -319,8 +319,8 @@ tc_pat tc_bndr pat@(NPlusKPatIn (L nm_loc name) lit@(HsIntegral i _) minus_name)
extendLIEs dicts `thenM_`
returnM (NPlusKPatOut (L nm_loc bndr_id) i
(SectionR (nlHsVar ge) over_lit_expr)
(SectionR minus_expr over_lit_expr),
(SectionR (nlHsVar ge) over_lit_expr)
(SectionR (noLoc minus_expr) over_lit_expr),
emptyBag, unitBag (name, bndr_id), [])
where
origin = PatOrigin pat
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment