Commit 7b018191 authored by partain's avatar partain

[project @ 1996-04-08 16:15:43 by partain]

SLPJ 1.3 hacks through 960408
parent f9120c20
......@@ -35,8 +35,8 @@ module Id {- (
idPrimRep, getInstIdModule,
getMentionedTyConsAndClassesFromId,
dataConTag,
dataConSig, getInstantiatedDataConSig,
dataConTag, dataConStrictMarks,
dataConSig, dataConArgTys,
dataConTyCon, dataConArity,
dataConFieldLabels,
......@@ -104,14 +104,13 @@ import Maybes ( maybeToBool )
import Name ( appendRdr, nameUnique, mkLocalName, isLocalName,
isLocallyDefinedName, isPreludeDefinedName,
nameOrigName,
RdrName(..), Name
)
import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
import Outputable ( isAvarop, isAconop, getLocalName,
isAvarop, isAconop, getLocalName,
isLocallyDefined, isPreludeDefined,
getOrigName, getOccName,
isExported, ExportFlag(..)
isExported, ExportFlag(..),
RdrName(..), Name
)
import FieldLabel ( fieldLabelName, FieldLabel{-instances-} )
import PragmaInfo ( PragmaInfo(..) )
import PrelMods ( pRELUDE_BUILTIN )
import PprType ( getTypeString, typeMaybeString, specMaybeTysSuffix,
......@@ -133,7 +132,7 @@ import UniqSupply ( getBuiltinUniques )
import Unique ( mkTupleDataConUnique, pprUnique, showUnique,
Unique{-instance Ord3-}
)
import Util ( mapAccumL, nOfThem,
import Util ( mapAccumL, nOfThem, zipEqual,
panic, panic#, pprPanic, assertPanic
)
\end{code}
......@@ -1379,7 +1378,7 @@ mkDataCon n stricts fields tvs ctxt args_tys tycon
= let
(inst_env, tyvars, tyvar_tys)
= instantiateTyVarTemplates tvs
(map getItsUnique tvs)
(map uniqueOf tvs)
in
-- the "context" and "arg_tys" have TyVarTemplates in them, so
-- we instantiate those types to have the right TyVars in them
......@@ -1446,7 +1445,7 @@ mkTupleCon arity
BEND
where
tyvar_tmpls = take arity alphaTyVars
(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map getItsUnique tyvar_tmpls)
(_, tyvars, tyvar_tys) = instantiateTyVarTemplates tyvar_tmpls (map uniqueOf tyvar_tmpls)
-}
fIRST_TAG :: ConTag
......@@ -1477,6 +1476,21 @@ dataConSig (Id _ _ (TupleConId _ arity) _ _)
dataConFieldLabels :: DataCon -> [FieldLabel]
dataConFieldLabels (Id _ _ (DataConId _ _ _ fields _ _ _ _) _ _) = fields
dataConFieldLabels (Id _ _ (TupleConId _ _) _ _) = []
dataConStrictMarks :: DataCon -> [StrictnessMark]
dataConStrictMarks (Id _ _ (DataConId _ _ stricts _ _ _ _ _) _ _) = stricts
dataConStrictMarks (Id _ _ (TupleConId _ arity) _ _)
= take arity (repeat NotMarkedStrict)
dataConArgTys :: DataCon
-> [Type] -- Instantiated at these types
-> [Type] -- Needs arguments of these types
dataConArgTys con_id inst_tys
= map (instantiateTy tenv) arg_tys
where
(tyvars, _, arg_tys, _) = dataConSig con_id
tenv = tyvars `zipEqual` inst_tys
\end{code}
\begin{code}
......@@ -1493,62 +1507,6 @@ recordSelectorFieldLabel :: Id -> FieldLabel
recordSelectorFieldLabel (Id _ _ (RecordSelId lbl) _ _) = lbl
\end{code}
{- LATER
dataConTyCon (Id _ _ _ (SpecId unspec tys _))
= mkSpecTyCon (dataConTyCon unspec) tys
dataConSig (Id _ _ _ (SpecId unspec ty_maybes _))
= (spec_tyvars, spec_theta_ty, spec_arg_tys, spec_tycon)
where
(tyvars, theta_ty, arg_tys, tycon) = dataConSig unspec
ty_env = tyvars `zip` ty_maybes
spec_tyvars = foldr nothing_tyvars [] ty_env
nothing_tyvars (tyvar, Nothing) l = tyvar : l
nothing_tyvars (tyvar, Just ty) l = l
spec_env = foldr just_env [] ty_env
just_env (tyvar, Nothing) l = l
just_env (tyvar, Just ty) l = (tyvar, ty) : l
spec_arg_tys = map (instantiateTauTy spec_env) arg_tys
spec_theta_ty = if null theta_ty then []
else panic "dataConSig:ThetaTy:SpecDataCon"
spec_tycon = mkSpecTyCon tycon ty_maybes
-}
\end{code}
\begin{pseudocode}
@getInstantiatedDataConSig@ takes a constructor and some types to which
it is applied; it returns its signature instantiated to these types.
\begin{code}
getInstantiatedDataConSig ::
DataCon -- The data constructor
-- Not a specialised data constructor
-> [TauType] -- Types to which applied
-- Must be fully applied i.e. contain all types of tycon
-> ([TauType], -- Types of dict args
[TauType], -- Types of regular args
TauType -- Type of result
)
getInstantiatedDataConSig data_con inst_tys
= ASSERT(isDataCon data_con)
let
(tvs, theta, arg_tys, tycon) = dataConSig data_con
inst_env = ASSERT(length tvs == length inst_tys)
tvs `zip` inst_tys
theta_tys = [ instantiateTy inst_env (mkDictTy c t) | (c,t) <- theta ]
cmpnt_tys = [ instantiateTy inst_env arg_ty | arg_ty <- arg_tys ]
result_ty = instantiateTy inst_env (applyTyCon tycon inst_tys)
in
-- Are the first/third results ever used?
(theta_tys, cmpnt_tys, result_ty)
\end{code}
Data type declarations are of the form:
\begin{verbatim}
......
......@@ -25,19 +25,29 @@ module Name (
mkImplicitName, isImplicitName,
mkBuiltinName,
NamedThing(..), -- class
ExportFlag(..), isExported,
nameUnique,
nameOrigName,
nameOccName,
nameExportFlag,
nameSrcLoc,
isLocallyDefinedName,
isPreludeDefinedName
isPreludeDefinedName,
getOrigName, getOccName, getExportFlag,
getSrcLoc, isLocallyDefined, isPreludeDefined,
getLocalName, getOrigNameRdr, ltLexical,
isOpLexeme, pprOp, pprNonOp,
isConop, isAconop, isAvarid, isAvarop
) where
import Ubiq
import CStrings ( identToC, cSEP )
import Outputable ( Outputable(..), ExportFlag(..), isConop )
import Outputable ( Outputable(..) )
import PprStyle ( PprStyle(..), codeStyle )
import Pretty
import PrelMods ( pRELUDE )
......@@ -272,3 +282,170 @@ pp_prov Builtin = ppPStr SLIT("/BUILTIN")
pp_prov _ = ppNil
\end{code}
%************************************************************************
%* *
\subsection[ExportFlag-datatype]{The @ExportFlag@ datatype}
%* *
%************************************************************************
The export flag @ExportAll@ means `export all there is', so there are
times when it is attached to a class or data type which has no
ops/constructors (if the class/type was imported abstractly). In
fact, @ExportAll@ is attached to everything except to classes/types
which are being {\em exported} abstractly, regardless of how they were
imported.
\begin{code}
data ExportFlag
= ExportAll -- export with all constructors/methods
| ExportAbs -- export abstractly
| NotExported
isExported a
= case (getExportFlag a) of
NotExported -> False
_ -> True
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isExported :: Class -> Bool #-}
{-# SPECIALIZE isExported :: Id -> Bool #-}
{-# SPECIALIZE isExported :: TyCon -> Bool #-}
#endif
\end{code}
%************************************************************************
%* *
\subsection{Overloaded functions related to Names}
%* *
%************************************************************************
\begin{code}
class NamedThing a where
getName :: a -> Name
\end{code}
\begin{code}
getOrigName :: NamedThing a => a -> (Module, FAST_STRING)
getOccName :: NamedThing a => a -> RdrName
getExportFlag :: NamedThing a => a -> ExportFlag
getSrcLoc :: NamedThing a => a -> SrcLoc
isLocallyDefined :: NamedThing a => a -> Bool
isPreludeDefined :: NamedThing a => a -> Bool
getOrigName = nameOrigName . getName
getOccName = nameOccName . getName
getExportFlag = nameExportFlag . getName
getSrcLoc = nameSrcLoc . getName
isLocallyDefined = isLocallyDefinedName . getName
isPreludeDefined = isPreludeDefinedName . getName
getLocalName :: (NamedThing a) => a -> FAST_STRING
getLocalName = snd . getOrigName
getOrigNameRdr :: (NamedThing a) => a -> RdrName
getOrigNameRdr n | isPreludeDefined n = Unqual str
| otherwise = Qual mod str
where
(mod,str) = getOrigName n
\end{code}
@ltLexical@ is used for sorting things into lexicographical order, so
as to canonicalize interfaces. [Regular @(<)@ should be used for fast
comparison.]
\begin{code}
a `ltLexical` b
= BIND isLocallyDefined a _TO_ a_local ->
BIND isLocallyDefined b _TO_ b_local ->
BIND getOrigName a _TO_ (a_mod, a_name) ->
BIND getOrigName b _TO_ (b_mod, b_name) ->
if a_local || b_local then
a_name < b_name -- can't compare module names
else
case _CMP_STRING_ a_mod b_mod of
LT_ -> True
EQ_ -> a_name < b_name
GT__ -> False
BEND BEND BEND BEND
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE ltLexical :: Class -> Class -> Bool #-}
{-# SPECIALIZE ltLexical :: Id -> Id -> Bool #-}
{-# SPECIALIZE ltLexical :: TyCon -> TyCon -> Bool #-}
#endif
\end{code}
These functions test strings to see if they fit the lexical categories
defined in the Haskell report. Normally applied as in e.g. @isConop
(getLocalName foo)@
\begin{code}
isConop, isAconop, isAvarid, isAvarop :: FAST_STRING -> Bool
isConop cs
| _NULL_ cs = False
| c == '_' = isConop (_TAIL_ cs) -- allow for leading _'s
| otherwise = isUpper c || c == ':'
|| c == '[' || c == '(' -- [] () and (,,) come is as Conop strings !!!
|| isUpperISO c
where
c = _HEAD_ cs
isAconop cs
| _NULL_ cs = False
| otherwise = c == ':'
where
c = _HEAD_ cs
isAvarid cs
| _NULL_ cs = False
| c == '_' = isAvarid (_TAIL_ cs) -- allow for leading _'s
| isLower c = True
| isLowerISO c = True
| otherwise = False
where
c = _HEAD_ cs
isAvarop cs
| _NULL_ cs = False
| isLower c = False
| isUpper c = False
| c `elem` "!#$%&*+./<=>?@\\^|~-" = True
| isSymbolISO c = True
| otherwise = False
where
c = _HEAD_ cs
isSymbolISO c = ord c `elem` (0xd7 : 0xf7 : [0xa1 .. 0xbf])
isUpperISO c = 0xc0 <= oc && oc <= 0xde && oc /= 0xd7 where oc = ord c
isLowerISO c = 0xdf <= oc && oc <= 0xff && oc /= 0xf7 where oc = ord c
\end{code}
And one ``higher-level'' interface to those:
\begin{code}
isOpLexeme :: NamedThing a => a -> Bool
isOpLexeme v
= let str = snd (getOrigName v) in isAvarop str || isAconop str
-- print `vars`, (op) correctly
pprOp, pprNonOp :: (NamedThing name, Outputable name) => PprStyle -> name -> Pretty
pprOp sty var
= if isOpLexeme var
then ppr sty var
else ppBesides [ppChar '`', ppr sty var, ppChar '`']
pprNonOp sty var
= if isOpLexeme var
then ppBesides [ppLparen, ppr sty var, ppRparen]
else ppr sty var
#ifdef USE_ATTACK_PRAGMAS
{-# SPECIALIZE isOpLexeme :: Id -> Bool #-}
{-# SPECIALIZE pprNonOp :: PprStyle -> Id -> Pretty #-}
{-# SPECIALIZE pprNonOp :: PprStyle -> TyCon -> Pretty #-}
{-# SPECIALIZE pprOp :: PprStyle -> Id -> Pretty #-}
#endif
\end{code}
......@@ -21,7 +21,7 @@ Haskell).
--<mkdependHS:friends> UniqSupply
module Unique (
Unique, Uniquable(..),
Unique,
u2i, -- hack: used in UniqFM
pprUnique, pprUnique10, showUnique,
......@@ -54,6 +54,7 @@ module Unique (
charPrimTyConKey,
charTyConKey,
consDataConKey,
dataClassKey,
doubleDataConKey,
doublePrimTyConKey,
doubleTyConKey,
......@@ -114,6 +115,10 @@ module Unique (
parErrorIdKey,
parIdKey,
patErrorIdKey,
recConErrorIdKey,
recUpdErrorIdKey,
irrefutPatErrorIdKey,
nonExhaustiveGuardsErrorIdKey,
primIoTyConKey,
ratioDataConKey,
ratioTyConKey,
......@@ -290,9 +295,6 @@ instance Ord3 Unique where
cmp = cmpUnique
-----------------
class Uniquable a where
uniqueOf :: a -> Unique
instance Uniquable Unique where
uniqueOf u = u
\end{code}
......@@ -415,6 +417,7 @@ monadZeroClassKey = mkPreludeClassUnique 15
binaryClassKey = mkPreludeClassUnique 16
cCallableClassKey = mkPreludeClassUnique 17
cReturnableClassKey = mkPreludeClassUnique 18
dataClassKey = mkPreludeClassUnique 19
\end{code}
%************************************************************************
......@@ -531,40 +534,44 @@ wordDataConKey = mkPreludeDataConUnique 41
%************************************************************************
\begin{code}
absentErrorIdKey = mkPreludeMiscIdUnique 1
appendIdKey = mkPreludeMiscIdUnique 2
augmentIdKey = mkPreludeMiscIdUnique 3
buildIdKey = mkPreludeMiscIdUnique 4
errorIdKey = mkPreludeMiscIdUnique 5
foldlIdKey = mkPreludeMiscIdUnique 6
foldrIdKey = mkPreludeMiscIdUnique 7
forkIdKey = mkPreludeMiscIdUnique 8
int2IntegerIdKey = mkPreludeMiscIdUnique 9
integerMinusOneIdKey = mkPreludeMiscIdUnique 10
integerPlusOneIdKey = mkPreludeMiscIdUnique 11
integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
integerZeroIdKey = mkPreludeMiscIdUnique 13
packCStringIdKey = mkPreludeMiscIdUnique 14
parErrorIdKey = mkPreludeMiscIdUnique 15
parIdKey = mkPreludeMiscIdUnique 16
patErrorIdKey = mkPreludeMiscIdUnique 17
realWorldPrimIdKey = mkPreludeMiscIdUnique 18
runSTIdKey = mkPreludeMiscIdUnique 19
seqIdKey = mkPreludeMiscIdUnique 20
traceIdKey = mkPreludeMiscIdUnique 21
unpackCString2IdKey = mkPreludeMiscIdUnique 22
unpackCStringAppendIdKey= mkPreludeMiscIdUnique 23
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
unpackCStringIdKey = mkPreludeMiscIdUnique 25
voidPrimIdKey = mkPreludeMiscIdUnique 26
mainIdKey = mkPreludeMiscIdUnique 27
mainPrimIOIdKey = mkPreludeMiscIdUnique 28
absentErrorIdKey = mkPreludeMiscIdUnique 1
appendIdKey = mkPreludeMiscIdUnique 2
augmentIdKey = mkPreludeMiscIdUnique 3
buildIdKey = mkPreludeMiscIdUnique 4
errorIdKey = mkPreludeMiscIdUnique 5
foldlIdKey = mkPreludeMiscIdUnique 6
foldrIdKey = mkPreludeMiscIdUnique 7
forkIdKey = mkPreludeMiscIdUnique 8
int2IntegerIdKey = mkPreludeMiscIdUnique 9
integerMinusOneIdKey = mkPreludeMiscIdUnique 10
integerPlusOneIdKey = mkPreludeMiscIdUnique 11
integerPlusTwoIdKey = mkPreludeMiscIdUnique 12
integerZeroIdKey = mkPreludeMiscIdUnique 13
packCStringIdKey = mkPreludeMiscIdUnique 14
parErrorIdKey = mkPreludeMiscIdUnique 15
parIdKey = mkPreludeMiscIdUnique 16
patErrorIdKey = mkPreludeMiscIdUnique 17
realWorldPrimIdKey = mkPreludeMiscIdUnique 18
runSTIdKey = mkPreludeMiscIdUnique 19
seqIdKey = mkPreludeMiscIdUnique 20
traceIdKey = mkPreludeMiscIdUnique 21
unpackCString2IdKey = mkPreludeMiscIdUnique 22
unpackCStringAppendIdKey = mkPreludeMiscIdUnique 23
unpackCStringFoldrIdKey = mkPreludeMiscIdUnique 24
unpackCStringIdKey = mkPreludeMiscIdUnique 25
voidPrimIdKey = mkPreludeMiscIdUnique 26
mainIdKey = mkPreludeMiscIdUnique 27
mainPrimIOIdKey = mkPreludeMiscIdUnique 28
recConErrorIdKey = mkPreludeMiscIdUnique 29
recUpdErrorIdKey = mkPreludeMiscIdUnique 30
irrefutPatErrorIdKey = mkPreludeMiscIdUnique 31
nonExhaustiveGuardsErrorIdKey = mkPreludeMiscIdUnique 32
#ifdef GRAN
parLocalIdKey = mkPreludeMiscIdUnique 29
parGlobalIdKey = mkPreludeMiscIdUnique 30
noFollowIdKey = mkPreludeMiscIdUnique 31
copyableIdKey = mkPreludeMiscIdUnique 32
parLocalIdKey = mkPreludeMiscIdUnique 33
parGlobalIdKey = mkPreludeMiscIdUnique 34
noFollowIdKey = mkPreludeMiscIdUnique 35
copyableIdKey = mkPreludeMiscIdUnique 36
#endif
\end{code}
......@@ -572,15 +579,15 @@ Certain class operations from Prelude classes. They get
their own uniques so we can look them up easily when we want
to conjure them up during type checking.
\begin{code}
fromIntClassOpKey = mkPreludeMiscIdUnique 33
fromIntegerClassOpKey = mkPreludeMiscIdUnique 34
fromRationalClassOpKey = mkPreludeMiscIdUnique 35
enumFromClassOpKey = mkPreludeMiscIdUnique 36
enumFromThenClassOpKey = mkPreludeMiscIdUnique 37
enumFromToClassOpKey = mkPreludeMiscIdUnique 38
enumFromThenToClassOpKey= mkPreludeMiscIdUnique 39
eqClassOpKey = mkPreludeMiscIdUnique 40
geClassOpKey = mkPreludeMiscIdUnique 41
fromIntClassOpKey = mkPreludeMiscIdUnique 37
fromIntegerClassOpKey = mkPreludeMiscIdUnique 38
fromRationalClassOpKey = mkPreludeMiscIdUnique 39
enumFromClassOpKey = mkPreludeMiscIdUnique 40
enumFromThenClassOpKey = mkPreludeMiscIdUnique 41
enumFromToClassOpKey = mkPreludeMiscIdUnique 42
enumFromThenToClassOpKey= mkPreludeMiscIdUnique 43
eqClassOpKey = mkPreludeMiscIdUnique 44
geClassOpKey = mkPreludeMiscIdUnique 45
\end{code}
......
......@@ -44,7 +44,7 @@ import Id ( idPrimRep, toplevelishId, isDataCon,
GenId{-instance NamedThing-}
)
import Maybes ( catMaybes )
import Outputable ( isLocallyDefined )
import Name ( isLocallyDefined )
import PprAbsC ( pprAmode )
import PprStyle ( PprStyle(..) )
import StgSyn ( StgArg(..), StgLiveVars(..), GenStgArg(..) )
......
......@@ -40,7 +40,7 @@ import Id ( dataConTag, dataConSig,
emptyIdSet,
GenId{-instance NamedThing-}
)
import Outputable ( getLocalName )
import Name ( getLocalName )
import PrimRep ( getPrimRepSize, PrimRep(..) )
import TyCon ( tyConDataCons, mkSpecTyCon )
import Type ( typePrimRep )
......
......@@ -86,7 +86,7 @@ import Id ( idType, idPrimRep, getIdArity,
)
import IdInfo ( arityMaybe )
import Maybes ( assocMaybe, maybeToBool )
import Outputable ( isLocallyDefined, getLocalName )
import Name ( isLocallyDefined, getLocalName )
import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instance Outputable-} )
import PrimRep ( getPrimRepSize, separateByPtrFollowness )
......
......@@ -25,7 +25,7 @@ import Id ( idType, mkSysLocal,
nullIdEnv, growIdEnvList, lookupIdEnv, IdEnv(..),
GenId{-instances-}
)
import Outputable ( isLocallyDefined, getSrcLoc )
import Name ( isLocallyDefined, getSrcLoc )
import PrelInfo ( liftDataCon, mkLiftTy, statePrimTyCon )
import TyCon ( isBoxedTyCon, TyCon{-instance-} )
import Type ( maybeAppDataTyCon, eqTy )
......
......@@ -19,12 +19,11 @@ import Bag
import Kind ( Kind{-instance-} )
import Literal ( literalType, Literal{-instance-} )
import Id ( idType, isBottomingId,
getInstantiatedDataConSig, GenId{-instances-}
dataConArgTys, GenId{-instances-}
)
import Maybes ( catMaybes )
import Outputable ( isLocallyDefined, getSrcLoc,
Outputable(..){-instance * []-}
)
import Name ( isLocallyDefined, getSrcLoc )
import Outputable ( Outputable(..){-instance * []-} )
import PprCore
import PprStyle ( PprStyle(..) )
import PprType ( GenType, GenTyVar, TyCon )
......@@ -344,7 +343,7 @@ lintAlgAlt scrut_ty tycon{-ToDo: use it!-} (con,args,rhs)
addErrL (mkAlgAltMsg1 scrut_ty)
Just (tycon, tys_applied, cons) ->
let
(_, arg_tys, _) = getInstantiatedDataConSig con tys_applied
arg_tys = dataConArgTys con tys_applied
in
checkL (con `elem` cons) (mkAlgAltMsg2 scrut_ty con) `seqL`
checkL (length arg_tys == length args) (mkAlgAltMsg3 con args)
......
......@@ -12,7 +12,7 @@ module CoreUtils (
substCoreExpr, substCoreBindings
, mkCoreIfThenElse
, mkErrorApp, escErrorMsg
, escErrorMsg -- ToDo: kill
, argToExpr
, unTagBinders, unTagBindersAlts
, manifestlyWHNF, manifestlyBottom
......@@ -44,8 +44,7 @@ import PprStyle ( PprStyle(..) )
import PprType ( GenType{-instances-} )
import Pretty ( ppAboves )
import PrelInfo ( trueDataCon, falseDataCon,
augmentId, buildId,
pAT_ERROR_ID
augmentId, buildId
)
import PrimOp ( primOpType, PrimOp(..) )
import SrcLoc ( mkUnknownSrcLoc )
......@@ -153,15 +152,20 @@ mkCoreIfThenElse guard then_expr else_expr
\end{code}
\begin{code}
mkErrorApp :: Type -> Id -> String -> CoreExpr
{- OLD:
mkErrorApp :: Id -> Type -> Id -> String -> CoreExpr
mkErrorApp ty str_var error_msg
mkErrorApp err_fun ty str_var error_msg
= Let (NonRec str_var (Lit (NoRepStr (_PK_ error_msg)))) (
mkApp (Var pAT_ERROR_ID) [] [ty] [VarArg str_var])
mkApp (Var err_fun) [] [ty] [VarArg str_var])
-}
escErrorMsg = panic "CoreUtils.escErrorMsg: To Die"
{- OLD:
escErrorMsg [] = []
escErrorMsg ('%':xs) = '%' : '%' : escErrorMsg xs
escErrorMsg (x:xs) = x : escErrorMsg xs
-}
\end{code}
For making @Apps@ and @Lets@, we must take appropriate evasive
......
......@@ -32,6 +32,7 @@ import Id ( idType, getIdInfo, getIdStrictness,
)
import IdInfo ( ppIdInfo, StrictnessInfo(..) )
import Literal ( Literal{-instances-} )
import Name ( isOpLexeme )
import Outputable -- quite a few things
import PprEnv
import PprType ( GenType{-instances-}, GenTyVar{-instance-} )
......
......@@ -27,7 +27,6 @@ import DsUtils
import Match ( matchWrapper )
import CmdLineOpts ( opt_SccProfilingOn, opt_CompilingPrelude )
import CoreUtils ( escErrorMsg )
import CostCentre ( mkAllDictsCC, preludeDictsCostCentre )
import Id ( idType, DictVar(..), GenId )
import ListSetOps ( minusList, intersectLists )
......@@ -472,23 +471,19 @@ dsMonoBinds is_rec tyvars dicts binder_subst (VarMonoBind var expr)
\begin{code}
dsMonoBinds is_rec tyvars dicts binder_subst (FunMonoBind fun matches locn)
= putSrcLocDs locn (
= putSrcLocDs locn $
let
new_fun = binder_subst fun
new_fun = binder_subst fun
error_string = "function " ++ showForErr fun
in
matchWrapper (FunMatch fun) matches (error_msg new_fun) `thenDs` \ (args, body) ->
matchWrapper (FunMatch fun) matches error_string `thenDs` \ (args, body) ->
returnDs [(new_fun,
mkLam tyvars (dicts ++ args) body)]
)
where
error_msg fun = "%F" -- "incomplete pattern(s) to match in function \""
++ (escErrorMsg (ppShow 80 (ppr PprForUser fun))) ++ "\""
dsMonoBinds is_rec tyvars dicts binder_subst (PatMonoBind (VarPat v) grhss_and_binds locn)
= putSrcLocDs locn (
dsGuarded grhss_and_binds locn `thenDs` \ body_expr ->
= putSrcLocDs locn $
dsGuarded grhss_and_binds `thenDs` \ body_expr ->
returnDs [(binder_subst v, mkLam tyvars dicts body_expr)]
)
\end{code}
%==============================================
......@@ -531,9 +526,9 @@ Then we transform to: