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)
......
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
% (c) The University of Glasgow, 1992-2003
%
%************************************************************************
%* *
......@@ -23,16 +23,27 @@ module SrcLoc (
srcLocFile, -- return the file name part
srcLocLine, -- return the line part
srcLocCol, -- return the column part
SrcSpan, -- Abstract
noSrcSpan,
mkGeneralSrcSpan,
isGoodSrcSpan,
mkSrcSpan, srcLocSpan,
combineSrcSpans,
srcSpanFile,
srcSpanStartLine, srcSpanEndLine,
srcSpanStartCol, srcSpanEndCol,
srcSpanStart, srcSpanEnd,
Located(..), getLoc, unLoc, noLoc, eqLocated, cmpLocated, combineLocs, addCLoc
) where
#include "HsVersions.h"
import Util ( thenCmp )
import Outputable
import FastTypes
import FastString
import GLAEXTS ( (+#), quotInt# )
\end{code}
%************************************************************************
......@@ -46,8 +57,10 @@ this is the obvious stuff:
\begin{code}
data SrcLoc
= SrcLoc FastString -- A precise location (file name)
FastInt -- line
FastInt -- column
!Int -- line number, begins at 1
!Int -- column number, begins at 0
-- Don't ask me why lines start at 1 and columns start at
-- zero. That's just the way it is, so there. --SDM
| ImportedLoc String -- Module name
......@@ -81,8 +94,8 @@ rare case.
Things to make 'em:
\begin{code}
mkSrcLoc x line col = SrcLoc x (iUnbox line) (iUnbox col)
noSrcLoc = UnhelpfulLoc FSLIT("<no locn>")
mkSrcLoc x line col = SrcLoc x line col
noSrcLoc = UnhelpfulLoc FSLIT("<no location info>")
generatedSrcLoc = UnhelpfulLoc FSLIT("<compiler-generated code>")
wiredInSrcLoc = UnhelpfulLoc FSLIT("<wired into compiler>")
interactiveSrcLoc = UnhelpfulLoc FSLIT("<interactive session>")
......@@ -101,22 +114,22 @@ srcLocFile (SrcLoc fname _ _) = fname
srcLocFile other = FSLIT("<unknown file")
srcLocLine :: SrcLoc -> Int
srcLocLine (SrcLoc _ l c) = iBox l
srcLocLine (SrcLoc _ l c) = l
srcLocLine other = panic "srcLocLine: unknown line"
srcLocCol :: SrcLoc -> Int
srcLocCol (SrcLoc _ l c) = iBox c
srcLocCol (SrcLoc _ l c) = c
srcLocCol other = panic "srcLocCol: unknown col"
advanceSrcLoc :: SrcLoc -> Char -> SrcLoc
advanceSrcLoc (SrcLoc f l c) '\t' = SrcLoc f l (tab c)
advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l +# 1#) 0#
advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c +# 1#)
advanceSrcLoc (SrcLoc f l c) '\n' = SrcLoc f (l + 1) 0
advanceSrcLoc (SrcLoc f l c) _ = SrcLoc f l (c + 1)
advanceSrcLoc loc _ = loc -- Better than nothing
-- Advance to the next tab stop. Tabs are at column positions 0, 8, 16, etc.
tab :: FastInt -> FastInt
tab c = (c `quotInt#` 8# +# 1#) *# 8#
tab :: Int -> Int
tab c = (c `quot` 8 + 1) * 8
\end{code}
%************************************************************************
......@@ -145,8 +158,8 @@ cmpSrcLoc (ImportedLoc _) other = LT
cmpSrcLoc (SrcLoc s1 l1 c1) (SrcLoc s2 l2 c2)
= (s1 `compare` s2) `thenCmp` (l1 `cmpline` l2) `thenCmp` (c1 `cmpline` c2)
where
l1 `cmpline` l2 | l1 <# l2 = LT
| l1 ==# l2 = EQ
l1 `cmpline` l2 | l1 < l2 = LT
| l1 == l2 = EQ
| otherwise = GT
cmpSrcLoc (SrcLoc _ _ _) other = GT
......@@ -155,13 +168,228 @@ instance Outputable SrcLoc where
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
hcat [ ftext src_path, char ':',
int (iBox src_line)
{- TODO: char ':', int (iBox src_col) -}
int src_line,
char ':', int src_col
]
else
hcat [text "{-# LINE ", int (iBox src_line), space,
hcat [text "{-# LINE ", int src_line, space,
char '\"', ftext src_path, text " #-}"]
ppr (ImportedLoc mod) = ptext SLIT("Imported from") <+> quotes (text mod)
ppr (UnhelpfulLoc s) = ftext s
\end{code}
%************************************************************************
%* *
\subsection[SrcSpan]{Source Spans}
%* *
%************************************************************************
\begin{code}
{- |
A SrcSpan delimits a portion of a text file. It could be represented
by a pair of (line,column) coordinates, but in fact we optimise
slightly by using more compact representations for single-line and
zero-length spans, both of which are quite common.
The end position is defined to be the column *after* the end of the
span. That is, a span of (1,1)-(1,2) is one character long, and a
span of (1,1)-(1,1) is zero characters long.
-}
data SrcSpan
= SrcSpanOneLine -- a common case: a single line
{ srcSpanFile :: FastString,
srcSpanLine :: !Int,
srcSpanSCol :: !Int,
srcSpanECol :: !Int
}
| SrcSpanMultiLine
{ srcSpanFile :: FastString,
srcSpanSLine :: !Int,
srcSpanSCol :: !Int,
srcSpanELine :: !Int,
srcSpanECol :: !Int
}
| SrcSpanPoint
{ srcSpanFile :: FastString,
srcSpanLine :: !Int,
srcSpanCol :: !Int
}
| ImportedSpan String -- Module name
| UnhelpfulSpan FastString -- Just a general indication
-- also used to indicate an empty span
deriving Eq
-- We want to order SrcSpans first by the start point, then by the end point.
instance Ord SrcSpan where
a `compare` b =
(srcSpanStart a `compare` srcSpanStart b) `thenCmp`
(srcSpanEnd a `compare` srcSpanEnd b)
noSrcSpan = UnhelpfulSpan FSLIT("<no location info>")
mkGeneralSrcSpan :: FastString -> SrcSpan
mkGeneralSrcSpan = UnhelpfulSpan
isGoodSrcSpan SrcSpanOneLine{} = True
isGoodSrcSpan SrcSpanMultiLine{} = True
isGoodSrcSpan SrcSpanPoint{} = True
isGoodSrcSpan _ = False
srcSpanStartLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanStartLine SrcSpanMultiLine{ srcSpanSLine=l } = l
srcSpanStartLine SrcSpanPoint{ srcSpanLine=l } = l
srcSpanStartLine _ = panic "SrcLoc.srcSpanStartLine"
srcSpanEndLine SrcSpanOneLine{ srcSpanLine=l } = l
srcSpanEndLine SrcSpanMultiLine{ srcSpanELine=l } = l
srcSpanEndLine SrcSpanPoint{ srcSpanLine=l } = l
srcSpanEndLine _ = panic "SrcLoc.srcSpanEndLine"
srcSpanStartCol SrcSpanOneLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanMultiLine{ srcSpanSCol=l } = l
srcSpanStartCol SrcSpanPoint{ srcSpanCol=l } = l
srcSpanStartCol _ = panic "SrcLoc.srcSpanStartCol"
srcSpanEndCol SrcSpanOneLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanMultiLine{ srcSpanECol=c } = c
srcSpanEndCol SrcSpanPoint{ srcSpanCol=c } = c
srcSpanEndCol _ = panic "SrcLoc.srcSpanEndCol"
srcSpanStart (ImportedSpan str) = ImportedLoc str
srcSpanStart (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanStart s =
mkSrcLoc (srcSpanFile s)
(srcSpanStartLine s)
(srcSpanStartCol s)
srcSpanEnd (ImportedSpan str) = ImportedLoc str
srcSpanEnd (UnhelpfulSpan str) = UnhelpfulLoc str
srcSpanEnd s =
mkSrcLoc (srcSpanFile s)
(srcSpanEndLine s)
(srcSpanEndCol s)
srcLocSpan :: SrcLoc -> SrcSpan
srcLocSpan (ImportedLoc str) = ImportedSpan str
srcLocSpan (UnhelpfulLoc str) = UnhelpfulSpan str
srcLocSpan (SrcLoc file line col) = SrcSpanPoint file line col
mkSrcSpan :: SrcLoc -> SrcLoc -> SrcSpan
mkSrcSpan (ImportedLoc str) _ = ImportedSpan str
mkSrcSpan (UnhelpfulLoc str) _ = UnhelpfulSpan str
mkSrcSpan _ (ImportedLoc str) = ImportedSpan str
mkSrcSpan _ (UnhelpfulLoc str) = UnhelpfulSpan str
mkSrcSpan loc1 loc2
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
| otherwise = SrcSpanMultiLine file line1 col1 line2 col2
where
line1 = srcLocLine loc1
line2 = srcLocLine loc2
col1 = srcLocCol loc1
col2 = srcLocCol loc2
file = srcLocFile loc1
combineSrcSpans :: SrcSpan -> SrcSpan -> SrcSpan
combineSrcSpans (ImportedSpan str) _ = ImportedSpan str
combineSrcSpans (UnhelpfulSpan str) r = r -- this seems more useful
combineSrcSpans _ (ImportedSpan str) = ImportedSpan str
combineSrcSpans l (UnhelpfulSpan str) = l
combineSrcSpans start end
| line1 == line2 = if col1 == col2
then SrcSpanPoint file line1 col1
else SrcSpanOneLine file line1 col1 col2
| otherwise = SrcSpanMultiLine file line1 col1 line2 col2
where
line1 = srcSpanStartLine start
line2 = srcSpanEndLine end
col1 = srcSpanStartCol start
col2 = srcSpanEndCol end
file = srcSpanFile start
instance Outputable SrcSpan where
ppr span
= getPprStyle $ \ sty ->
if userStyle sty || debugStyle sty then
pprUserSpan span
else
hcat [text "{-# LINE ", int (srcSpanStartLine span), space,
char '\"', ftext (srcSpanFile span), text " #-}"]
pprUserSpan (SrcSpanOneLine src_path line start_col end_col)
= hcat [ ftext src_path, char ':',
int line,
char ':', int start_col
]
<> if end_col - start_col <= 1
then empty
-- for single-character or point spans, we just output the starting
-- column number
else char '-' <> int (end_col-1)
pprUserSpan (SrcSpanMultiLine src_path sline scol eline ecol)
= hcat [ ftext src_path, char ':',
parens (int sline <> char ',' <> int scol),
char '-',
parens (int eline <> char ',' <>
if ecol == 0 then int ecol else int (ecol-1))
]
pprUserSpan (SrcSpanPoint src_path line col)
= hcat [ ftext src_path, char ':',
int line,
char ':', int col
]
pprUserSpan (ImportedSpan mod) = ptext SLIT("Imported from") <+> quotes (text mod)
pprUserSpan (UnhelpfulSpan s) = ftext s
\end{code}
%************************************************************************
%* *
\subsection[Located]{Attaching SrcSpans to things}
%* *
%************************************************************************
\begin{code}
-- | We attach SrcSpans to lots of things, so let's have a datatype for it.
data Located e = L SrcSpan e
unLoc :: Located e -> e
unLoc (L _ e) = e
getLoc :: Located e -> SrcSpan
getLoc (L l _) = l
noLoc :: e -> Located e
noLoc e = L noSrcSpan e
combineLocs :: Located a -> Located b -> SrcSpan
combineLocs a b = combineSrcSpans (getLoc a) (getLoc b)
addCLoc :: Located a -> Located b -> c -> Located c
addCLoc a b c = L (combineSrcSpans (getLoc a) (getLoc b)) c
-- not clear whether to add a general Eq instance, but this is useful sometimes:
eqLocated :: Eq a => Located a -> Located a -> Bool
eqLocated a b = unLoc a == unLoc b
-- not clear whether to add a general Eq instance, but this is useful sometimes:
cmpLocated :: Ord a => Located a -> Located a -> Ordering
cmpLocated a b = unLoc a `compare` unLoc b
instance Functor Located where
fmap f (L l e) = L l (f e)
instance Outputable e => Outputable (Located e) where
ppr (L span e) = ppr e
-- do we want to dump the span in debugSty mode?
\end{code}
......@@ -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
......
......@@ -11,19 +11,19 @@ module Check ( check , ExhaustivePat ) where
import HsSyn
import TcHsSyn ( TypecheckedPat, hsPatType )
import TcHsSyn ( hsPatType )
import TcType ( tcTyConAppTyCon )
import DsUtils ( EquationInfo(..), MatchResult(..), EqnSet,
CanItFail(..), tidyLitPat, tidyNPat,
)
import Id ( idType )
import Id ( Id, idType )
import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConFieldLabels )
import Name ( Name, mkInternalName, getOccName, isDataSymOcc, getName, mkVarOcc )
import TysWiredIn
import PrelNames ( unboundKey )
import TyCon ( tyConDataCons, tupleTyConBoxity, isTupleTyCon )
import BasicTypes ( Boxity(..) )
import SrcLoc ( noSrcLoc )
import SrcLoc ( noSrcLoc, Located(..), getLoc, unLoc, noLoc )
import UniqSet
import Util ( takeList, splitAtList, notNull )
import Outputable
......@@ -131,23 +131,25 @@ untidy_pars :: WarningPat -> WarningPat
untidy_pars p = untidy True p
untidy :: NeedPars -> WarningPat -> WarningPat
untidy _ p@(WildPat _) = p
untidy _ p@(VarPat name) = p
untidy _ (LitPat lit) = LitPat (untidy_lit lit)
untidy _ p@(ConPatIn name (PrefixCon [])) = p
untidy b (ConPatIn name ps) = pars b (ConPatIn name (untidy_con ps))
untidy _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty
untidy _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed
untidy _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
untidy _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
untidy b (L loc p) = L loc (untidy' b p)
where
untidy' _ p@(WildPat _) = p
untidy' _ p@(VarPat name) = p
untidy' _ (LitPat lit) = LitPat (untidy_lit lit)
untidy' _ p@(ConPatIn name (PrefixCon [])) = p
untidy' b (ConPatIn name ps) = pars b (L loc (ConPatIn name (untidy_con ps)))
untidy' _ (ListPat pats ty) = ListPat (map untidy_no_pars pats) ty
untidy' _ (TuplePat pats boxed) = TuplePat (map untidy_no_pars pats) boxed
untidy' _ (PArrPat _ _) = panic "Check.untidy: Shouldn't get a parallel array here!"
untidy' _ (SigPatIn _ _) = panic "Check.untidy: SigPat"
untidy_con (PrefixCon pats) = PrefixCon (map untidy_pars pats)
untidy_con (InfixCon p1 p2) = InfixCon (untidy_pars p1) (untidy_pars p2)
untidy_con (RecCon bs) = RecCon [(f,untidy_pars p) | (f,p) <- bs]
pars :: NeedPars -> WarningPat -> WarningPat
pars :: NeedPars -> WarningPat -> Pat Name
pars True p = ParPat p
pars _ p = p
pars _ p = unLoc p
untidy_lit :: HsLit -> HsLit
untidy_lit (HsCharPrim c) = HsChar c
......@@ -186,7 +188,7 @@ check' :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
check' [] = ([([],[])],emptyUniqSet)
check' [EqnInfo n ctx ps (MatchResult CanFail _)]
| all_vars ps = ([(takeList ps (repeat new_wild_pat),[])], unitUniqSet n)
| all_vars ps = ([(takeList ps (repeat wildPat),[])], unitUniqSet n)
check' qs@((EqnInfo n ctx ps (MatchResult CanFail _)):rs)
| all_vars ps = (pats, addOneToUniqSet indexs n)
......@@ -251,7 +253,7 @@ process_literals used_lits qs
default_eqns = ASSERT2( okGroup qs, pprGroup qs )
map remove_var (filter (is_var . firstPat) qs)
(pats',indexs') = check' default_eqns
pats_default = [(new_wild_pat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
pats_default = [(wildPat:ps,constraints) | (ps,constraints) <- (pats')] ++ pats
indexs_default = unionUniqSets indexs' indexs
\end{code}
......@@ -264,7 +266,7 @@ construct_literal_matrix lit qs =
(map (\ (xs,ys) -> (new_lit:xs,ys)) pats,indexs)
where
(pats,indexs) = (check' (remove_first_column_lit lit qs))
new_lit = LitPat lit
new_lit = nlLitPat lit
remove_first_column_lit :: HsLit
-> [EquationInfo]
......@@ -299,7 +301,7 @@ nothing to do.
\begin{code}
first_column_only_vars :: [EquationInfo] -> ([ExhaustivePat],EqnSet)
first_column_only_vars qs = (map (\ (xs,ys) -> (new_wild_pat:xs,ys)) pats,indexs)
first_column_only_vars qs = (map (\ (xs,ys) -> (wildPat:xs,ys)) pats,indexs)
where
(pats,indexs) = check' (map remove_var qs)
......@@ -314,13 +316,13 @@ constructors or not explicitly. The reasoning is similar to @process_literals@,
the difference is that here the default case is not always needed.
\begin{code}
no_need_default_case :: [TypecheckedPat] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
no_need_default_case :: [Pat Id] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
no_need_default_case cons qs = (concat pats, unionManyUniqSets indexs)
where
pats_indexs = map (\x -> construct_matrix x qs) cons
(pats,indexs) = unzip pats_indexs
need_default_case :: [TypecheckedPat] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
need_default_case :: [Pat Id] -> [DataCon] -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
need_default_case used_cons unused_cons qs
| null default_eqns = (pats_default_no_eqns,indexs)
| otherwise = (pats_default,indexs_default)
......@@ -334,7 +336,7 @@ need_default_case used_cons unused_cons qs
pats_default_no_eqns = [(make_whole_con c:new_wilds,[]) | c <- unused_cons] ++ pats
indexs_default = unionUniqSets indexs' indexs
construct_matrix :: TypecheckedPat -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
construct_matrix :: Pat Id -> [EquationInfo] -> ([ExhaustivePat],EqnSet)
construct_matrix con qs =
(map (make_con con) pats,indexs)
where
......@@ -356,7 +358,7 @@ is transformed in:
\end{verbatim}
\begin{code}
remove_first_column :: TypecheckedPat -- Constructor
remove_first_column :: Pat Id -- Constructor
-> [EquationInfo]
-> [EquationInfo]
remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs
......@@ -365,14 +367,14 @@ remove_first_column (ConPatOut con (PrefixCon con_pats) _ _ _) qs
where
new_wilds = [WildPat (hsPatType arg_pat) | arg_pat <- con_pats]
shift_var (EqnInfo n ctx (ConPatOut _ (PrefixCon ps') _ _ _:ps) result) =
EqnInfo n ctx (ps'++ps) result
EqnInfo n ctx (map unLoc ps'++ps) result
shift_var (EqnInfo n ctx (WildPat _ :ps) result) =