Commit 55042138 authored by simonmar's avatar simonmar

[project @ 2003-12-10 14:15:16 by simonmar]

Add accurate source location annotations to HsSyn
-------------------------------------------------

Every syntactic entity in HsSyn is now annotated with a SrcSpan, which
details the exact beginning and end points of that entity in the
original source file.  All honest compilers should do this, and it was
about time GHC did the right thing.

The most obvious benefit is that we now have much more accurate error
messages; when running GHC inside emacs for example, the cursor will
jump to the exact location of an error, not just a line somewhere
nearby.  We haven't put a huge amount of effort into making sure all
the error messages are accurate yet, so there could be some tweaking
still needed, although the majority of messages I've seen have been
spot-on.

Error messages now contain a column number in addition to the line
number, eg.

   read001.hs:25:10: Variable not in scope: `+#'

To get the full text span info, use the new option -ferror-spans.  eg.

   read001.hs:25:10-11: Variable not in scope: `+#'

I'm not sure whether we should do this by default.  Emacs won't
understand the new error format, for one thing.

In a more elaborate editor setting (eg. Visual Studio), we can arrange
to actually highlight the subexpression containing an error.  Eventually
this information will be used so we can find elements in the abstract
syntax corresponding to text locations, for performing high-level editor
functions (eg. "tell me the type of this expression I just highlighted").

Performance of the compiler doesn't seem to be adversely affected.
Parsing is still quicker than in 6.0.1, for example.

Implementation:

This was an excrutiatingly painful change to make: both Simon P.J. and
myself have been working on it for the last three weeks or so.  The
basic changes are:

 - a new datatype SrcSpan, which represents a beginning and end position
   in a source file.

 - To reduce the pain as much as possible, we also defined:

      data Located e = L SrcSpan e

 - Every datatype in HsSyn has an equivalent Located version.  eg.

      type LHsExpr id = Located (HsExpr id)

   and pretty much everywhere we used to use HsExpr we now use
   LHsExpr.  Believe me, we thought about this long and hard, and
   all the other options were worse :-)


Additional changes/cleanups we made at the same time:

  - The abstract syntax for bindings is now less arcane.  MonoBinds
    and HsBinds with their built-in list constructors have gone away,
    replaced by HsBindGroup and HsBind (see HsSyn/HsBinds.lhs).

  - The various HsSyn type synonyms have now gone away (eg. RdrNameHsExpr,
    RenamedHsExpr, and TypecheckedHsExpr are now HsExpr RdrName,
    HsExpr Name, and HsExpr Id respectively).

  - Utilities over HsSyn are now collected in a new module HsUtils.
    More stuff still needs to be moved in here.

  - MachChar now has a real Char instead of an Int.  All GHC versions that
    can compile GHC now support 32-bit Chars, so this was a simplification.
parent 60ea58ab
......@@ -52,6 +52,12 @@ name = Util.global (value) :: IORef (ty); \
{-# NOINLINE name #-}
#endif
#if __GLASGOW_HASKELL__ >= 620
#define UNBOX_FIELD !!
#else
#define UNBOX_FIELD !
#endif
#define COMMA ,
#ifdef DEBUG
......
......@@ -354,13 +354,13 @@ prelude/PrelRules_HC_OPTS = -fvia-C
main/ParsePkgConf_HC_OPTS += -fno-warn-incomplete-patterns
# Use -fvia-C since the NCG can't handle the narrow16Int# (and intToInt16#?)
# primops on all platforms.
parser/Parser_HC_OPTS += -Onot -fno-warn-incomplete-patterns -fvia-C
parser/Parser_HC_OPTS += -fno-warn-incomplete-patterns -fvia-C
# The latest GHC version doesn't have a -K option yet, and it doesn't
# seem to be necessary anymore for the modules below.
ifeq "$(compiling_with_4xx)" "YES"
parser/Parser_HC_OPTS += -K2m
endif
# Careful optimisation of the parser: we don't want to throw everything
# at it, because that takes too long and doesn't buy much, but we do want
# to inline certain key external functions, so we instruct GHC not to
# throw away inlinings as it would normally do in -Onot mode:
parser/Parser_HC_OPTS += -Onot -fno-ignore-interface-pragmas
ifeq "$(HOSTPLATFORM)" "hppa1.1-hp-hpux9"
rename/RnMonad_HC_OPTS = -O2 -O2-for-C
......@@ -368,6 +368,8 @@ endif
utils/Digraph_HC_OPTS = -fglasgow-exts
basicTypes/SrcLoc_HC_OPTS = -funbox-strict-fields
ifeq "$(bootstrapped)" "YES"
utils/Binary_HC_OPTS = -funbox-strict-fields
endif
......@@ -569,6 +571,9 @@ MAINTAINER_CLEAN_FILES += parser/Parser.info main/ParsePkgConf.info
MKDEPENDHS_SRCS =
MKDEPENDC_SRCS =
# Make doesn't work this out for itself, it seems
parser/Parser.y : parser/Parser.y.pp
include $(TOP)/mk/target.mk
# -----------------------------------------------------------------------------
......
......@@ -96,7 +96,7 @@ function applications, etc., etc., has not yet been done.
data Literal
= ------------------
-- First the primitive guys
MachChar Int -- Char# At least 31 bits
MachChar Char -- Char# At least 31 bits
| MachStr FastString
| MachNullAddr -- the NULL pointer, the only pointer value
......@@ -211,8 +211,8 @@ inIntRange, inWordRange :: Integer -> Bool
inIntRange x = x >= tARGET_MIN_INT && x <= tARGET_MAX_INT
inWordRange x = x >= 0 && x <= tARGET_MAX_WORD
inCharRange :: Int -> Bool
inCharRange c = c >= 0 && c <= tARGET_MAX_CHAR
inCharRange :: Char -> Bool
inCharRange c = c >= '\0' && c <= chr tARGET_MAX_CHAR
isZeroLit :: Literal -> Bool
isZeroLit (MachInt 0) = True
......@@ -250,8 +250,8 @@ narrow8WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word8))
narrow16WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word16))
narrow32WordLit (MachWord w) = MachWord (toInteger (fromInteger w :: Word32))
char2IntLit (MachChar c) = MachInt (toInteger c)
int2CharLit (MachInt i) = MachChar (fromInteger i)
char2IntLit (MachChar c) = MachInt (toInteger (ord c))
int2CharLit (MachInt i) = MachChar (chr (fromInteger i))
float2IntLit (MachFloat f) = MachInt (truncate f)
int2FloatLit (MachInt i) = MachFloat (fromInteger i)
......@@ -366,7 +366,7 @@ pprLit lit
code_style = codeStyle sty
in
case lit of
MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show ch)]
MachChar ch | code_style -> hcat [ptext SLIT("(C_)"), text (show (ord ch))]
| otherwise -> pprHsChar ch
MachStr s | code_style -> pprFSInCStyle s
......@@ -439,7 +439,7 @@ Hash values should be zero or a positive integer. No negatives please.
\begin{code}
hashLiteral :: Literal -> Int
hashLiteral (MachChar c) = c + 1000 -- Keep it out of range of common ints
hashLiteral (MachChar c) = ord c + 1000 -- Keep it out of range of common ints
hashLiteral (MachStr s) = hashFS s
hashLiteral (MachNullAddr) = 0
hashLiteral (MachInt i) = hashInteger i
......
......@@ -51,7 +51,7 @@ import Module ( ModuleName, mkSysModuleNameFS, mkModuleNameFS )
import Name ( Name, NamedThing(getName), nameModuleName, nameParent_maybe,
nameOccName, isExternalName, nameSrcLoc )
import Maybes ( seqMaybe )
import SrcLoc ( SrcLoc, isGoodSrcLoc )
import SrcLoc ( SrcLoc, isGoodSrcLoc, SrcSpan )
import BasicTypes( DeprecTxt )
import Outputable
import Util ( thenCmp )
......@@ -433,7 +433,7 @@ data ImportSpec -- Describes a particular import declaration
-- the defining module for this thing!
is_as :: ModuleName, -- 'as M' (or 'Muggle' if there is no 'as' clause)
is_qual :: Bool, -- True <=> qualified (only)
is_loc :: SrcLoc } -- Location of import statment
is_loc :: SrcSpan } -- Location of import statment
-- Comparison of provenance is just used for grouping
-- error messages (in RnEnv.warnUnusedBinds)
......
This diff is collapsed.
......@@ -51,6 +51,7 @@ import Util
import Outputable
import List ( partition )
import Char ( ord )
\end{code}
%************************************************************************
......@@ -172,7 +173,8 @@ buildDynCon binder cc con [arg_amode]
| maybeCharLikeCon con && in_range_char_lit arg_amode
= returnFC (stableAmodeIdInfo binder (CCharLike arg_amode) (mkConLFInfo con))
where
in_range_char_lit (CLit (MachChar val)) = val <= mAX_CHARLIKE && val >= mIN_CHARLIKE
in_range_char_lit (CLit (MachChar val)) =
ord val <= mAX_CHARLIKE && ord val >= mIN_CHARLIKE
in_range_char_lit _other_amode = False
\end{code}
......
......@@ -25,8 +25,8 @@ import Subst ( substTyWith )
import Name ( getSrcLoc )
import PprCore
import ErrUtils ( dumpIfSet_core, ghcExit, Message, showPass,
addErrLocHdrLine )
import SrcLoc ( SrcLoc, noSrcLoc )
mkLocMessage )
import SrcLoc ( SrcLoc, noSrcLoc, mkSrcSpan )
import Type ( Type, tyVarsOfType, eqType,
splitFunTy_maybe, mkTyVarTy,
splitForAllTy_maybe, splitTyConApp_maybe, splitTyConApp,
......@@ -521,7 +521,7 @@ addErr errs_so_far msg locs
context | opt_PprStyle_Debug = vcat (reverse cxts) $$ cxt1
| otherwise = cxt1
mk_msg msg = addErrLocHdrLine loc context msg
mk_msg msg = mkLocMessage (mkSrcSpan loc loc) (context $$ msg)
addLoc :: LintLocInfo -> LintM a -> LintM a
addLoc extra_loc m loc scope errs
......
......@@ -164,9 +164,7 @@ make_alt (DEFAULT,[],e) = C.Adefault (make_exp e)
make_lit :: Literal -> C.Lit
make_lit l =
case l of
MachChar i | i <= 0xff -> C.Lchar (chr i) t
MachChar i | otherwise -> C.Lint (toEnum i) t
-- For big characters, use an integer literal with a character type sig
MachChar i -> C.Lchar i t
MachStr s -> C.Lstring (unpackFS s) t
MachNullAddr -> C.Lint 0 t
MachInt i -> C.Lint i t
......
This diff is collapsed.
......@@ -12,9 +12,8 @@ import CmdLineOpts ( DynFlag(..), dopt, opt_SccProfilingOn )
import HscTypes ( ModGuts(..), ModGuts, HscEnv(..), GhciMode(..),
Dependencies(..), TypeEnv,
unQualInScope, availsToNameSet )
import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
HsExpr(..), HsBinds(..), MonoBinds(..) )
import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr )
import HsSyn ( RuleDecl(..), RuleBndr(..), HsExpr(..), LHsExpr,
HsBindGroup(..), LRuleDecl, HsBind(..) )
import TcRnTypes ( TcGblEnv(..), ImportAvails(..) )
import MkIface ( mkUsageInfo )
import Id ( Id, setIdLocalExported, idName )
......@@ -23,8 +22,8 @@ import CoreSyn
import PprCore ( pprIdRules, pprCoreExpr )
import Subst ( substExpr, mkSubst, mkInScopeSet )
import DsMonad
import DsExpr ( dsExpr )
import DsBinds ( dsMonoBinds, AutoScc(..) )
import DsExpr ( dsLExpr )
import DsBinds ( dsHsBinds, AutoScc(..) )
import DsForeign ( dsForeigns )
import DsExpr () -- Forces DsExpr to be compiled; DsBinds only
-- depends on DsExpr.hi-boot.
......@@ -34,15 +33,15 @@ import RdrName ( GlobalRdrEnv )
import NameSet
import VarEnv
import VarSet
import Bag ( isEmptyBag, mapBag, emptyBag )
import Bag ( isEmptyBag, mapBag, emptyBag, bagToList )
import CoreLint ( showPass, endPass )
import CoreFVs ( ruleRhsFreeVars )
import ErrUtils ( doIfSet, dumpIfSet_dyn, pprBagOfWarnings,
addShortWarnLocLine, errorsFound )
mkWarnMsg, errorsFound, WarnMsg )
import Outputable
import qualified Pretty
import UniqSupply ( mkSplitUniqSupply )
import SrcLoc ( SrcLoc )
import SrcLoc ( Located(..), SrcSpan, unLoc )
import DATA_IOREF ( readIORef )
import FastString
\end{code}
......@@ -127,13 +126,13 @@ deSugar hsc_env
-- Desugarer warnings are SDocs; here we
-- add the info about whether or not to print unqualified
mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
mk_warn (loc, sdoc) = addShortWarnLocLine loc print_unqual sdoc
mk_warn :: (SrcSpan,SDoc) -> WarnMsg
mk_warn (loc, sdoc) = mkWarnMsg loc print_unqual sdoc
deSugarExpr :: HscEnv
-> Module -> GlobalRdrEnv -> TypeEnv
-> TypecheckedHsExpr
-> LHsExpr Id
-> IO CoreExpr
deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
= do { showPass dflags "Desugar"
......@@ -143,7 +142,7 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
; let { is_boot = emptyModuleEnv } -- Assume no hi-boot files when
-- doing stuff from the command line
; (core_expr, ds_warns) <- initDs hsc_env this_mod type_env is_boot $
dsExpr tc_expr
dsLExpr tc_expr
-- Display any warnings
-- Note: if -Werror is used, we don't signal an error here.
......@@ -159,8 +158,8 @@ deSugarExpr hsc_env this_mod rdr_env type_env tc_expr
dflags = hsc_dflags hsc_env
print_unqual = unQualInScope rdr_env
mk_warn :: (SrcLoc,SDoc) -> (SrcLoc, Pretty.Doc)
mk_warn (loc,sdoc) = addShortWarnLocLine loc print_unqual sdoc
mk_warn :: (SrcSpan,SDoc) -> WarnMsg
mk_warn (loc,sdoc) = mkWarnMsg loc print_unqual sdoc
dsProgram ghci_mode (TcGblEnv { tcg_exports = exports,
......@@ -168,7 +167,7 @@ dsProgram ghci_mode (TcGblEnv { tcg_exports = exports,
tcg_binds = binds,
tcg_fords = fords,
tcg_rules = rules })
= dsMonoBinds auto_scc binds [] `thenDs` \ core_prs ->
= dsHsBinds auto_scc binds [] `thenDs` \ core_prs ->
dsForeigns fords `thenDs` \ (ds_fords, foreign_prs) ->
let
all_prs = foreign_prs ++ core_prs
......@@ -254,24 +253,25 @@ ppr_ds_rules rules
%************************************************************************
\begin{code}
dsRule :: IdSet -> TypecheckedRuleDecl -> DsM (Id, CoreRule)
dsRule in_scope (HsRule name act vars lhs rhs loc)
= putSrcLocDs loc $
dsRule :: IdSet -> LRuleDecl Id -> DsM (Id, CoreRule)
dsRule in_scope (L loc (HsRule name act vars lhs rhs))
= putSrcSpanDs loc $
ds_lhs all_vars lhs `thenDs` \ (fn, args) ->
dsExpr rhs `thenDs` \ core_rhs ->
dsLExpr rhs `thenDs` \ core_rhs ->
returnDs (fn, Rule name act tpl_vars args core_rhs)
where
tpl_vars = [var | RuleBndr var <- vars]
tpl_vars = [var | RuleBndr (L _ var) <- vars]
all_vars = mkInScopeSet (in_scope `unionVarSet` mkVarSet tpl_vars)
ds_lhs all_vars lhs
= let
(dict_binds, body) = case lhs of
(HsLet (MonoBind dict_binds _ _) body) -> (dict_binds, body)
other -> (EmptyMonoBinds, lhs)
(dict_binds, body) =
case unLoc lhs of
(HsLet [HsBindGroup dict_binds _ _] body) -> (dict_binds, body)
other -> (emptyBag, lhs)
in
ds_dict_binds dict_binds `thenDs` \ dict_binds' ->
dsExpr body `thenDs` \ body' ->
mappM ds_dict_bind (bagToList dict_binds) `thenDs` \ dict_binds' ->
dsLExpr body `thenDs` \ body' ->
-- Substitute the dict bindings eagerly,
-- and take the body apart into a (f args) form
......@@ -293,10 +293,7 @@ ds_lhs all_vars lhs
in
returnDs pair
ds_dict_binds EmptyMonoBinds = returnDs []
ds_dict_binds (AndMonoBinds b1 b2) = ds_dict_binds b1 `thenDs` \ env1 ->
ds_dict_binds b2 `thenDs` \ env2 ->
returnDs (env1 ++ env2)
ds_dict_binds (VarMonoBind id rhs) = dsExpr rhs `thenDs` \ rhs' ->
returnDs [(id,rhs')]
ds_dict_bind (L _ (VarBind id rhs)) =
dsLExpr rhs `thenDs` \ rhs' ->
returnDs (id,rhs')
\end{code}
This diff is collapsed.
......@@ -8,12 +8,12 @@ in that the @Rec@/@NonRec@/etc structure is thrown away (whereas at
lower levels it is preserved with @let@/@letrec@s).
\begin{code}
module DsBinds ( dsMonoBinds, AutoScc(..) ) where
module DsBinds ( dsHsBinds, AutoScc(..) ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr( dsExpr )
import {-# SOURCE #-} DsExpr( dsLExpr )
import DsMonad
import DsGRHSs ( dsGuarded )
import DsUtils
......@@ -21,7 +21,6 @@ import DsUtils
import HsSyn -- lots of things
import CoreSyn -- lots of things
import CoreUtils ( exprType, mkInlineMe, mkSCC )
import TcHsSyn ( TypecheckedMonoBinds )
import Match ( matchWrapper )
import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_AutoSccsOnExportedToplevs )
......@@ -33,7 +32,11 @@ import TcType ( mkTyVarTy )
import Subst ( substTyWith )
import TysWiredIn ( voidTy )
import Outputable
import SrcLoc ( Located(..) )
import Maybe ( isJust )
import Bag ( Bag, bagToList )
import Monad ( foldM )
\end{code}
%************************************************************************
......@@ -43,19 +46,28 @@ import Maybe ( isJust )
%************************************************************************
\begin{code}
dsMonoBinds :: AutoScc -- scc annotation policy (see below)
-> TypecheckedMonoBinds
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> DsM [(Id,CoreExpr)] -- Result
dsHsBinds :: AutoScc -- scc annotation policy (see below)
-> Bag (LHsBind Id)
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> DsM [(Id,CoreExpr)] -- Result
dsHsBinds auto_scc binds rest =
foldM (dsLHsBind auto_scc) rest (bagToList binds)
dsMonoBinds _ EmptyMonoBinds rest = returnDs rest
dsLHsBind :: AutoScc
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> LHsBind Id
-> DsM [(Id,CoreExpr)] -- Result
dsLHsBind auto_scc rest (L loc bind)
= putSrcSpanDs loc $ dsHsBind auto_scc rest bind
dsMonoBinds auto_scc (AndMonoBinds binds_1 binds_2) rest
= dsMonoBinds auto_scc binds_2 rest `thenDs` \ rest' ->
dsMonoBinds auto_scc binds_1 rest'
dsHsBind :: AutoScc
-> [(Id,CoreExpr)] -- Put this on the end (avoid quadratic append)
-> HsBind Id
-> DsM [(Id,CoreExpr)] -- Result
dsMonoBinds _ (VarMonoBind var expr) rest
= dsExpr expr `thenDs` \ core_expr ->
dsHsBind auto_scc rest (VarBind var expr)
= dsLExpr expr `thenDs` \ core_expr ->
-- Dictionary bindings are always VarMonoBinds, so
-- we only need do this here
......@@ -73,15 +85,13 @@ dsMonoBinds _ (VarMonoBind var expr) rest
returnDs ((var, core_expr'') : rest)
dsMonoBinds auto_scc (FunMonoBind fun _ matches locn) rest
= putSrcLocDs locn $
matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
dsHsBind auto_scc rest (FunBind (L _ fun) _ matches)
= matchWrapper (FunRhs (idName fun)) matches `thenDs` \ (args, body) ->
addAutoScc auto_scc (fun, mkLams args body) `thenDs` \ pair ->
returnDs (pair : rest)
dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
= putSrcLocDs locn $
dsGuarded grhss `thenDs` \ body_expr ->
dsHsBind auto_scc rest (PatBind pat grhss)
= dsGuarded grhss `thenDs` \ body_expr ->
mkSelectorBinds pat body_expr `thenDs` \ sel_binds ->
mappM (addAutoScc auto_scc) sel_binds `thenDs` \ sel_binds ->
returnDs (sel_binds ++ rest)
......@@ -90,9 +100,9 @@ dsMonoBinds auto_scc (PatMonoBind pat grhss locn) rest
-- For the (rare) case when there are some mixed-up
-- dictionary bindings (for which a Rec is convenient)
-- we reply on the enclosing dsBind to wrap a Rec around.
dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
dsHsBind auto_scc rest (AbsBinds [] [] exports inlines binds)
= dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
core_prs' = addLocalInlines exports inlines core_prs
exports' = [(global, Var local) | (_, global, local) <- exports]
in
......@@ -100,10 +110,10 @@ dsMonoBinds auto_scc (AbsBinds [] [] exports inlines binds) rest
-- Another common case: one exported variable
-- Non-recursive bindings come through this way
dsMonoBinds auto_scc
(AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds) rest
dsHsBind auto_scc rest
(AbsBinds all_tyvars dicts exps@[(tyvars, global, local)] inlines binds)
= ASSERT( all (`elem` tyvars) all_tyvars )
dsMonoBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs ->
dsHsBinds (addSccs auto_scc exps) binds [] `thenDs` \ core_prs ->
let
-- Always treat the binds as recursive, because the typechecker
-- makes rather mixed-up dictionary bindings
......@@ -117,8 +127,8 @@ dsMonoBinds auto_scc
in
returnDs (export' : rest)
dsMonoBinds auto_scc (AbsBinds all_tyvars dicts exports inlines binds) rest
= dsMonoBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
dsHsBind auto_scc rest (AbsBinds all_tyvars dicts exports inlines binds)
= dsHsBinds (addSccs auto_scc exports) binds []`thenDs` \ core_prs ->
let
-- Rec because of mixed-up dictionary bindings
core_bind = Rec (addLocalInlines exports inlines core_prs)
......
......@@ -238,7 +238,7 @@ unboxArg arg
])
| otherwise
= getSrcLocDs `thenDs` \ l ->
= getSrcSpanDs `thenDs` \ l ->
pprPanic "unboxArg: " (ppr l <+> ppr arg_ty)
where
arg_ty = exprType arg
......
__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
This diff is collapsed.
......@@ -16,9 +16,8 @@ import CoreSyn
import DsCCall ( dsCCall, mkFCall, boxResult, unboxArg, resultWrapper )
import DsMonad
import HsSyn ( ForeignDecl(..), ForeignExport(..),
import HsSyn ( ForeignDecl(..), ForeignExport(..), LForeignDecl,
ForeignImport(..), CImportSpec(..) )
import TcHsSyn ( TypecheckedForeignDecl )
import CoreUtils ( exprType, mkInlineMe )
import Id ( Id, idType, idName, mkSysLocal, setInlinePragma )
import Literal ( Literal(..) )
......@@ -46,6 +45,7 @@ import PrimRep ( getPrimRepSizeInBytes )
import PrelNames ( hasKey, ioTyConKey, stablePtrTyConName, newStablePtrName, bindIOName,
checkDotnetResName )
import BasicTypes ( Activation( NeverActive ) )
import SrcLoc ( Located(..), unLoc )
import Outputable
import Maybe ( fromJust )
import FastString
......@@ -68,7 +68,7 @@ so we reuse the desugaring code in @DsCCall@ to deal with these.
type Binding = (Id, CoreExpr) -- No rec/nonrec structure;
-- the occurrence analyser will sort it all out
dsForeigns :: [TypecheckedForeignDecl]
dsForeigns :: [LForeignDecl Id]
-> DsM (ForeignStubs, [Binding])
dsForeigns []
= returnDs (NoStubs, [])
......@@ -76,9 +76,9 @@ dsForeigns fos
= foldlDs combine (ForeignStubs empty empty [] [], []) fos
where
combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignImport id _ spec depr loc)
(L loc (ForeignImport id _ spec depr))
= traceIf (text "fi start" <+> ppr id) `thenDs` \ _ ->
dsFImport id spec `thenDs` \ (bs, h, c, mbhd) ->
dsFImport (unLoc id) spec `thenDs` \ (bs, h, c, mbhd) ->
warnDepr depr loc `thenDs` \ _ ->
traceIf (text "fi end" <+> ppr id) `thenDs` \ _ ->
returnDs (ForeignStubs (h $$ acc_h)
......@@ -88,7 +88,7 @@ dsForeigns fos
bs ++ acc_f)
combine (ForeignStubs acc_h acc_c acc_hdrs acc_feb, acc_f)
(ForeignExport id _ (CExport (CExportStatic ext_nm cconv)) depr loc)
(L loc (ForeignExport (L _ id) _ (CExport (CExportStatic ext_nm cconv)) depr))
= dsFExport id (idType id)
ext_nm cconv False `thenDs` \(h, c, _) ->
warnDepr depr loc `thenDs` \_ ->
......
......@@ -8,13 +8,14 @@ module DsGRHSs ( dsGuarded, dsGRHSs ) where
#include "HsVersions.h"
import {-# SOURCE #-} DsExpr ( dsExpr, dsLet )
import {-# SOURCE #-} DsExpr ( dsLExpr, dsLet )
import {-# SOURCE #-} Match ( matchSinglePat )
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..), HsMatchContext(..) )
import TcHsSyn ( TypecheckedGRHSs, TypecheckedPat, TypecheckedStmt, TypecheckedMatchContext )
import HsSyn ( Stmt(..), HsExpr(..), GRHSs(..), GRHS(..),
HsMatchContext(..), Pat(..), LStmt )
import CoreSyn ( CoreExpr )
import Type ( Type )
import Var ( Id )
import DsMonad
import DsUtils
......@@ -22,6 +23,8 @@ import Unique ( Uniquable(..) )
import PrelInfo ( nON_EXHAUSTIVE_GUARDS_ERROR_ID )
import TysWiredIn ( trueDataConId )
import PrelNames ( otherwiseIdKey, hasKey )
import Name ( Name )
import SrcLoc ( unLoc, Located(..) )
\end{code}
@dsGuarded@ is used for both @case@ expressions and pattern bindings.
......@@ -36,7 +39,7 @@ producing an expression with a runtime error in the corner if
necessary. The type argument gives the type of the @ei@.
\begin{code}
dsGuarded :: TypecheckedGRHSs -> DsM CoreExpr
dsGuarded :: GRHSs Id -> DsM CoreExpr
dsGuarded grhss
= dsGRHSs PatBindRhs [] grhss `thenDs` \ (err_ty, match_result) ->
......@@ -47,8 +50,8 @@ dsGuarded grhss
In contrast, @dsGRHSs@ produces a @MatchResult@.
\begin{code}
dsGRHSs :: TypecheckedMatchContext -> [TypecheckedPat] -- These are to build a MatchContext from
-> TypecheckedGRHSs -- Guarded RHSs
dsGRHSs :: HsMatchContext Name -> [Pat Id] -- These are to build a MatchContext from
-> GRHSs Id -- Guarded RHSs
-> DsM (Type, MatchResult)
dsGRHSs kind pats (GRHSs grhss binds ty)
......@@ -60,8 +63,8 @@ dsGRHSs kind pats (GRHSs grhss binds ty)
in
returnDs (ty, match_result2)
dsGRHS kind pats (GRHS guard locn)
= matchGuard guard (DsMatchContext kind pats locn)
dsGRHS kind pats (L loc (GRHS guard))
= matchGuard (map unLoc guard) (DsMatchContext kind pats loc)
\end{code}
......@@ -72,29 +75,29 @@ dsGRHS kind pats (GRHS guard locn)
%************************************************************************
\begin{code}
matchGuard :: [TypecheckedStmt] -- Guard
matchGuard :: [Stmt Id] -- Guard
-> DsMatchContext -- Context
-> DsM MatchResult
-- See comments with HsExpr.Stmt re what an ExprStmt means
-- Here we must be in a guard context (not do-expression, nor list-comp)
matchGuard [ResultStmt expr locn] ctx
= putSrcLocDs locn (dsExpr expr) `thenDs` \ core_expr ->
matchGuard [ResultStmt expr] ctx
= dsLExpr expr `thenDs` \ core_expr ->
returnDs (cantFailMatchResult core_expr)
-- ExprStmts must be guards
-- Turn an "otherwise" guard is a no-op
matchGuard (ExprStmt (HsVar v) _ _ : stmts) ctx
matchGuard (ExprStmt (L _ (HsVar v)) _ : stmts) ctx
| v `hasKey` otherwiseIdKey
|| v `hasKey` getUnique trueDataConId
-- trueDataConId doesn't have the same
-- unique as trueDataCon
= matchGuard stmts ctx
matchGuard (ExprStmt expr _ locn : stmts) ctx
= matchGuard stmts ctx `thenDs` \ match_result ->
putSrcLocDs locn (dsExpr expr) `thenDs` \ pred_expr ->
matchGuard (ExprStmt expr _ : stmts) ctx
= matchGuard stmts ctx `thenDs` \ match_result ->
dsLExpr expr `thenDs` \ pred_expr ->
returnDs (mkGuardedMatchResult pred_expr match_result)
matchGuard (LetStmt binds : stmts) ctx
......@@ -102,9 +105,9 @@ matchGuard (LetStmt binds : stmts) ctx
returnDs (adjustMatchResultDs (dsLet binds) match_result)
-- NB the dsLet occurs inside the match_result
matchGuard (BindStmt pat rhs locn : stmts) ctx
matchGuard (BindStmt pat rhs : stmts) ctx
= matchGuard stmts ctx `thenDs` \ match_result ->
putSrcLocDs locn (dsExpr rhs) `thenDs` \ core_rhs ->
dsLExpr rhs `thenDs` \ core_rhs ->
matchSinglePat core_rhs ctx pat match_result
\end{code}
......
This diff is collapsed.
This diff is collapsed.
......@@ -11,7 +11,7 @@ module DsMonad (
newTyVarsDs,
duplicateLocalDs, newSysLocalDs, newSysLocalsDs, newUniqueId,
newFailLocalDs,
getSrcLocDs, putSrcLocDs,
getSrcSpanDs, putSrcSpanDs,
getModuleDs,
newUnique,
UniqSupply, newUniqueSupply,
......@@ -27,8 +27,8 @@ module DsMonad (
#include "HsVersions.h"
import TcHsSyn ( TypecheckedPat, TypecheckedMatchContext, TypecheckedHsExpr )
import TcRnMonad
import HsSyn ( HsExpr, HsMatchContext, Pat )
import IfaceEnv ( tcIfaceGlobal )
import HscTypes ( TyThing(..), TypeEnv, HscEnv,
IsBootInterface,
......@@ -41,7 +41,7 @@ import Id ( mkSysLocal, setIdUnique, Id )
import Module ( Module, ModuleName, ModuleEnv )
import Var ( TyVar, setTyVarUnique )
import Outputable
import SrcLoc ( noSrcLoc, SrcLoc )
import SrcLoc ( noSrcSpan, SrcSpan )
import Type ( Type )
import UniqSupply ( UniqSupply, uniqsFromSupply )
import Name ( Name, nameOccName )
......@@ -69,7 +69,10 @@ foldlDs = foldlM
mapAndUnzipDs = mapAndUnzipM
type DsWarning = (SrcLoc, SDoc)
type DsWarning = (SrcSpan, SDoc)
-- Not quite the same as a WarnMsg, we have an SDoc here
-- and we'll do the print_unqual stuff later on to turn it
-- into a Doc.
data DsGblEnv = DsGblEnv {
ds_mod :: Module, -- For SCC profiling
......@@ -80,7 +83,7 @@ data DsGblEnv = DsGblEnv {
data DsLclEnv = DsLclEnv {
ds_meta :: DsMetaEnv, -- Template Haskell bindings
ds_loc :: SrcLoc -- to put in pattern-matching error msgs
ds_loc :: SrcSpan -- to put in pattern-matching error msgs
}
-- Inside [| |] brackets, the desugarer looks
......@@ -92,8 +95,8 @@ data DsMetaVal
-- Will be dynamically alpha renamed.
-- The Id has type THSyntax.Var
| Splice TypecheckedHsExpr -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
| Splice (HsExpr Id) -- These bindings are introduced by
-- the PendingSplices on a HsBracketOut
-- initDs returns the UniqSupply out the end (not just the result)
......@@ -111,7 +114,7 @@ initDs hsc_env mod type_env is_boot thing_inside
ds_if_env = if_env,
ds_warns = warn_var }
; lcl_env = DsLclEnv { ds_meta = emptyNameEnv,
ds_loc = noSrcLoc } }
ds_loc = noSrcSpan } }
; res <- initTcRnIf 'd' hsc_env gbl_env lcl_env thing_inside
......@@ -158,7 +161,7 @@ newTyVarsDs tyvar_tmpls
\end{code}
We can also reach out and either set/grab location information from
the @SrcLoc@ being carried around.
the @SrcSpan@ being carried around.
\begin{code}
getDOptsDs :: DsM DynFlags
......@@ -167,11 +170,11 @@ getDOptsDs = getDOpts
getModuleDs :: DsM Module
getModuleDs = do { env <- getGblEnv; return (ds_mod env) }
getSrcLocDs :: DsM SrcLoc
getSrcLocDs = do { env <- getLclEnv; return (ds_loc env) }
getSrcSpanDs :: DsM SrcSpan
getSrcSpanDs = do { env <- getLclEnv; return (ds_loc env) }
putSrcLocDs :: SrcLoc -> DsM a -> DsM a
putSrcLocDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
putSrcSpanDs :: SrcSpan -> DsM a -> DsM a
putSrcSpanDs new_loc thing_inside = updLclEnv (\ env -> env {ds_loc = new_loc}) thing_inside
dsWarn :: DsWarning -> DsM ()
dsWarn (loc,warn) = do { env <- getGblEnv; updMutVar (ds_warns env) (`snocBag` (loc,msg)) }
......@@ -221,7 +224,7 @@ dsExtendMetaEnv menv thing_inside
\begin{code}
data DsMatchContext
= DsMatchContext TypecheckedMatchContext [TypecheckedPat] SrcLoc
= DsMatchContext (HsMatchContext Name) [Pat Id] SrcSpan