diff options
76 files changed, 1045 insertions, 626 deletions
diff --git a/ghc/compiler/basicTypes/Id.lhs b/ghc/compiler/basicTypes/Id.lhs index 75f1520367..adbd61f788 100644 --- a/ghc/compiler/basicTypes/Id.lhs +++ b/ghc/compiler/basicTypes/Id.lhs @@ -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} diff --git a/ghc/compiler/basicTypes/Name.lhs b/ghc/compiler/basicTypes/Name.lhs index f4667bb796..14691d66b7 100644 --- a/ghc/compiler/basicTypes/Name.lhs +++ b/ghc/compiler/basicTypes/Name.lhs @@ -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} diff --git a/ghc/compiler/basicTypes/Unique.lhs b/ghc/compiler/basicTypes/Unique.lhs index d3ee26e544..b77ed34ece 100644 --- a/ghc/compiler/basicTypes/Unique.lhs +++ b/ghc/compiler/basicTypes/Unique.lhs @@ -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} diff --git a/ghc/compiler/codeGen/CgBindery.lhs b/ghc/compiler/codeGen/CgBindery.lhs index e678d180d4..8c5814a7ad 100644 --- a/ghc/compiler/codeGen/CgBindery.lhs +++ b/ghc/compiler/codeGen/CgBindery.lhs @@ -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(..) ) diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index a3113e441f..c35219edd1 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -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 ) diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 6256db0a14..f7eb45a539 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -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 ) diff --git a/ghc/compiler/coreSyn/CoreLift.lhs b/ghc/compiler/coreSyn/CoreLift.lhs index 9020e0b41e..71383a55ed 100644 --- a/ghc/compiler/coreSyn/CoreLift.lhs +++ b/ghc/compiler/coreSyn/CoreLift.lhs @@ -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 ) diff --git a/ghc/compiler/coreSyn/CoreLint.lhs b/ghc/compiler/coreSyn/CoreLint.lhs index 6cff5a159e..3aa5c628f8 100644 --- a/ghc/compiler/coreSyn/CoreLint.lhs +++ b/ghc/compiler/coreSyn/CoreLint.lhs @@ -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) diff --git a/ghc/compiler/coreSyn/CoreUtils.lhs b/ghc/compiler/coreSyn/CoreUtils.lhs index ddc7658249..2fc8a3bfea 100644 --- a/ghc/compiler/coreSyn/CoreUtils.lhs +++ b/ghc/compiler/coreSyn/CoreUtils.lhs @@ -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 diff --git a/ghc/compiler/coreSyn/PprCore.lhs b/ghc/compiler/coreSyn/PprCore.lhs index 4a503e47aa..412c62d4c5 100644 --- a/ghc/compiler/coreSyn/PprCore.lhs +++ b/ghc/compiler/coreSyn/PprCore.lhs @@ -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-} ) diff --git a/ghc/compiler/deSugar/DsBinds.lhs b/ghc/compiler/deSugar/DsBinds.lhs index ec1bdd4fff..c2c23ae2d6 100644 --- a/ghc/compiler/deSugar/DsBinds.lhs +++ b/ghc/compiler/deSugar/DsBinds.lhs @@ -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: \begin{code} dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) - = putSrcLocDs locn ( + = putSrcLocDs locn $ - dsGuarded grhss_and_binds locn `thenDs` \ body_expr -> + dsGuarded grhss_and_binds `thenDs` \ body_expr -> {- KILLED by Sansom. 95/05 -- make *sure* there are no primitive types in the pattern @@ -549,7 +544,6 @@ dsMonoBinds is_rec tyvars [] binder_subst (PatMonoBind pat grhss_and_binds locn) mkSelectorBinds tyvars pat [(binder, binder_subst binder) | binder <- pat_binders] body_expr - ) where pat_binders = collectTypedPatBinders pat -- NB For a simple tuple pattern, these binders diff --git a/ghc/compiler/deSugar/DsCCall.lhs b/ghc/compiler/deSugar/DsCCall.lhs index b54e111991..e19eddf902 100644 --- a/ghc/compiler/deSugar/DsCCall.lhs +++ b/ghc/compiler/deSugar/DsCCall.lhs @@ -16,7 +16,7 @@ import DsMonad import DsUtils import CoreUtils ( coreExprType ) -import Id ( getInstantiatedDataConSig, mkTupleCon ) +import Id ( dataConArgTys, mkTupleCon ) import Maybes ( maybeToBool ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instances-} ) @@ -192,7 +192,7 @@ we decide what's happening with enumerations. ADR (Just (tycon, tycon_arg_tys, data_cons)) = maybe_data_type (the_data_con : other_data_cons) = data_cons - (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys + data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys (data_con_arg_ty1 : data_con_arg_ty2 : _) = data_con_arg_tys can't_see_datacons_error thing ty @@ -292,7 +292,7 @@ boxResult result_ty Just (tycon, tycon_arg_tys, data_cons) = maybe_data_type (the_data_con : other_data_cons) = data_cons - (_, data_con_arg_tys, _) = getInstantiatedDataConSig the_data_con tycon_arg_tys + data_con_arg_tys = dataConArgTys the_data_con tycon_arg_tys (the_prim_result_ty : other_args_tys) = data_con_arg_tys (state_and_prim_datacon, state_and_prim_ty) = getStatePairingConInfo the_prim_result_ty diff --git a/ghc/compiler/deSugar/DsExpr.lhs b/ghc/compiler/deSugar/DsExpr.lhs index 088809955e..0e4afdc199 100644 --- a/ghc/compiler/deSugar/DsExpr.lhs +++ b/ghc/compiler/deSugar/DsExpr.lhs @@ -13,13 +13,17 @@ import DsLoop -- partly to get dsBinds, partly to chk dsExpr import HsSyn ( HsExpr(..), HsLit(..), ArithSeqInfo(..), Match, Qual, HsBinds, Stmt, PolyType ) -import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..) ) +import TcHsSyn ( TypecheckedHsExpr(..), TypecheckedHsBinds(..), + TypecheckedRecordBinds(..) + ) import CoreSyn import DsMonad import DsCCall ( dsCCall ) import DsListComp ( dsListComp ) -import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom ) +import DsUtils ( mkAppDs, mkConDs, mkPrimDs, dsExprToAtom, + mkErrorAppDs, showForErr + ) import Match ( matchWrapper ) import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), @@ -27,19 +31,26 @@ import CoreUnfold ( UnfoldingDetails(..), UnfoldingGuidance(..), import CoreUtils ( coreExprType, substCoreExpr, argToExpr, mkCoreIfThenElse, unTagBinders ) import CostCentre ( mkUserCC ) +import FieldLabel ( FieldLabel{-instance Eq/Outputable-} ) import Id ( mkTupleCon, idType, nullIdEnv, addOneToIdEnv, - getIdUnfolding ) + getIdUnfolding, dataConArgTys, dataConFieldLabels, + recordSelectorFieldLabel + ) import Literal ( mkMachInt, Literal(..) ) import MagicUFs ( MagicUnfoldingFun ) import PprStyle ( PprStyle(..) ) import PprType ( GenType ) import PrelInfo ( mkTupleTy, unitTy, nilDataCon, consDataCon, - charDataCon, charTy ) + charDataCon, charTy, rEC_CON_ERROR_ID, + rEC_UPD_ERROR_ID + ) import Pretty ( ppShow, ppBesides, ppPStr, ppStr ) -import Type ( splitSigmaTy, typePrimRep ) +import Type ( splitSigmaTy, splitFunTy, typePrimRep, + getAppDataTyCon + ) import TyVar ( nullTyVarEnv, addOneToTyVarEnv ) import Usage ( UVar(..) ) -import Util ( pprError, panic ) +import Util ( zipEqual, pprError, panic, assertPanic ) maybeBoxedPrimType = panic "DsExpr.maybeBoxedPrimType" splitTyArgs = panic "DsExpr.splitTyArgs" @@ -170,10 +181,7 @@ dsExpr (HsLitOut (HsStringPrim s) _) -- end of literals magic. -- dsExpr expr@(HsLam a_Match) - = let - error_msg = "%L" --> "pattern-matching failed in lambda" - in - matchWrapper LambdaMatch [a_Match] error_msg `thenDs` \ (binders, matching_code) -> + = matchWrapper LambdaMatch [a_Match] "lambda" `thenDs` \ (binders, matching_code) -> returnDs ( mkValLam binders matching_code ) dsExpr expr@(HsApp e1 e2) = dsApp expr [] @@ -247,11 +255,8 @@ dsExpr (HsSCC cc expr) dsExpr expr@(HsCase discrim matches src_loc) = putSrcLocDs src_loc $ - dsExpr discrim `thenDs` \ core_discrim -> - let - error_msg = "%C" --> "pattern-matching failed in case" - in - matchWrapper CaseMatch matches error_msg `thenDs` \ ([discrim_var], matching_code) -> + dsExpr discrim `thenDs` \ core_discrim -> + matchWrapper CaseMatch matches "case" `thenDs` \ ([discrim_var], matching_code) -> returnDs ( mkCoLetAny (NonRec discrim_var core_discrim) matching_code ) dsExpr (ListComp expr quals) @@ -267,6 +272,30 @@ dsExpr (HsDoOut stmts m_id mz_id src_loc) = putSrcLocDs src_loc $ panic "dsExpr:HsDoOut" +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 -> + returnDs (mkCoreIfThenElse core_guard core_then core_else) + +\end{code} + + +Type lambda and application +~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} +dsExpr (TyLam tyvars expr) + = dsExpr expr `thenDs` \ core_expr -> + returnDs (mkTyLam tyvars core_expr) + +dsExpr expr@(TyApp e tys) = dsApp expr [] +\end{code} + + +Various data construction things +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +\begin{code} dsExpr (ExplicitListOut ty xs) = case xs of [] -> returnDs (mk_nil_con ty) @@ -281,15 +310,9 @@ dsExpr (ExplicitTuple expr_list) (map coreExprType core_exprs) core_exprs -dsExpr (RecordCon con rbinds) = panic "dsExpr:RecordCon" -dsExpr (RecordUpd aexp rbinds) = panic "dsExpr:RecordUpd" - -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 -> - returnDs (mkCoreIfThenElse core_guard core_then core_else) +dsExpr (HsCon con tys args) + = mapDs dsExpr args `thenDs` \ args_exprs -> + mkConDs con tys args_exprs dsExpr (ArithSeqOut expr (From from)) = dsExpr expr `thenDs` \ expr2 -> @@ -316,38 +339,119 @@ dsExpr (ArithSeqOut expr (FromThenTo from thn two)) mkAppDs expr2 [] [from2, thn2, two2] \end{code} +Record construction and update +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +For record construction we do this (assuming T has three arguments) -Type lambda and application -~~~~~~~~~~~~~~~~~~~~~~~~~~~ -\begin{code} -dsExpr (TyLam tyvars expr) - = dsExpr expr `thenDs` \ core_expr -> - returnDs (mkTyLam tyvars core_expr) + T { op2 = e } +==> + let err = /\a -> recConErr a + T (recConErr t1 "M.lhs/230/op1") + e + (recConErr t1 "M.lhs/230/op3") -dsExpr expr@(TyApp e tys) = dsApp expr [] -\end{code} +recConErr then converts its arugment string into a proper message +before printing it as + + M.lhs, line 230: missing field op1 was evaluated -Record construction and update -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -{- dsExpr (RecordCon con_expr rbinds) = dsExpr con_expr `thenDs` \ con_expr' -> let - con_args = map mk_arg (arg_tys `zip` fieldLabelTags) - (arg_tys, data_ty) = splitFunTy (coreExprType con_expr') + con_id = get_con_id con_expr' + (arg_tys, data_ty) = splitFunTy (idType con_id) - mk_arg (arg_ty, tag) = case [ | (sel_id,rhs) <- rbinds, - fieldLabelTag (recordSelectorFieldLabel sel_id) == tag + mk_arg (arg_ty, lbl) = case [rhs | (sel_id,rhs,_) <- rbinds, + lbl == recordSelectorFieldLabel sel_id ] of (rhs:rhss) -> ASSERT( null rhss ) dsExpr rhs - [] -> returnDs ......GONE HOME!>>>>> + [] -> mkErrorAppDs rEC_CON_ERROR_ID arg_ty (showForErr lbl) + in + mapDs mk_arg (arg_tys `zip` dataConFieldLabels con_id) `thenDs` \ con_args -> - mkAppDs con_expr [] con_args --} + mkAppDs con_expr' [] con_args + where + -- The "con_expr'" is simply an application of the constructor Id + -- to types and (perhaps) dictionaries. This boring little + -- function gets the constructor out. + get_con_id (App fun _) = get_con_id fun + get_con_id (Var con) = con +\end{code} + +Record update is a little harder. Suppose we have the decl: + + data T = T1 {op1, op2, op3 :: Int} + | T2 {op4, op1 :: Int} + | T3 + +Then we translate as follows: + + r { op2 = e } +===> + let op2 = e in + case r of + T1 op1 _ op3 -> T1 op1 op2 op3 + T2 op4 _ -> T2 op4 op2 + other -> recUpdError "M.lhs/230" + +It's important that we use the constructor Ids for T1, T2 etc on the +RHSs, and do not generate a Core Con directly, because the constructor +might do some argument-evaluation first; and may have to throw away some +dictionaries. + +\begin{code} +dsExpr (RecordUpdOut record_expr dicts rbinds) + = dsExpr record_expr `thenDs` \ record_expr' -> + + -- Desugar the rbinds, and generate let-bindings if + -- necessary so that we don't lose sharing +-- dsRbinds rbinds $ \ rbinds' -> + let rbinds' = panic "dsExpr:RecordUpdOut:rbinds'" in + let + record_ty = coreExprType record_expr' + (tycon, inst_tys, cons) = getAppDataTyCon record_ty + cons_to_upd = filter has_all_fields cons + + -- initial_args are passed to every constructor + initial_args = map TyArg inst_tys ++ map VarArg dicts + + mk_val_arg (field, arg_id) + = case [arg | (f, arg) <- rbinds', f==field] of + (arg:args) -> ASSERT(null args) + arg + [] -> VarArg arg_id + + mk_alt con + = newSysLocalsDs (dataConArgTys con inst_tys) `thenDs` \ arg_ids -> + let + val_args = map mk_val_arg (dataConFieldLabels con `zipEqual` arg_ids) + in + returnDs (con, arg_ids, mkGenApp (mkGenApp (Var con) initial_args) val_args) + + mk_default + | length cons_to_upd == length cons + = returnDs NoDefault + | otherwise + = newSysLocalDs record_ty `thenDs` \ deflt_id -> + mkErrorAppDs rEC_UPD_ERROR_ID record_ty "" `thenDs` \ err -> + returnDs (BindDefault deflt_id err) + in + mapDs mk_alt cons_to_upd `thenDs` \ alts -> + mk_default `thenDs` \ deflt -> + + returnDs (Case record_expr' (AlgAlts alts deflt)) + + where + has_all_fields :: Id -> Bool + has_all_fields con_id + = all ok rbinds + where + con_fields = dataConFieldLabels con_id + ok (sel_id, _, _) = recordSelectorFieldLabel sel_id `elem` con_fields \end{code} Dictionary lambda and application @@ -503,6 +607,24 @@ apply_to_args fun args sep a@(UsageArg _) _ = panic "DsExpr:apply_to_args:UsageArg" \end{code} + +\begin{code} +dsRbinds :: TypecheckedRecordBinds -- The field bindings supplied + -> ([(Id, CoreArg)] -> DsM CoreExpr) -- A continuation taking the field + -- bindings with atomic rhss + -> DsM CoreExpr -- The result of the continuation, + -- wrapped in suitable Lets + +dsRbinds [] continue_with + = continue_with [] + +dsRbinds ((sel_id, rhs, pun_flag) : rbinds) continue_with + = dsExpr rhs `thenDs` \ rhs' -> + dsExprToAtom rhs' $ \ rhs_atom -> + dsRbinds rbinds $ \ rbinds' -> + continue_with ((panic "dsRbinds:field_label?"{-sel_id-}, rhs_atom) : rbinds') +\end{code} + \begin{code} do_unfold ty_env val_env (Lam (TyBinder tyvar) body) (TyArg ty : args) = do_unfold (addOneToTyVarEnv ty_env tyvar ty) val_env body args diff --git a/ghc/compiler/deSugar/DsGRHSs.lhs b/ghc/compiler/deSugar/DsGRHSs.lhs index d90e330396..938d8657ed 100644 --- a/ghc/compiler/deSugar/DsGRHSs.lhs +++ b/ghc/compiler/deSugar/DsGRHSs.lhs @@ -21,8 +21,8 @@ import CoreSyn ( CoreBinding(..), CoreExpr(..), mkCoLetsAny ) import DsMonad import DsUtils -import CoreUtils ( escErrorMsg, mkErrorApp, mkCoreIfThenElse ) -import PrelInfo ( stringTy ) +import CoreUtils ( mkCoreIfThenElse ) +import PrelInfo ( stringTy, nON_EXHAUSTIVE_GUARDS_ERROR_ID ) import PprStyle ( PprStyle(..) ) import Pretty ( ppShow ) import SrcLoc ( SrcLoc{-instance-} ) @@ -42,23 +42,15 @@ necessary. The type argument gives the type of the ei. \begin{code} dsGuarded :: TypecheckedGRHSsAndBinds - -> SrcLoc -> DsM CoreExpr -dsGuarded (GRHSsAndBindsOut grhss binds err_ty) err_loc +dsGuarded (GRHSsAndBindsOut grhss binds err_ty) = dsBinds binds `thenDs` \ core_binds -> dsGRHSs err_ty PatBindMatch [] grhss `thenDs` \ (MatchResult can_it_fail _ core_grhss_fn _) -> case can_it_fail of CantFail -> returnDs (mkCoLetsAny core_binds (core_grhss_fn (panic "It can't fail"))) - CanFail -> newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String - returnDs (mkCoLetsAny core_binds (core_grhss_fn (error_expr str_var))) - where - unencoded_part_of_msg = escErrorMsg (ppShow 80 (ppr PprForUser err_loc)) - - error_expr :: Id -> CoreExpr - error_expr str_var = mkErrorApp err_ty str_var - (unencoded_part_of_msg - ++ "%N") --> ": non-exhaustive guards" + CanFail -> mkErrorAppDs nON_EXHAUSTIVE_GUARDS_ERROR_ID err_ty "" `thenDs` \ error_expr -> + returnDs (mkCoLetsAny core_binds (core_grhss_fn error_expr)) \end{code} Desugar a list of (grhs, expr) pairs [grhs = guarded diff --git a/ghc/compiler/deSugar/DsUtils.lhs b/ghc/compiler/deSugar/DsUtils.lhs index 700db9e238..9726092b57 100644 --- a/ghc/compiler/deSugar/DsUtils.lhs +++ b/ghc/compiler/deSugar/DsUtils.lhs @@ -15,7 +15,7 @@ module DsUtils ( combineMatchResults, dsExprToAtom, mkCoAlgCaseMatchResult, - mkAppDs, mkConDs, mkPrimDs, + mkAppDs, mkConDs, mkPrimDs, mkErrorAppDs, mkCoLetsMatchResult, mkCoPrimCaseMatchResult, mkFailurePair, @@ -23,7 +23,8 @@ module DsUtils ( mkSelectorBinds, mkTupleBind, mkTupleExpr, - selectMatchVars + selectMatchVars, + showForErr ) where import Ubiq @@ -37,10 +38,13 @@ import CoreSyn import DsMonad -import CoreUtils ( coreExprType, escErrorMsg, mkCoreIfThenElse, mkErrorApp ) -import PrelInfo ( stringTy ) -import Id ( idType, getInstantiatedDataConSig, mkTupleCon, +import CoreUtils ( coreExprType, mkCoreIfThenElse ) +import PprStyle ( PprStyle(..) ) +import PrelInfo ( stringTy, iRREFUT_PAT_ERROR_ID ) +import Pretty ( ppShow ) +import Id ( idType, dataConArgTys, mkTupleCon, DataCon(..), DictVar(..), Id(..), GenId ) +import Literal ( Literal(..) ) import TyCon ( mkTupleTyCon ) import Type ( mkTyVarTys, mkRhoTy, mkFunTys, isUnboxedType, applyTyCon, getAppDataTyCon @@ -141,7 +145,7 @@ mkCoAlgCaseMatchResult var alts -- We need to build new locals for the args of the constructor, -- and figuring out their types is somewhat tiresome. let - (_,arg_tys,_) = getInstantiatedDataConSig con tycon_arg_tys + arg_tys = dataConArgTys con tycon_arg_tys in newSysLocalsDs arg_tys `thenDs` \ arg_ids -> @@ -252,8 +256,6 @@ dsExprsToAtoms (arg:args) continue_with %* * %************************************************************************ -Plumb the desugarer's @UniqueSupply@ in/out of the @UniqSupply@ monad -world. \begin{code} mkAppDs :: CoreExpr -> [Type] -> [CoreExpr] -> DsM CoreExpr mkConDs :: Id -> [Type] -> [CoreExpr] -> DsM CoreExpr @@ -272,6 +274,24 @@ mkPrimDs op tys arg_exprs returnDs (mkPrim op [] tys vals) \end{code} +\begin{code} +showForErr :: Outputable a => a -> String -- Boring but useful +showForErr thing = ppShow 80 (ppr PprForUser thing) + +mkErrorAppDs :: Id -- The error function + -> Type -- Type to which it should be applied + -> String -- The error message string to pass + -> DsM CoreExpr + +mkErrorAppDs err_id ty msg + = getSrcLocDs `thenDs` \ (file, line) -> + let + full_msg = file ++ "|" ++ line ++ "|" ++msg + msg_lit = NoRepStr (_PK_ full_msg) + in + returnDs (mkApp (Var err_id) [] [ty] [LitArg msg_lit]) +\end{code} + %************************************************************************ %* * \subsection[mkSelectorBind]{Make a selector bind} @@ -303,17 +323,10 @@ mkSelectorBinds :: [TyVar] -- Variables wrt which the pattern is polymorphic -> DsM [(Id,CoreExpr)] mkSelectorBinds tyvars pat locals_and_globals val_expr - = getSrcLocDs `thenDs` \ (src_file, src_line) -> - - if is_simple_tuple_pat pat then + = if is_simple_tuple_pat pat then mkTupleBind tyvars [] locals_and_globals val_expr else - newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the string - let - src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line - error_string = src_loc_str ++ "%~" --> ": pattern-match failed on an irrefutable pattern" - error_msg = mkErrorApp res_ty str_var error_string - in + mkErrorAppDs iRREFUT_PAT_ERROR_ID res_ty "" `thenDs` \ error_msg -> matchSimply val_expr pat res_ty local_tuple error_msg `thenDs` \ tuple_expr -> mkTupleBind tyvars [] locals_and_globals tuple_expr where diff --git a/ghc/compiler/deSugar/Match.lhs b/ghc/compiler/deSugar/Match.lhs index c7d0b5d860..4380041333 100644 --- a/ghc/compiler/deSugar/Match.lhs +++ b/ghc/compiler/deSugar/Match.lhs @@ -18,16 +18,16 @@ import TcHsSyn ( TypecheckedPat(..), TypecheckedMatch(..), import DsHsSyn ( outPatType, collectTypedPatBinders ) import CoreSyn +import CoreUtils ( coreExprType ) import DsMonad import DsGRHSs ( dsGRHSs ) import DsUtils import MatchCon ( matchConFamily ) import MatchLit ( matchLiterals ) -import CoreUtils ( escErrorMsg, mkErrorApp ) import FieldLabel ( allFieldLabelTags, fieldLabelTag ) import Id ( idType, mkTupleCon, dataConSig, - recordSelectorFieldLabel, + dataConArgTys, recordSelectorFieldLabel, GenId{-instance-} ) import PprStyle ( PprStyle(..) ) @@ -38,7 +38,9 @@ import PrelInfo ( nilDataCon, consDataCon, mkTupleTy, mkListTy, integerTy, intPrimTy, charPrimTy, floatPrimTy, doublePrimTy, stringTy, addrTy, addrPrimTy, addrDataCon, - wordTy, wordPrimTy, wordDataCon ) + wordTy, wordPrimTy, wordDataCon, + pAT_ERROR_ID + ) import Type ( isPrimType, eqTy, getAppDataTyCon, instantiateTauTy ) @@ -329,14 +331,12 @@ tidy1 v (ConOpPat pat1 id pat2 ty) match_result tidy1 v (RecPat con_id pat_ty rpats) match_result = returnDs (ConPat con_id pat_ty pats, match_result) where - pats = map mk_pat tagged_arg_tys + pats = map mk_pat tagged_arg_tys -- Boring stuff to find the arg-tys of the constructor - (tyvars, _, arg_tys, _) = dataConSig con_id - (_, inst_tys, _) = getAppDataTyCon pat_ty - tenv = tyvars `zip` inst_tys - con_arg_tys' = map (instantiateTauTy tenv) arg_tys - tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags + (_, inst_tys, _) = getAppDataTyCon pat_ty + con_arg_tys' = dataConArgTys con_id inst_tys + tagged_arg_tys = con_arg_tys' `zip` allFieldLabelTags -- mk_pat picks a WildPat of the appropriate type for absent fields, -- and the specified pattern for present fields @@ -613,16 +613,12 @@ matchWrapper kind [(GRHSMatch matchWrapper kind matches error_string = flattenMatches kind matches `thenDs` \ eqns_info@(EqnInfo arg_pats (MatchResult _ result_ty _ _) : _) -> - selectMatchVars arg_pats `thenDs` \ new_vars -> - match new_vars eqns_info [] `thenDs` \ match_result -> + selectMatchVars arg_pats `thenDs` \ new_vars -> + match new_vars eqns_info [] `thenDs` \ match_result -> + + mkErrorAppDs pAT_ERROR_ID result_ty error_string `thenDs` \ fail_expr -> + extractMatchResult match_result fail_expr `thenDs` \ result_expr -> - getSrcLocDs `thenDs` \ (src_file, src_line) -> - newSysLocalDs stringTy `thenDs` \ str_var -> -- to hold the String - let - src_loc_str = escErrorMsg ('"' : src_file) ++ "%l" ++ src_line - fail_expr = mkErrorApp result_ty str_var (src_loc_str++": "++error_string) - in - extractMatchResult match_result fail_expr `thenDs` \ result_expr -> returnDs (new_vars, result_expr) \end{code} @@ -703,4 +699,15 @@ flattenMatches kind (match : matches) returnDs (EqnInfo pats (mkCoLetsMatchResult core_binds match_result)) where pats = reverse pats_so_far -- They've accumulated in reverse order + + flatten_match pats_so_far (SimpleMatch expr) + = dsExpr expr `thenDs` \ core_expr -> + returnDs (EqnInfo pats + (MatchResult CantFail (coreExprType core_expr) + (\ ignore -> core_expr) + NoMatchContext)) + -- The NoMatchContext is just a place holder. In a simple match, + -- the matching can't fail, so we won't generate an error message. + where + pats = reverse pats_so_far -- They've accumulated in reverse order \end{code} diff --git a/ghc/compiler/hsSyn/HsBinds.lhs b/ghc/compiler/hsSyn/HsBinds.lhs index bcc9133cb3..15dafc9d0e 100644 --- a/ghc/compiler/hsSyn/HsBinds.lhs +++ b/ghc/compiler/hsSyn/HsBinds.lhs @@ -22,7 +22,10 @@ import HsTypes ( PolyType ) --others: import Id ( DictVar(..), Id(..), GenId ) -import Outputable +import Name ( pprNonOp ) +import Outputable ( interpp'SP, ifnotPprForUser, + Outputable(..){-instance * (,)-} + ) import Pretty import SrcLoc ( SrcLoc{-instances-} ) --import TyVar ( GenTyVar{-instances-} ) diff --git a/ghc/compiler/hsSyn/HsDecls.lhs b/ghc/compiler/hsSyn/HsDecls.lhs index 6952ef0c8b..750519a66c 100644 --- a/ghc/compiler/hsSyn/HsDecls.lhs +++ b/ghc/compiler/hsSyn/HsDecls.lhs @@ -20,7 +20,10 @@ import HsPragmas ( DataPragmas, ClassPragmas, import HsTypes -- others: -import Outputable +import Name ( pprOp, pprNonOp ) +import Outputable ( interppSP, interpp'SP, + Outputable(..){-instance * []-} + ) import Pretty import SrcLoc ( SrcLoc ) import Util ( cmpList, panic#{-ToDo:rm eventually-} ) diff --git a/ghc/compiler/hsSyn/HsExpr.lhs b/ghc/compiler/hsSyn/HsExpr.lhs index 8c62d1835d..0a0397ec27 100644 --- a/ghc/compiler/hsSyn/HsExpr.lhs +++ b/ghc/compiler/hsSyn/HsExpr.lhs @@ -19,7 +19,8 @@ import HsTypes ( PolyType ) -- others: import Id ( DictVar(..), GenId, Id(..) ) -import Outputable +import Name ( isOpLexeme, pprOp ) +import Outputable ( interppSP, interpp'SP, ifnotPprForUser ) import PprType ( pprGenType, pprParendGenType, GenType{-instance-} ) import Pretty import PprStyle ( PprStyle(..) ) @@ -109,6 +110,10 @@ data HsExpr tyvar uvar id pat | RecordUpd (HsExpr tyvar uvar id pat) (HsRecordBinds tyvar uvar id pat) + | RecordUpdOut (HsExpr tyvar uvar id pat) -- TRANSLATION + [id] -- Dicts needed for construction + (HsRecordBinds tyvar uvar id pat) + | ExprWithTySig -- signature binding (HsExpr tyvar uvar id pat) (PolyType id) @@ -165,6 +170,11 @@ Everything from here on appears only in typechecker output. | SingleDict -- a simple special case of Dictionary id -- local dictionary name + | HsCon -- TRANSLATION; a constructor application + Id -- used only in the RHS of constructor definitions + [GenType tyvar uvar] + [HsExpr tyvar uvar id pat] + type HsRecordBinds tyvar uvar id pat = [(id, HsExpr tyvar uvar id pat, Bool)] -- True <=> source code used "punning", diff --git a/ghc/compiler/hsSyn/HsLoop.lhi b/ghc/compiler/hsSyn/HsLoop.lhi index e425c234d1..34b1926073 100644 --- a/ghc/compiler/hsSyn/HsLoop.lhi +++ b/ghc/compiler/hsSyn/HsLoop.lhi @@ -2,10 +2,11 @@ interface HsLoop where -import HsExpr( HsExpr ) -import Outputable( NamedThing, Outputable ) -import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds ) -import HsDecls ( ConDecl ) +import HsExpr ( HsExpr ) +import HsBinds ( Bind, HsBinds, MonoBinds, Sig, nullBinds, nullMonoBinds ) +import HsDecls ( ConDecl ) +import Name ( NamedThing ) +import Outputable ( Outputable ) -- HsExpr outputs data HsExpr tyvar uvar id pat diff --git a/ghc/compiler/hsSyn/HsMatches.lhs b/ghc/compiler/hsSyn/HsMatches.lhs index b257cd336e..7aed7aee48 100644 --- a/ghc/compiler/hsSyn/HsMatches.lhs +++ b/ghc/compiler/hsSyn/HsMatches.lhs @@ -45,6 +45,8 @@ data Match tyvar uvar id pat = PatMatch pat (Match tyvar uvar id pat) | GRHSMatch (GRHSsAndBinds tyvar uvar id pat) + + | SimpleMatch (HsExpr tyvar uvar id pat) -- Used in translations \end{code} Sets of guarded right hand sides (GRHSs). In: diff --git a/ghc/compiler/hsSyn/HsPat.lhs b/ghc/compiler/hsSyn/HsPat.lhs index 9cf88be29a..d96e8ecc8c 100644 --- a/ghc/compiler/hsSyn/HsPat.lhs +++ b/ghc/compiler/hsSyn/HsPat.lhs @@ -26,7 +26,8 @@ import HsLoop ( HsExpr ) -- others: import Id ( GenId, dataConSig ) import Maybes ( maybeToBool ) -import Outputable +import Name ( pprOp, pprNonOp ) +import Outputable ( interppSP, interpp'SP, ifPprShowAll ) import PprStyle ( PprStyle(..) ) import Pretty import TyCon ( maybeTyConSingleCon ) diff --git a/ghc/compiler/prelude/PrelInfo.lhs b/ghc/compiler/prelude/PrelInfo.lhs index f857b89329..901af61dfb 100644 --- a/ghc/compiler/prelude/PrelInfo.lhs +++ b/ghc/compiler/prelude/PrelInfo.lhs @@ -18,7 +18,13 @@ module PrelInfo ( BuiltinKeys(..), BuiltinIdInfos(..), -- *odd* values that need to be reached out and grabbed: - eRROR_ID, pAT_ERROR_ID, aBSENT_ERROR_ID, + eRROR_ID, + pAT_ERROR_ID, + rEC_CON_ERROR_ID, + rEC_UPD_ERROR_ID, + iRREFUT_PAT_ERROR_ID, + nON_EXHAUSTIVE_GUARDS_ERROR_ID, + aBSENT_ERROR_ID, packStringForCId, unpackCStringId, unpackCString2Id, unpackCStringAppendId, unpackCStringFoldrId, @@ -104,8 +110,7 @@ import CmdLineOpts ( opt_HideBuiltinNames, import FiniteMap ( FiniteMap, emptyFM, listToFM ) import Id ( mkTupleCon, GenId, Id(..) ) import Maybes ( catMaybes ) -import Name ( mkBuiltinName ) -import Outputable ( getOrigName ) +import Name ( mkBuiltinName, getOrigName ) import RnHsSyn ( RnName(..) ) import TyCon ( tyConDataCons, mkFunTyCon, mkTupleTyCon, TyCon ) import Type diff --git a/ghc/compiler/prelude/PrelVals.lhs b/ghc/compiler/prelude/PrelVals.lhs index 5c5375a590..1f0fe9529b 100644 --- a/ghc/compiler/prelude/PrelVals.lhs +++ b/ghc/compiler/prelude/PrelVals.lhs @@ -70,8 +70,19 @@ pc_bottoming_Id key mod name ty eRROR_ID = pc_bottoming_Id errorIdKey pRELUDE_BUILTIN SLIT("error") errorTy +generic_ERROR_ID u n + = pc_bottoming_Id u pRELUDE_BUILTIN n errorTy + pAT_ERROR_ID - = pc_bottoming_Id patErrorIdKey pRELUDE_BUILTIN SLIT("patError#") errorTy + = generic_ERROR_ID patErrorIdKey SLIT("patError#") +rEC_CON_ERROR_ID + = generic_ERROR_ID recConErrorIdKey SLIT("recConError#") +rEC_UPD_ERROR_ID + = generic_ERROR_ID recUpdErrorIdKey SLIT("recUpdError#") +iRREFUT_PAT_ERROR_ID + = generic_ERROR_ID irrefutPatErrorIdKey SLIT("irrefutPatError#") +nON_EXHAUSTIVE_GUARDS_ERROR_ID + = generic_ERROR_ID nonExhaustiveGuardsErrorIdKey SLIT("nonExhaustiveGuardsError#") aBSENT_ERROR_ID = pc_bottoming_Id absentErrorIdKey pRELUDE_BUILTIN SLIT("absent#") diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index f60cff34c0..4253749fe6 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -27,17 +27,18 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where +import Ubiq{-uitous-} + import Id ( externallyVisibleId, GenId, Id(..) ) import CStrings ( identToC, stringToC ) import Maybes ( Maybe(..) ) -import Name ( showRdr, RdrName ) -import Outputable +import Name ( showRdr, getOccName, RdrName ) import Pretty ( ppShow, prettyToUn ) import PprStyle ( PprStyle(..) ) import UniqSet import Unpretty import Util -import Ubiq + showId = panic "Whoops" pprIdInUnfolding = panic "Whoops" \end{code} diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs index eb8f1430ad..6f6b12b7c8 100644 --- a/ghc/compiler/profiling/SCCauto.lhs +++ b/ghc/compiler/profiling/SCCauto.lhs @@ -23,9 +23,9 @@ import CmdLineOpts ( opt_AutoSccsOnAllToplevs, opt_SccGroup ) import CoreSyn -import Id ( isTopLevId, GenId{-instances-} ) -import Outputable ( isExported ) import CostCentre ( mkAutoCC, IsCafCC(..) ) +import Id ( isTopLevId, GenId{-instances-} ) +import Name ( isExported ) \end{code} \begin{code} diff --git a/ghc/compiler/reader/RdrHsSyn.lhs b/ghc/compiler/reader/RdrHsSyn.lhs index 29f69cb316..758ea33f1e 100644 --- a/ghc/compiler/reader/RdrHsSyn.lhs +++ b/ghc/compiler/reader/RdrHsSyn.lhs @@ -52,7 +52,7 @@ module RdrHsSyn ( import Ubiq import HsSyn -import Outputable ( ExportFlag(..) ) +import Name ( ExportFlag(..) ) \end{code} \begin{code} diff --git a/ghc/compiler/rename/Rename.lhs b/ghc/compiler/rename/Rename.lhs index 386dcbe9a2..e116f7e696 100644 --- a/ghc/compiler/rename/Rename.lhs +++ b/ghc/compiler/rename/Rename.lhs @@ -26,8 +26,7 @@ import MainMonad import Bag ( isEmptyBag, unionBags, bagToList, listToBag ) import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( emptyFM, eltsFM ) -import Name ( Name, RdrName(..) ) -import Outputable ( getOrigNameRdr, isLocallyDefined ) +import Name ( getOrigNameRdr, isLocallyDefined, Name, RdrName(..) ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) import UniqFM ( emptyUFM, lookupUFM, addListToUFM_C, eltsUFM ) import UniqSupply ( splitUniqSupply ) @@ -67,7 +66,7 @@ renameModule b_names b_keys us = findHiFiles `thenPrimIO` \ hi_files -> newVar (emptyFM, hi_files) `thenPrimIO` \ iface_var -> - fixPrimIO ( \ (_, _, _, _, rec_occ_fm, rec_export_fn) -> + fixPrimIO ( \ ~(_, _, _, _, rec_occ_fm, rec_export_fn) -> let rec_occ_fn :: Name -> [RdrName] rec_occ_fn n = case lookupUFM rec_occ_fm n of diff --git a/ghc/compiler/rename/RnExpr.lhs b/ghc/compiler/rename/RnExpr.lhs index 86ba6803bf..04db620b99 100644 --- a/ghc/compiler/rename/RnExpr.lhs +++ b/ghc/compiler/rename/RnExpr.lhs @@ -25,8 +25,7 @@ import RnHsSyn import RnMonad import ErrUtils ( addErrLoc ) -import Name ( isLocallyDefinedName, Name, RdrName ) -import Outputable ( pprOp ) +import Name ( isLocallyDefinedName, pprOp, Name, RdrName ) import Pretty import UniqFM ( lookupUFM ) import UniqSet ( emptyUniqSet, unitUniqSet, diff --git a/ghc/compiler/rename/RnHsSyn.lhs b/ghc/compiler/rename/RnHsSyn.lhs index 9c8ab0dfdf..7f4b74b43e 100644 --- a/ghc/compiler/rename/RnHsSyn.lhs +++ b/ghc/compiler/rename/RnHsSyn.lhs @@ -12,11 +12,11 @@ import Ubiq import HsSyn -import Name ( isLocalName, nameUnique, Name, RdrName ) import Id ( GenId, Id(..) ) -import Outputable ( Outputable(..) ) -import PprType ( GenType, GenTyVar, TyCon ) +import Name ( isLocalName, nameUnique, Name, RdrName ) +import Outputable ( Outputable(..){-instance * []-} ) import PprStyle ( PprStyle(..) ) +import PprType ( GenType, GenTyVar, TyCon ) import Pretty import TyCon ( TyCon ) import TyVar ( GenTyVar ) diff --git a/ghc/compiler/rename/RnMonad.lhs b/ghc/compiler/rename/RnMonad.lhs index 49765f117f..076f7d16d2 100644 --- a/ghc/compiler/rename/RnMonad.lhs +++ b/ghc/compiler/rename/RnMonad.lhs @@ -48,10 +48,9 @@ import ErrUtils ( Error(..), Warning(..) ) import FiniteMap ( FiniteMap, emptyFM, lookupFM, addToFM ) import Maybes ( assocMaybe ) import Name ( Module(..), RdrName(..), isQual, - Name, mkLocalName, mkImplicitName + Name, mkLocalName, mkImplicitName, + getOccName ) -import Outputable ( getOccName ) -import PprStyle ( PprStyle ) import Pretty ( Pretty(..), PrettyRep ) import SrcLoc ( SrcLoc, mkUnknownSrcLoc ) import UniqFM ( UniqFM, emptyUFM ) diff --git a/ghc/compiler/rename/RnNames.lhs b/ghc/compiler/rename/RnNames.lhs index 384f9f844a..b0ec1905be 100644 --- a/ghc/compiler/rename/RnNames.lhs +++ b/ghc/compiler/rename/RnNames.lhs @@ -26,8 +26,10 @@ import RnUtils ( RnEnv(..), emptyRnEnv, extendGlobalRnEnv, qualNameErr, dupName import Bag ( emptyBag, unitBag, unionBags, unionManyBags, mapBag, listToBag, bagToList ) import ErrUtils ( Error(..), Warning(..), addShortErrLocLine ) import FiniteMap ( fmToList ) -import Name ( RdrName(..), isQual, mkTopLevName, mkImportedName, nameExportFlag, Name ) -import Outputable ( getLocalName, getSrcLoc, pprNonOp ) +import Name ( RdrName(..), Name, isQual, mkTopLevName, + mkImportedName, nameExportFlag, + getLocalName, getSrcLoc, pprNonOp + ) import PrelInfo ( BuiltinNames(..), BuiltinKeys(..) ) import PrelMods ( fromPrelude ) import Pretty diff --git a/ghc/compiler/rename/RnSource.lhs b/ghc/compiler/rename/RnSource.lhs index 235e945938..16cd506373 100644 --- a/ghc/compiler/rename/RnSource.lhs +++ b/ghc/compiler/rename/RnSource.lhs @@ -21,9 +21,8 @@ import RnBinds ( rnTopBinds, rnMethodBinds ) import Bag ( bagToList ) import Class ( derivableClassKeys ) import ListSetOps ( unionLists, minusList ) -import Name ( RdrName ) import Maybes ( maybeToBool, catMaybes ) -import Outputable ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..) ) +import Name ( isLocallyDefined, isAvarid, getLocalName, ExportFlag(..), RdrName ) import Pretty import SrcLoc ( SrcLoc ) import Unique ( Unique ) diff --git a/ghc/compiler/rename/RnUtils.lhs b/ghc/compiler/rename/RnUtils.lhs index f79e7c47a4..721fa8e245 100644 --- a/ghc/compiler/rename/RnUtils.lhs +++ b/ghc/compiler/rename/RnUtils.lhs @@ -30,8 +30,7 @@ import ErrUtils ( addShortErrLocLine, addErrLoc ) import FiniteMap ( FiniteMap, emptyFM, isEmptyFM, lookupFM, addListToFM, addToFM ) import Maybes ( maybeToBool ) -import Name ( RdrName(..), isQual ) -import Outputable ( pprNonOp, getLocalName ) +import Name ( RdrName(..), isQual, pprNonOp, getLocalName ) import PprStyle ( PprStyle(..) ) import Pretty import RnHsSyn ( RnName ) diff --git a/ghc/compiler/simplCore/OccurAnal.lhs b/ghc/compiler/simplCore/OccurAnal.lhs index 94e9fc6c0a..0574b4150e 100644 --- a/ghc/compiler/simplCore/OccurAnal.lhs +++ b/ghc/compiler/simplCore/OccurAnal.lhs @@ -33,7 +33,8 @@ import Id ( idWantsToBeINLINEd, isConstMethodId, GenId{-instance Eq-} ) import Maybes ( maybeToBool ) -import Outputable ( isExported, Outputable(..){-instance * (,) -} ) +import Name ( isExported ) +import Outputable ( Outputable(..){-instance * (,) -} ) import PprCore import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} ) diff --git a/ghc/compiler/simplCore/SATMonad.lhs b/ghc/compiler/simplCore/SATMonad.lhs index 1b6b20c0b1..eb0b36d102 100644 --- a/ghc/compiler/simplCore/SATMonad.lhs +++ b/ghc/compiler/simplCore/SATMonad.lhs @@ -217,7 +217,7 @@ saTransform binder rhs -- tag (or Exported tag) modified. fake_binder = mkSysLocal (getOccName binder _APPEND_ SLIT("_fsat")) - (getItsUnique binder) + (uniqueOf binder) (idType binder) mkUnknownSrcLoc rec_body = mkValLam non_static_args diff --git a/ghc/compiler/simplCore/SimplEnv.lhs b/ghc/compiler/simplCore/SimplEnv.lhs index f2d0fe60f5..f07a328b01 100644 --- a/ghc/compiler/simplCore/SimplEnv.lhs +++ b/ghc/compiler/simplCore/SimplEnv.lhs @@ -64,7 +64,8 @@ import Id ( idType, getIdUnfolding, getIdStrictness, IdEnv(..), IdSet(..), GenId ) import IdInfo ( StrictnessInfo ) import Literal ( isNoRepLit, Literal{-instances-} ) -import Outputable ( isLocallyDefined, Outputable(..){-instances-} ) +import Name ( isLocallyDefined ) +import Outputable ( Outputable(..){-instances-} ) import PprCore -- various instances import PprStyle ( PprStyle(..) ) import PprType ( GenType, GenTyVar ) diff --git a/ghc/compiler/simplCore/SimplPgm.lhs b/ghc/compiler/simplCore/SimplPgm.lhs index dc9d1c4846..3db8a5f5c8 100644 --- a/ghc/compiler/simplCore/SimplPgm.lhs +++ b/ghc/compiler/simplCore/SimplPgm.lhs @@ -20,8 +20,8 @@ import Id ( externallyVisibleId, GenId{-instance Ord3-} ) import Maybes ( catMaybes ) +import Name ( isExported ) import OccurAnal ( occurAnalyseBinds ) -import Outputable ( isExported ) import Pretty ( ppAboves, ppBesides, ppInt, ppChar, ppStr ) import SimplEnv import SimplMonad diff --git a/ghc/compiler/simplCore/SimplUtils.lhs b/ghc/compiler/simplCore/SimplUtils.lhs index f546fbc054..3e9c6aab64 100644 --- a/ghc/compiler/simplCore/SimplUtils.lhs +++ b/ghc/compiler/simplCore/SimplUtils.lhs @@ -27,7 +27,7 @@ import BinderInfo import CmdLineOpts ( SimplifierSwitch(..) ) import CoreSyn import CoreUtils ( manifestlyWHNF ) -import Id ( idType, isBottomingId, idWantsToBeINLINEd, +import Id ( idType, isBottomingId, idWantsToBeINLINEd, dataConArgTys, getIdArity, GenId{-instance Eq-} ) import IdInfo ( arityMaybe ) @@ -40,7 +40,6 @@ import Type ( eqTy, isPrimType, maybeAppDataTyCon, getTyVar_maybe ) import TyVar ( GenTyVar{-instance Eq-} ) import Util ( isIn, panic ) -getInstantiatedDataConSig = panic "SimplUtils.getInstantiatedDataConSig (ToDo)" \end{code} @@ -375,7 +374,7 @@ mkIdentityAlts rhs_ty = case (maybeAppDataTyCon rhs_ty) of Just (tycon, ty_args, [data_con]) -> -- algebraic type suitable for unpacking let - (_,inst_con_arg_tys,_) = getInstantiatedDataConSig data_con ty_args + inst_con_arg_tys = dataConArgTys data_con ty_args in newIds inst_con_arg_tys `thenSmpl` \ new_bindees -> let diff --git a/ghc/compiler/simplCore/Simplify.lhs b/ghc/compiler/simplCore/Simplify.lhs index 3bbb88af2b..76b17d945b 100644 --- a/ghc/compiler/simplCore/Simplify.lhs +++ b/ghc/compiler/simplCore/Simplify.lhs @@ -26,7 +26,7 @@ import Id ( idType, idWantsToBeINLINEd, import IdInfo ( willBeDemanded, DemandInfo ) import Literal ( isNoRepLit ) import Maybes ( maybeToBool ) -import Outputable ( isLocallyDefined ) +import Name ( isLocallyDefined ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import PrelInfo ( realWorldStateTy ) diff --git a/ghc/compiler/simplStg/SimplStg.lhs b/ghc/compiler/simplStg/SimplStg.lhs index 51ea249d60..48ac2b6501 100644 --- a/ghc/compiler/simplStg/SimplStg.lhs +++ b/ghc/compiler/simplStg/SimplStg.lhs @@ -14,7 +14,7 @@ import StgSyn import StgUtils import LambdaLift ( liftProgram ) -import Outputable ( isLocallyDefined ) +import Name ( isLocallyDefined ) import SCCfinal ( stgMassageForProfiling ) import SatStgRhs ( satStgRhs ) import StgLint ( lintStgBindings ) @@ -33,7 +33,7 @@ import Id ( nullIdEnv, lookupIdEnv, addOneToIdEnv, ) import MainMonad ( writeMn, thenMn_, thenMn, returnMn, MainIO(..) ) import Maybes ( maybeToBool ) -import Outputable ( isExported ) +import Name ( isExported ) import PprType ( GenType{-instance Outputable-} ) import Pretty ( ppShow, ppAbove, ppAboves, ppStr ) import UniqSupply ( splitUniqSupply ) diff --git a/ghc/compiler/simplStg/StgVarInfo.lhs b/ghc/compiler/simplStg/StgVarInfo.lhs index 097251a2cb..ed675f705c 100644 --- a/ghc/compiler/simplStg/StgVarInfo.lhs +++ b/ghc/compiler/simplStg/StgVarInfo.lhs @@ -25,7 +25,7 @@ import Id ( emptyIdSet, mkIdSet, minusIdSet, GenId{-instance Eq-} ) import Maybes ( maybeToBool ) -import Outputable ( isLocallyDefined ) +import Name ( isLocallyDefined ) import PprStyle ( PprStyle(..) ) import PprType ( GenType{-instance Outputable-} ) import Util ( panic, pprPanic, assertPanic ) diff --git a/ghc/compiler/specialise/SpecUtils.lhs b/ghc/compiler/specialise/SpecUtils.lhs index e1aa07065a..4f83c8ef7c 100644 --- a/ghc/compiler/specialise/SpecUtils.lhs +++ b/ghc/compiler/specialise/SpecUtils.lhs @@ -33,7 +33,7 @@ import Id ( idType, isDictFunId, isConstMethodId_maybe, GenId {-instance NamedThing -} ) import Maybes ( maybeToBool, catMaybes, firstJust ) -import Outputable ( isAvarop, pprNonOp, getOrigName ) +import Name ( isAvarop, pprNonOp, getOrigName ) import PprStyle ( PprStyle(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, TyCon{-ditto-}, GenType{-ditto-}, GenTyVar diff --git a/ghc/compiler/specialise/Specialise.lhs b/ghc/compiler/specialise/Specialise.lhs index 18d1d078e5..15230b43e0 100644 --- a/ghc/compiler/specialise/Specialise.lhs +++ b/ghc/compiler/specialise/Specialise.lhs @@ -44,7 +44,8 @@ import Id ( idType, isDefaultMethodId_maybe, toplevelishId, ) import Literal ( Literal{-instance Outputable-} ) import Maybes ( catMaybes, firstJust, maybeToBool ) -import Outputable ( interppSP, isLocallyDefined, Outputable(..){-instance * []-} ) +import Name ( isLocallyDefined ) +import Outputable ( interppSP, Outputable(..){-instance * []-} ) import PprStyle ( PprStyle(..) ) import PprType ( pprGenType, pprParendGenType, pprMaybeTy, GenType{-instance Outputable-}, GenTyVar{-ditto-}, diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 50a9bc07bd..c3bd393c51 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -28,7 +28,7 @@ import Id ( mkSysLocal, idType, isBottomingId, IdEnv(..), GenId{-instance NamedThing-} ) import Literal ( mkMachInt, Literal(..) ) -import Outputable ( isExported ) +import Name ( isExported ) import PrelInfo ( unpackCStringId, unpackCString2Id, stringTy, integerTy, rationalTy, ratioDataCon, integerZeroId, integerPlusOneId, diff --git a/ghc/compiler/stgSyn/StgLint.lhs b/ghc/compiler/stgSyn/StgLint.lhs index 8d1ccfa5ec..9f3c14b224 100644 --- a/ghc/compiler/stgSyn/StgLint.lhs +++ b/ghc/compiler/stgSyn/StgLint.lhs @@ -13,7 +13,7 @@ import Ubiq{-uitous-} import StgSyn import Bag ( emptyBag, isEmptyBag, snocBag, foldBag ) -import Id ( idType, isDataCon, +import Id ( idType, isDataCon, dataConArgTys, emptyIdSet, isEmptyIdSet, elementOfIdSet, mkIdSet, intersectIdSets, unionIdSets, idSetToList, IdSet(..), @@ -21,9 +21,8 @@ import Id ( idType, isDataCon, ) import Literal ( literalType, Literal{-instance Outputable-} ) import Maybes ( catMaybes ) -import Outputable ( Outputable(..){-instance * []-}, - isLocallyDefined, getSrcLoc - ) +import Name ( isLocallyDefined, getSrcLoc ) +import Outputable ( Outputable(..){-instance * []-} ) import PprType ( GenType{-instance Outputable-}, TyCon ) import Pretty -- quite a bit of it import PrimOp ( primOpType ) @@ -35,7 +34,6 @@ import Util ( zipEqual, pprPanic, panic, panic# ) infixr 9 `thenL`, `thenL_`, `thenMaybeL`, `thenMaybeL_` -getInstantiatedDataConSig = panic "StgLint.getInstantiatedDataConSig (ToDo)" splitTypeWithDictsAsArgs = panic "StgLint.splitTypeWithDictsAsArgs (ToDo)" unDictifyTy = panic "StgLint.unDictifyTy (ToDo)" \end{code} @@ -228,7 +226,7 @@ lintAlgAlt scrut_ty (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) `thenL_` checkL (length arg_tys == length args) (mkAlgAltMsg3 con args) diff --git a/ghc/compiler/stgSyn/StgSyn.lhs b/ghc/compiler/stgSyn/StgSyn.lhs index 395eaa077e..ba87f68fb9 100644 --- a/ghc/compiler/stgSyn/StgSyn.lhs +++ b/ghc/compiler/stgSyn/StgSyn.lhs @@ -44,8 +44,8 @@ import Ubiq{-uitous-} import CostCentre ( showCostCentre ) import Id ( idPrimRep, GenId{-instance NamedThing-} ) import Literal ( literalPrimRep, isLitLitLit, Literal{-instance Outputable-} ) -import Outputable ( isExported, isOpLexeme, ifPprDebug, - interppSP, interpp'SP, +import Name ( isExported, isOpLexeme ) +import Outputable ( ifPprDebug, interppSP, interpp'SP, Outputable(..){-instance * Bool-} ) import PprStyle ( PprStyle(..) ) diff --git a/ghc/compiler/stranal/SaAbsInt.lhs b/ghc/compiler/stranal/SaAbsInt.lhs index 1020b6726b..11c621fb33 100644 --- a/ghc/compiler/stranal/SaAbsInt.lhs +++ b/ghc/compiler/stranal/SaAbsInt.lhs @@ -21,7 +21,7 @@ import CoreSyn import CoreUnfold ( UnfoldingDetails(..), FormSummary ) import CoreUtils ( unTagBinders ) import Id ( idType, getIdStrictness, getIdUnfolding, - dataConSig + dataConSig, dataConArgTys ) import IdInfo ( StrictnessInfo(..), Demand(..), wwPrim, wwStrict, wwEnum, wwUnpack @@ -44,7 +44,6 @@ import Util ( isIn, isn'tIn, nOfThem, zipWithEqual, pprTrace, panic, pprPanic, assertPanic ) -getInstantiatedDataConSig = panic "SaAbsInt.getInstantiatedDataConSig (ToDo)" returnsRealWorld = panic "SaAbsInt.returnsRealWorld (ToDo)" \end{code} @@ -848,7 +847,7 @@ findRecDemand strflags seen str_fn abs_fn ty Just (tycon,tycon_arg_tys,[data_con]) | tycon `not_elem` seen -> -- Single constructor case, tycon not already seen higher up let - (_,cmpnt_tys,_) = getInstantiatedDataConSig data_con tycon_arg_tys + cmpnt_tys = dataConArgTys data_con tycon_arg_tys prod_len = length cmpnt_tys compt_strict_infos diff --git a/ghc/compiler/stranal/WwLib.lhs b/ghc/compiler/stranal/WwLib.lhs index 4d1fa7a576..0b9913ceef 100644 --- a/ghc/compiler/stranal/WwLib.lhs +++ b/ghc/compiler/stranal/WwLib.lhs @@ -15,7 +15,7 @@ module WwLib ( import Ubiq{-uitous-} import CoreSyn -import Id ( idType, mkSysLocal ) +import Id ( idType, mkSysLocal, dataConArgTys ) import IdInfo ( mkStrictnessInfo, nonAbsentArgs, Demand(..) ) import PrelInfo ( aBSENT_ERROR_ID ) import SrcLoc ( mkUnknownSrcLoc ) @@ -26,7 +26,6 @@ import UniqSupply ( returnUs, thenUs, thenMaybeUs, import Util ( zipWithEqual, assertPanic, panic ) quantifyTy = panic "WwLib.quantifyTy" -getInstantiatedDataConSig = panic "WwLib.getInstantiatedDataConSig" \end{code} %************************************************************************ @@ -327,8 +326,7 @@ mk_ww_arg_processing (arg : args) (WwUnpack cmpnt_infos : infos) max_extra_args -- The main event: a single-constructor data type let - (_,inst_con_arg_tys,_) - = getInstantiatedDataConSig data_con tycon_arg_tys + inst_con_arg_tys = dataConArgTys data_con tycon_arg_tys in getUniques (length inst_con_arg_tys) `thenUs` \ uniqs -> diff --git a/ghc/compiler/typecheck/Inst.lhs b/ghc/compiler/typecheck/Inst.lhs index 71d7651383..fd242812a5 100644 --- a/ghc/compiler/typecheck/Inst.lhs +++ b/ghc/compiler/typecheck/Inst.lhs @@ -45,7 +45,7 @@ import Bag ( emptyBag, unitBag, unionBags, unionManyBags, listToBag, consBag ) import Class ( Class(..), GenClass, ClassInstEnv(..), getClassInstEnv ) import Id ( GenId, idType, mkInstId ) import MatchEnv ( lookupMEnv, insertMEnv ) -import Name ( mkLocalName, Name ) +import Name ( mkLocalName, getLocalName, Name ) import Outputable import PprType ( GenClass, TyCon, GenType, GenTyVar ) import PprStyle ( PprStyle(..) ) @@ -538,6 +538,10 @@ data InstOrigin s = OccurrenceOf (TcIdOcc s) -- Occurrence of an overloaded identifier | OccurrenceOfCon Id -- Occurrence of a data constructor + | RecordUpdOrigin + + | DataDeclOrigin -- Typechecking a data declaration + | InstanceDeclOrigin -- Typechecking an instance decl | LiteralOrigin HsLit -- Occurrence of a literal diff --git a/ghc/compiler/typecheck/TcBinds.lhs b/ghc/compiler/typecheck/TcBinds.lhs index 16e80698b4..7bd91f9897 100644 --- a/ghc/compiler/typecheck/TcBinds.lhs +++ b/ghc/compiler/typecheck/TcBinds.lhs @@ -36,7 +36,7 @@ import Kind ( mkBoxedTypeKind, mkTypeKind ) import Id ( GenId, idType, mkUserId ) import IdInfo ( noIdInfo ) import Maybes ( assocMaybe, catMaybes, Maybe(..) ) -import Outputable ( pprNonOp ) +import Name ( pprNonOp ) import PragmaInfo ( PragmaInfo(..) ) import Pretty import RnHsSyn ( RnName ) -- instances @@ -213,6 +213,175 @@ tcBindAndSigs binder_rn_names bind sigs prag_info_fn RecBind _ -> mkTypeKind -- Non-recursive, so we permit unboxed types \end{code} + +=========== +\begin{code} +{- + +data SigInfo + = SigInfo RnName + (TcIdBndr s) -- Polymorpic version + (TcIdBndr s) -- Monomorphic verstion + [TcType s] [TcIdOcc s] -- Instance information for the monomorphic version + + + + -- Deal with type signatures + tcTySigs sigs `thenTc` \ sig_infos -> + let + sig_binders = [binder | SigInfo binder _ _ _ _ <- sig_infos] + poly_sigs = [(name,poly) | SigInfo name poly _ _ _ <- sig_infos] + mono_sigs = [(name,mono) | SigInfo name _ mono _ _ <- sig_infos] + nosig_binders = binders `minusList` sig_binders + in + + + -- Typecheck the binding group + tcExtendLocalEnv poly_sigs ( + newMonoIds nosig_binders kind (\ nosig_local_ids -> + tcMonoBinds mono_sigs mono_binds `thenTc` \ binds_w_lies -> + returnTc (nosig_local_ids, binds_w_lies) + )) `thenTc` \ (nosig_local_ids, binds_w_lies) -> + + + -- Decide what to generalise over + getImplicitStuffToGen sig_ids binds_w_lies + `thenTc` \ (tyvars_not_to_gen, tyvars_to_gen, lie_to_gen) -> + + + -- Make poly_ids for all the binders that don't have type signatures + let + dicts_to_gen = map instToId (bagToList lie_to_gen) + dict_tys = map tcIdType dicts_to_gen + + mk_poly binder local_id = mkUserId (getName binder) ty noPragmaInfo + where + ty = mkForAllTys tyvars_to_gen $ + mkFunTys dict_tys $ + tcIdType local_id + + tys_to_gen = mkTyVarTys tyvars_to_gen + more_sig_infos = [ SigInfo binder (mk_poly binder local_id) + local_id tys_to_gen dicts_to_gen lie_to_gen + | (binder, local_id) <- nosig_binders `zipEqual` nosig_local_ids + ] + + local_binds = [ (local_id, DictApp (mkHsTyApp (HsVar local_id) inst_tys) dicts) + | SigInfo _ _ local_id inst_tys dicts <- more_sig_infos + ] + + all_sig_infos = sig_infos ++ more_sig_infos -- Contains a "signature" for each binder + in + + + -- Now generalise the bindings + let + find_sig lid = head [ (pid, tvs, ds, lie) + | SigInfo _ pid lid' tvs ds lie, + lid==lid' + ] + -- Do it again, but with increased free_tyvars/reduced_tyvars_to_gen: + -- We still need to do this simplification, because some dictionaries + -- may gratuitously constrain some tyvars over which we *are* going + -- to generalise. + -- For example d::Eq (Foo a b), where Foo is instanced as above. + gen_bind (bind, lie) + = tcSimplifyWithExtraGlobals tyvars_not_to_gen tyvars_to_gen avail lie + `thenTc` \ (lie_free, dict_binds) -> + returnTc (AbsBind tyvars_to_gen_here + dicts + (local_ids `zipEqual` poly_ids) + (dict_binds ++ local_binds) + bind, + lie_free) + where + local_ids = bindersOf bind + local_sigs = [sig | sig@(SigInfo _ _ local_id _ _) <- all_sig_infos, + local_id `elem` local_ids + ] + + (tyvars_to_gen_here, dicts, avail) + = case (local_ids, sigs) of + + ([local_id], [SigInfo _ _ _ tyvars_to_gen dicts lie]) + -> (tyvars_to_gen, dicts, lie) + + other -> (tyvars_to_gen, dicts, avail) +\end{code} + +@getImplicitStuffToGen@ decides what type variables +and LIE to generalise over. + +For a "restricted group" -- see the monomorphism restriction +for a definition -- we bind no dictionaries, and +remove from tyvars_to_gen any constrained type variables + +*Don't* simplify dicts at this point, because we aren't going +to generalise over these dicts. By the time we do simplify them +we may well know more. For example (this actually came up) + f :: Array Int Int + f x = array ... xs where xs = [1,2,3,4,5] +We don't want to generate lots of (fromInt Int 1), (fromInt Int 2) +stuff. If we simplify only at the f-binding (not the xs-binding) +we'll know that the literals are all Ints, and we can just produce +Int literals! + +Find all the type variables involved in overloading, the "constrained_tyvars" +These are the ones we *aren't* going to generalise. +We must be careful about doing this: + (a) If we fail to generalise a tyvar which is not actually + constrained, then it will never, ever get bound, and lands + up printed out in interface files! Notorious example: + instance Eq a => Eq (Foo a b) where .. + Here, b is not constrained, even though it looks as if it is. + Another, more common, example is when there's a Method inst in + the LIE, whose type might very well involve non-overloaded + type variables. + (b) On the other hand, we mustn't generalise tyvars which are constrained, + because we are going to pass on out the unmodified LIE, with those + tyvars in it. They won't be in scope if we've generalised them. + +So we are careful, and do a complete simplification just to find the +constrained tyvars. We don't use any of the results, except to +find which tyvars are constrained. + +\begin{code} +getImplicitStuffToGen is_restricted sig_ids binds_w_lies + | isUnRestrictedGroup tysig_vars bind + = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, dicts_to_gen) -> + returnNF_Tc (emptyTyVarSet, tyvars_to_gen, dicts_to_gen) + + | otherwise + = tcSimplify tyvars_to_gen lie `thenTc` \ (_, _, constrained_dicts) -> + let + -- ASSERT: dicts_sig is already zonked! + constrained_tyvars = foldBag unionTyVarSets tyVarsOfInst emptyTyVarSet constrained_dicts + reduced_tyvars_to_gen = tyvars_to_gen `minusTyVarSet` constrained_tyvars + in + returnTc (constrained_tyvars, reduced_tyvars_to_gen, emptyLIE) + + where + sig_ids = [sig_var | (TySigInfo sig_id _ _ _ _) <- ty_sigs] + + (tyvars_to_gen, lie) = foldBag (\(tv1,lie2) (tv2,lie2) -> (tv1 `unionTyVarSets` tv2, + lie1 `plusLIE` lie2)) + get + (emptyTyVarSet, emptyLIE) + binds_w_lies + get (bind, lie) + = case bindersOf bind of + [local_id] | local_id `in` sig_ids -> -- A simple binding with + -- a type signature + (emptyTyVarSet, emptyLIE) + + local_ids -> -- Complex binding or no type sig + (foldr (unionTyVarSets . tcIdType) emptyTyVarSet local_ids, + lie) +-} +\end{code} + + + \begin{code} tc_bind :: RenamedBind -> TcM s (TcBind s, LIE s) diff --git a/ghc/compiler/typecheck/TcClassDcl.lhs b/ghc/compiler/typecheck/TcClassDcl.lhs index ea8e4773c2..a48bc1e3c5 100644 --- a/ghc/compiler/typecheck/TcClassDcl.lhs +++ b/ghc/compiler/typecheck/TcClassDcl.lhs @@ -41,7 +41,7 @@ import CoreUtils ( escErrorMsg ) import Id ( mkSuperDictSelId, mkMethodSelId, mkDefaultMethodId, idType ) import IdInfo ( noIdInfo ) -import Outputable ( isLocallyDefined, getOrigName, getLocalName ) +import Name ( isLocallyDefined, getOrigName, getLocalName ) import PrelVals ( pAT_ERROR_ID ) import PprStyle import Pretty diff --git a/ghc/compiler/typecheck/TcDeriv.lhs b/ghc/compiler/typecheck/TcDeriv.lhs index 8d3aad6b83..ea4828a9ea 100644 --- a/ghc/compiler/typecheck/TcDeriv.lhs +++ b/ghc/compiler/typecheck/TcDeriv.lhs @@ -39,7 +39,6 @@ import CmdLineOpts ( opt_CompilingPrelude ) import ErrUtils ( pprBagOfErrors, addErrLoc, Error(..) ) import Id ( dataConSig, dataConArity ) import Maybes ( assocMaybe, maybeToBool, Maybe(..) ) ---import Name ( Name(..) ) import Outputable import PprType ( GenType, GenTyVar, GenClass, TyCon ) import PprStyle diff --git a/ghc/compiler/typecheck/TcEnv.lhs b/ghc/compiler/typecheck/TcEnv.lhs index 98800bdee6..290db74634 100644 --- a/ghc/compiler/typecheck/TcEnv.lhs +++ b/ghc/compiler/typecheck/TcEnv.lhs @@ -13,7 +13,7 @@ module TcEnv( tcExtendGlobalValEnv, tcExtendLocalValEnv, tcLookupLocalValue, tcLookupLocalValueOK, tcLookupLocalValueByKey, - tcLookupGlobalValue, tcLookupGlobalValueByKey, tcGlobalOcc, + tcLookupGlobalValue, tcLookupGlobalValueByKey, newMonoIds, newLocalIds, newLocalId, tcGetGlobalTyVars @@ -36,8 +36,7 @@ import Class ( Class(..), GenClass, getClassSig ) import TcMonad -import Name ( Name{-instance NamedThing-} ) -import Outputable ( getOccName, getSrcLoc ) +import Name ( getOccName, getSrcLoc, Name{-instance NamedThing-} ) import PprStyle import Pretty import RnHsSyn ( RnName(..) ) @@ -256,23 +255,6 @@ tcLookupGlobalValue name def = panic "tcLookupGlobalValue" #endif --- A useful function that takes an occurrence of a global thing --- and instantiates its type with fresh type variables -tcGlobalOcc :: RnName - -> NF_TcM s (Id, -- The Id - [TcType s], -- Instance types - TcType s) -- Rest of its type - -tcGlobalOcc name - = tcLookupGlobalValue name `thenNF_Tc` \ id -> - let - (tyvars, rho) = splitForAllTy (idType id) - in - tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> - tcInstType tenv rho `thenNF_Tc` \ rho' -> - returnNF_Tc (id, arg_tys, rho') - - tcLookupGlobalValueByKey :: Unique -> NF_TcM s Id tcLookupGlobalValueByKey uniq = tcGetEnv `thenNF_Tc` \ (TcEnv tve tce ce gve lve gtvs) -> diff --git a/ghc/compiler/typecheck/TcExpr.lhs b/ghc/compiler/typecheck/TcExpr.lhs index d2e9b4893d..809e08f9ff 100644 --- a/ghc/compiler/typecheck/TcExpr.lhs +++ b/ghc/compiler/typecheck/TcExpr.lhs @@ -30,21 +30,20 @@ import Inst ( Inst, InstOrigin(..), OverloadedLit(..), newMethod, newMethodWithGivenTy, newDicts ) import TcBinds ( tcBindsAndThen ) import TcEnv ( tcLookupLocalValue, tcLookupGlobalValue, tcLookupClassByKey, - tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars, - tcGlobalOcc + tcLookupGlobalValueByKey, newMonoIds, tcGetGlobalTyVars ) import TcMatches ( tcMatchesCase, tcMatch ) import TcMonoType ( tcPolyType ) import TcPat ( tcPat ) import TcSimplify ( tcSimplifyAndCheck, tcSimplifyRank2 ) import TcType ( TcType(..), TcMaybe(..), - tcInstType, tcInstTcType, tcInstTyVars, + tcInstId, tcInstType, tcInstTheta, tcInstTcType, tcInstTyVars, newTyVarTy, zonkTcTyVars, zonkTcType ) import TcKind ( TcKind ) import Class ( Class(..), getClassSig ) import FieldLabel ( fieldLabelName ) -import Id ( Id(..), GenId, idType, dataConFieldLabels ) +import Id ( Id(..), GenId, idType, dataConFieldLabels, dataConSig ) import Kind ( Kind, mkBoxedTypeKind, mkTypeKind, mkArrowKind ) import GenSpecEtc ( checkSigTyVars, checkSigTyVarsGivenGlobals ) import Name ( Name{-instance Eq-} ) @@ -56,7 +55,7 @@ import Type ( mkFunTy, mkAppTy, mkTyVarTy, mkTyVarTys, getTyVar_maybe, getFunTy_maybe, splitForAllTy, splitRhoTy, splitSigmaTy, splitFunTy, isTauTy, mkFunTys, tyVarsOfType, getForAllTy_maybe, - maybeAppDataTyCon + getAppDataTyCon, maybeAppDataTyCon ) import TyVar ( GenTyVar, TyVarSet(..), unionTyVarSets, mkTyVarSet ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists, unifyFunTy ) @@ -85,7 +84,7 @@ tcExpr :: RenamedHsExpr -> TcM s (TcExpr s, LIE s, TcType s) \begin{code} tcExpr (HsVar name) - = tcId name `thenTc` \ (expr', lie, res_ty) -> + = tcId name `thenNF_Tc` \ (expr', lie, res_ty) -> -- Check that the result type doesn't have any nested for-alls. -- For example, a "build" on its own is no good; it must be @@ -356,40 +355,55 @@ tcExpr (ExplicitTuple exprs) returnTc (ExplicitTuple exprs', lie, mkTupleTy (length tys) tys) tcExpr (RecordCon (HsVar con) rbinds) - = tcGlobalOcc con `thenNF_Tc` \ (con_id, arg_tys, con_rho) -> + = tcId con `thenNF_Tc` \ (con_expr, con_lie, con_tau) -> let - (con_theta, con_tau) = splitRhoTy con_rho (_, record_ty) = splitFunTy con_tau - con_expr = mkHsTyApp (HsVar (RealId con_id)) arg_tys in - -- TEMPORARY ASSERT - ASSERT( null con_theta ) - -- Con is syntactically constrained to be a data constructor ASSERT( maybeToBool (maybeAppDataTyCon record_ty ) ) tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> + -- Check that the record bindings match the constructor + tcLookupGlobalValue con `thenNF_Tc` \ con_id -> checkTc (checkRecordFields rbinds con_id) (badFieldsCon con rbinds) `thenTc_` - returnTc (RecordCon con_expr rbinds', panic "tcExpr:RecordCon:con_lie???" {-con_lie???-} `plusLIE` rbinds_lie, record_ty) + returnTc (RecordCon con_expr rbinds', con_lie `plusLIE` rbinds_lie, record_ty) + +-- One small complication in RecordUpd is that we have to generate some +-- dictionaries for the data type context, since we are going to +-- do some construction. +-- +-- What dictionaries do we need? For the moment we assume that all +-- data constructors have the same context, and grab it from the first +-- constructor. If they have varying contexts then we'd have to +-- union the ones that could participate in the update. tcExpr (RecordUpd record_expr rbinds) - = tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) -> + = ASSERT( not (null rbinds) ) + tcAddErrCtxt recordUpdCtxt $ + + tcExpr record_expr `thenTc` \ (record_expr', record_lie, record_ty) -> tcRecordBinds record_ty rbinds `thenTc` \ (rbinds', rbinds_lie) -> -- Check that the field names are plausible zonkTcType record_ty `thenNF_Tc` \ record_ty' -> let - maybe_tycon_stuff = maybeAppDataTyCon record_ty' - Just (tycon, args_tys, data_cons) = maybe_tycon_stuff + (tycon, inst_tys, data_cons) = getAppDataTyCon record_ty' + -- The record binds are non-empty (syntax); so at least one field + -- label will have been unified with record_ty by tcRecordBinds; + -- field labels must be of data type; hencd the getAppDataTyCon must succeed. + (tyvars, theta, _, _) = dataConSig (head data_cons) in - checkTc (maybeToBool maybe_tycon_stuff) - (panic "TcExpr:Records:mystery error message") `thenTc_` + tcInstTheta (tyvars `zipEqual` inst_tys) theta `thenNF_Tc` \ theta' -> + newDicts RecordUpdOrigin theta' `thenNF_Tc` \ (con_lie, dicts) -> checkTc (any (checkRecordFields rbinds) data_cons) (badFieldsUpd rbinds) `thenTc_` - returnTc (RecordUpd record_expr' rbinds', record_lie `plusLIE` rbinds_lie, record_ty) + + returnTc (RecordUpdOut record_expr' dicts rbinds', + con_lie `plusLIE` record_lie `plusLIE` rbinds_lie, + record_ty) tcExpr (ArithSeqIn seq@(From expr)) = tcExpr expr `thenTc` \ (expr', lie1, ty) -> @@ -505,7 +519,7 @@ tcApp fun args -- In the HsVar case we go straight to tcId to avoid hitting the -- rank-2 check, which we check later here anyway (case fun of - HsVar name -> tcId name + HsVar name -> tcId name `thenNF_Tc` \ stuff -> returnTc stuff other -> tcExpr fun ) `thenTc` \ (fun', lie_fun, fun_ty) -> @@ -623,7 +637,7 @@ tcArg expected_arg_ty arg %************************************************************************ \begin{code} -tcId :: RnName -> TcM s (TcExpr s, LIE s, TcType s) +tcId :: RnName -> NF_TcM s (TcExpr s, LIE s, TcType s) tcId name = -- Look up the Id and instantiate its type @@ -637,20 +651,25 @@ tcId name tcInstTcType tenv rho `thenNF_Tc` \ rho' -> returnNF_Tc (TcId tc_id, arg_tys', rho') - Nothing -> tcGlobalOcc name `thenNF_Tc` \ (id, arg_tys, rho) -> - returnNF_Tc (RealId id, arg_tys, rho) + Nothing -> tcLookupGlobalValue name `thenNF_Tc` \ id -> + let + (tyvars, rho) = splitForAllTy (idType id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> + tcInstType tenv rho `thenNF_Tc` \ rho' -> + returnNF_Tc (RealId id, arg_tys, rho') ) `thenNF_Tc` \ (tc_id_occ, arg_tys, rho) -> -- Is it overloaded? case splitRhoTy rho of ([], tau) -> -- Not overloaded, so just make a type application - returnTc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau) + returnNF_Tc (mkHsTyApp (HsVar tc_id_occ) arg_tys, emptyLIE, tau) (theta, tau) -> -- Overloaded, so make a Method inst newMethodWithGivenTy (OccurrenceOf tc_id_occ) tc_id_occ arg_tys rho `thenNF_Tc` \ (lie, meth_id) -> - returnTc (HsVar meth_id, lie, tau) + returnNF_Tc (HsVar meth_id, lie, tau) \end{code} @@ -808,7 +827,8 @@ tcRecordBinds expected_record_ty rbinds returnTc (rbinds', plusLIEs lies) where do_bind (field_label, rhs, pun_flag) - = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) -> + = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id -> + tcInstId sel_id `thenNF_Tc` \ (_, _, tau) -> -- Record selectors all have type -- forall a1..an. T a1 .. an -> tau @@ -918,11 +938,13 @@ rank2ArgCtxt arg expected_arg_ty sty ppr sty expected_arg_ty]) badFieldsUpd rbinds sty - = ppHang (ppStr "In a record update construct, no constructor has all these fields:") + = ppHang (ppStr "No constructor has all these fields:") 4 (interpp'SP sty fields) where fields = [field | (field, _, _) <- rbinds] +recordUpdCtxt sty = ppStr "In a record update construct" + badFieldsCon con rbinds sty = ppHang (ppBesides [ppStr "Inconsistent constructor:", ppr sty con]) 4 (ppBesides [ppStr "and fields:", interpp'SP sty fields]) diff --git a/ghc/compiler/typecheck/TcHsSyn.lhs b/ghc/compiler/typecheck/TcHsSyn.lhs index 97b1f4e284..24054217dc 100644 --- a/ghc/compiler/typecheck/TcHsSyn.lhs +++ b/ghc/compiler/typecheck/TcHsSyn.lhs @@ -21,6 +21,7 @@ module TcHsSyn ( TypecheckedQual(..), TypecheckedStmt(..), TypecheckedMatch(..), TypecheckedHsModule(..), TypecheckedGRHSsAndBinds(..), TypecheckedGRHS(..), + TypecheckedRecordBinds(..), mkHsTyApp, mkHsDictApp, mkHsTyLam, mkHsDictLam, @@ -95,6 +96,7 @@ type TypecheckedStmt = Stmt TyVar UVar Id TypecheckedPat type TypecheckedMatch = Match TyVar UVar Id TypecheckedPat type TypecheckedGRHSsAndBinds = GRHSsAndBinds TyVar UVar Id TypecheckedPat type TypecheckedGRHS = GRHS TyVar UVar Id TypecheckedPat +type TypecheckedRecordBinds = HsRecordBinds TyVar UVar Id TypecheckedPat type TypecheckedHsModule = HsModule TyVar UVar Id TypecheckedPat \end{code} diff --git a/ghc/compiler/typecheck/TcInstDcls.lhs b/ghc/compiler/typecheck/TcInstDcls.lhs index 0d43182c0f..62379841eb 100644 --- a/ghc/compiler/typecheck/TcInstDcls.lhs +++ b/ghc/compiler/typecheck/TcInstDcls.lhs @@ -63,7 +63,7 @@ import CoreUtils ( escErrorMsg ) import Id ( GenId, idType, isDefaultMethodId_maybe ) import ListSetOps ( minusList ) import Maybes ( maybeToBool, expectJust ) -import Outputable ( getLocalName, getOrigName ) +import Name ( getLocalName, getOrigName ) import PrelInfo ( pAT_ERROR_ID ) import PprType ( GenType, GenTyVar, GenClass, GenClassOp, TyCon, pprParendGenType ) @@ -663,8 +663,7 @@ processInstBinds1 inst_tyvars avail_insts method_ids mbind let tag = panic "processInstBinds1:getTagFromClassOpName"{-getTagFromClassOpName op-} method_id = method_ids !! (tag-1) - TcId method_bndr = method_id - method_ty = idType method_bndr + method_ty = tcIdType method_id (method_tyvars, method_theta, method_tau) = splitSigmaTy method_ty in newDicts origin method_theta `thenNF_Tc` \ (method_dicts,method_dict_ids) -> diff --git a/ghc/compiler/typecheck/TcInstUtil.lhs b/ghc/compiler/typecheck/TcInstUtil.lhs index a0e452c5db..9d5a403d9d 100644 --- a/ghc/compiler/typecheck/TcInstUtil.lhs +++ b/ghc/compiler/typecheck/TcInstUtil.lhs @@ -30,7 +30,7 @@ import CoreSyn ( GenCoreExpr(..), mkValLam, mkTyApp ) import Id ( GenId, mkDictFunId, mkConstMethodId, mkSysLocal ) import MatchEnv ( nullMEnv, insertMEnv ) import Maybes ( MaybeErr(..), mkLookupFunDef ) -import Outputable ( getSrcLoc ) +import Name ( getSrcLoc ) import PprType ( GenClass, GenType, GenTyVar ) import Pretty import SpecEnv ( SpecEnv(..), nullSpecEnv, addOneToSpecEnv ) diff --git a/ghc/compiler/typecheck/TcModule.lhs b/ghc/compiler/typecheck/TcModule.lhs index 39122d3524..1645d0e358 100644 --- a/ghc/compiler/typecheck/TcModule.lhs +++ b/ghc/compiler/typecheck/TcModule.lhs @@ -39,7 +39,7 @@ import Bag ( listToBag ) import Class ( GenClass ) import Id ( GenId, isDataCon, isMethodSelId, idType ) import Maybes ( catMaybes ) -import Outputable ( isExported, isLocallyDefined ) +import Name ( isExported, isLocallyDefined ) import PrelInfo ( unitTy, mkPrimIoTy ) import Pretty import RnUtils ( GlobalNameMappers(..), GlobalNameMapper(..) ) diff --git a/ghc/compiler/typecheck/TcMonad.lhs b/ghc/compiler/typecheck/TcMonad.lhs index 5614273ccf..b23cf3782a 100644 --- a/ghc/compiler/typecheck/TcMonad.lhs +++ b/ghc/compiler/typecheck/TcMonad.lhs @@ -50,7 +50,7 @@ import SST import Bag ( Bag, emptyBag, isEmptyBag, foldBag, unitBag, unionBags, snocBag ) import FiniteMap ( FiniteMap, emptyFM ) -import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) +--import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) import ErrUtils ( Error(..) ) import Maybes ( MaybeErr(..) ) --import Name ( Name ) diff --git a/ghc/compiler/typecheck/TcPat.lhs b/ghc/compiler/typecheck/TcPat.lhs index 23d73af096..16b0ca28bc 100644 --- a/ghc/compiler/typecheck/TcPat.lhs +++ b/ghc/compiler/typecheck/TcPat.lhs @@ -22,8 +22,8 @@ import Inst ( Inst, OverloadedLit(..), InstOrigin(..), newMethod, newOverloadedLit ) import TcEnv ( tcLookupGlobalValue, tcLookupGlobalValueByKey, - tcLookupLocalValueOK, tcGlobalOcc ) -import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys ) + tcLookupLocalValueOK ) +import TcType ( TcType(..), TcMaybe, tcInstType, newTyVarTy, newTyVarTys, tcInstId ) import Unify ( unifyTauTy, unifyTauTyList, unifyTauTyLists ) import Bag ( Bag ) @@ -181,9 +181,9 @@ tcPat pat_in@(ConOpPatIn pat1 op pat2) -- & in binary-op form... \begin{code} tcPat pat_in@(RecPatIn name rpats) - = tcGlobalOcc name `thenNF_Tc` \ (con_id, _, con_rho) -> + = tcLookupGlobalValue name `thenNF_Tc` \ con_id -> + tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> let - (_, con_tau) = splitRhoTy con_rho -- Ignore the con_theta; overloaded constructors only -- behave differently when called, not when used for -- matching. @@ -200,7 +200,8 @@ tcPat pat_in@(RecPatIn name rpats) where do_bind expected_record_ty (field_label, rhs_pat, pun_flag) - = tcGlobalOcc field_label `thenNF_Tc` \ (sel_id, _, tau) -> + = tcLookupGlobalValue field_label `thenNF_Tc` \ sel_id -> + tcInstId sel_id `thenNF_Tc` \ (_, _, tau) -> -- Record selectors all have type -- forall a1..an. T a1 .. an -> tau @@ -316,13 +317,12 @@ unifies the actual args against the expected ones. matchConArgTys :: RnName -> [TcType s] -> TcM s (Id, TcType s) matchConArgTys con arg_tys - = tcGlobalOcc con `thenNF_Tc` \ (con_id, _, con_rho) -> - let - (con_theta, con_tau) = splitRhoTy con_rho + = tcLookupGlobalValue con `thenNF_Tc` \ con_id -> + tcInstId con_id `thenNF_Tc` \ (_, _, con_tau) -> -- Ignore the con_theta; overloaded constructors only -- behave differently when called, not when used for -- matching. - + let (con_args, con_result) = splitFunTy con_tau con_arity = length con_args no_of_args = length arg_tys diff --git a/ghc/compiler/typecheck/TcSimplify.lhs b/ghc/compiler/typecheck/TcSimplify.lhs index 7962527daa..ff30d6f70d 100644 --- a/ghc/compiler/typecheck/TcSimplify.lhs +++ b/ghc/compiler/typecheck/TcSimplify.lhs @@ -34,7 +34,7 @@ import Class ( isNumericClass, isStandardClass, isCcallishClass, isSuperClassOf, getSuperDictSelId ) import Id ( GenId ) import Maybes ( expectJust, firstJust, catMaybes, seqMaybe, maybeToBool, Maybe(..) ) -import Outputable ( Outputable(..) ) +import Outputable ( Outputable(..){-instance * []-} ) import PprType ( GenType, GenTyVar ) import Pretty import SrcLoc ( mkUnknownSrcLoc ) diff --git a/ghc/compiler/typecheck/TcTyClsDecls.lhs b/ghc/compiler/typecheck/TcTyClsDecls.lhs index 56fa41cb82..06b8d04243 100644 --- a/ghc/compiler/typecheck/TcTyClsDecls.lhs +++ b/ghc/compiler/typecheck/TcTyClsDecls.lhs @@ -27,19 +27,19 @@ import TcEnv ( tcExtendTyConEnv, tcExtendClassEnv, tcExtendGlobalValEnv, tcTyVarScope, tcGetEnv ) import TcKind ( TcKind, newKindVars ) -import TcTyDecls ( tcTyDecl, tcRecordSelectors ) +import TcTyDecls ( tcTyDecl, mkDataBinds ) import Bag import Class ( Class(..), getClassSelIds ) import Digraph ( findSCCs, SCC(..) ) -import Outputable ( getSrcLoc ) +import Name ( getSrcLoc ) import PprStyle import Pretty import UniqSet ( UniqSet(..), emptyUniqSet, unitUniqSet, unionUniqSets, unionManyUniqSets, uniqSetToList ) import SrcLoc ( SrcLoc ) -import TyCon ( TyCon, tyConDataCons ) +import TyCon ( TyCon, tyConDataCons, isDataTyCon ) import Unique ( Unique ) import Util ( panic, pprTrace ) @@ -121,7 +121,7 @@ tcGroup inst_mapper decls -- Create any necessary record selector Ids and their bindings - mapAndUnzipTc tcRecordSelectors tycons `thenTc` \ (sel_ids_s, binds) -> + mapAndUnzipTc mkDataBinds (filter isDataTyCon tycons) `thenTc` \ (data_ids_s, binds) -> -- Extend the global value environment with -- a) constructors @@ -129,8 +129,7 @@ tcGroup inst_mapper decls -- c) class op selectors tcSetEnv final_env $ - tcExtendGlobalValEnv (concat (map tyConDataCons tycons)) $ - tcExtendGlobalValEnv (concat sel_ids_s) $ + tcExtendGlobalValEnv (concat data_ids_s) $ tcExtendGlobalValEnv (concat (map getClassSelIds classes)) $ tcGetEnv `thenNF_Tc` \ really_final_env -> diff --git a/ghc/compiler/typecheck/TcTyDecls.lhs b/ghc/compiler/typecheck/TcTyDecls.lhs index 8c03384c5a..e8595fd7e9 100644 --- a/ghc/compiler/typecheck/TcTyDecls.lhs +++ b/ghc/compiler/typecheck/TcTyDecls.lhs @@ -9,43 +9,55 @@ module TcTyDecls ( tcTyDecl, tcConDecl, - tcRecordSelectors + mkDataBinds ) where import Ubiq{-uitous-} import HsSyn ( TyDecl(..), ConDecl(..), BangType(..), HsExpr(..), Match(..), GRHSsAndBinds(..), GRHS(..), OutPat(..), - HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, PolyType, + HsBinds(..), HsLit, Stmt, Qual, ArithSeqInfo, + PolyType, Fake, InPat, Bind(..), MonoBinds(..), Sig, MonoType ) import RnHsSyn ( RenamedTyDecl(..), RenamedConDecl(..), RnName{-instance Outputable-} ) -import TcHsSyn ( TcHsBinds(..), TcIdOcc(..), mkHsTyLam ) +import TcHsSyn ( mkHsTyLam, tcIdType, zonkId, TcHsBinds(..), TcIdOcc(..) ) +import Inst ( newDicts, InstOrigin(..), Inst ) import TcMonoType ( tcMonoTypeKind, tcMonoType, tcContext ) -import TcType ( tcInstTyVars, tcInstType ) +import TcType ( tcInstTyVars, tcInstType, tcInstId ) import TcEnv ( tcLookupTyCon, tcLookupTyVar, tcLookupClass, - newLocalId + tcLookupClassByKey, + newLocalId, newLocalIds ) import TcMonad import TcKind ( TcKind, unifyKind, mkTcArrowKind, mkTcTypeKind ) +import Class ( GenClass{-instance Eq-} ) import Id ( mkDataCon, dataConSig, mkRecordSelId, - dataConFieldLabels, StrictnessMark(..) + dataConFieldLabels, dataConStrictMarks, + StrictnessMark(..), + GenId{-instance NamedThing-} ) import FieldLabel import Kind ( Kind, mkArrowKind, mkBoxedTypeKind ) import SpecEnv ( SpecEnv(..), nullSpecEnv ) -import Name ( Name{-instance Ord3-} ) +import Name ( nameSrcLoc, isLocallyDefinedName, getSrcLoc, + Name{-instance Ord3-} + ) import Pretty -import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, tyConDataCons ) -import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, applyTyCon, - mkForAllTys, mkFunTy ) -import TyVar ( getTyVarKind, elementOfTyVarSet ) +import TyCon ( TyCon, NewOrData(..), mkSynTyCon, mkDataTyCon, isDataTyCon, + tyConDataCons ) +import Type ( getTypeKind, getTyVar, tyVarsOfTypes, eqTy, + applyTyCon, mkTyVarTys, mkForAllTys, mkFunTy, + splitFunTy, mkTyVarTy, getTyVar_maybe + ) +import TyVar ( getTyVarKind, elementOfTyVarSet, GenTyVar{-instance Eq-} ) +import Unique ( Unique {- instance Eq -}, dataClassKey ) import UniqSet ( emptyUniqSet, mkUniqSet, uniqSetToList, unionManyUniqSets, UniqSet(..) ) -import Util ( panic, equivClasses ) +import Util ( equivClasses, zipEqual, panic, assertPanic ) \end{code} \begin{code} @@ -145,14 +157,21 @@ tc_deriv name returnNF_Tc clas \end{code} -Generating selector bindings for record delarations -~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Generating constructor/selector bindings for data declarations +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ \begin{code} -tcRecordSelectors :: TyCon -> TcM s ([Id], TcHsBinds s) -tcRecordSelectors tycon - = mapAndUnzipTc (tcRecordSelector tycon) groups `thenTc` \ (ids, binds) -> - returnTc (ids, SingleBind (NonRecBind (foldr AndMonoBinds EmptyMonoBinds binds))) +mkDataBinds :: TyCon -> TcM s ([Id], TcHsBinds s) +mkDataBinds tycon + = ASSERT( isDataTyCon tycon ) + mapAndUnzipTc mkConstructor data_cons `thenTc` \ (con_ids, con_binds) -> + mapAndUnzipTc (mkRecordSelector tycon) groups `thenTc` \ (sel_ids, sel_binds) -> + returnTc (con_ids ++ sel_ids, + SingleBind $ NonRecBind $ + foldr AndMonoBinds + (foldr AndMonoBinds EmptyMonoBinds con_binds) + con_binds + ) where data_cons = tyConDataCons tycon fields = [ (con, field) | con <- data_cons, @@ -165,6 +184,86 @@ tcRecordSelectors tycon = fieldLabelName field1 `cmp` fieldLabelName field2 \end{code} +We're going to build a constructor that looks like: + + data (Data a, C b) => T a b = T1 !a !Int b + + T1 = /\ a b -> + \d1::Data a, d2::C b -> + \p q r -> case p of { p -> + case q of { q -> + HsCon [a,b,c] [p,q,r]}} + +Notice that + +* d2 is thrown away --- a context in a data decl is used to make sure + one *could* construct dictionaries at the site the constructor + is used, but the dictionary isn't actually used. + +* We have to check that we can construct Data dictionaries for + the types a and Int. Once we've done that we can throw d1 away too. + +* We use (case p of ...) to evaluate p, rather than "seq" because + all that matters is that the arguments are evaluated. "seq" is + very careful to preserve evaluation order, which we don't need + to be here. + +\begin{code} +mkConstructor con_id + | not (isLocallyDefinedName (getName con_id)) + = returnTc (con_id, EmptyMonoBinds) + + | otherwise -- It is locally defined + = tcInstId con_id `thenNF_Tc` \ (tyvars, theta, tau) -> + newDicts DataDeclOrigin theta `thenNF_Tc` \ (_, dicts) -> + let + (arg_tys, result_ty) = splitFunTy tau + n_args = length arg_tys + in + newLocalIds (take n_args (repeat SLIT("con"))) arg_tys `thenNF_Tc` {- \ pre_zonk_args -> + mapNF_Tc zonkId pre_zonk_args `thenNF_Tc` -} \ args -> + + -- Check that all the types of all the strict + -- arguments are in Data. This is trivially true of everything except + -- type variables, for which we must check the context. + let + strict_marks = dataConStrictMarks con_id + strict_args = [arg | (arg, MarkedStrict) <- args `zipEqual` strict_marks] + + data_tyvars = -- The tyvars in the constructor's context that are arguments + -- to the Data class + [getTyVar "mkConstructor" ty + | (clas,ty) <- theta, + uniqueOf clas == dataClassKey] + + check_data arg = case getTyVar_maybe (tcIdType arg) of + Nothing -> returnTc () -- Not a tyvar, so OK + Just tyvar -> checkTc (tyvar `elem` data_tyvars) (missingDataErr tyvar) + in + mapTc check_data strict_args `thenTc_` + + -- Build the data constructor + let + con_rhs = mkHsTyLam tyvars $ + DictLam dicts $ + mk_pat_match args $ + mk_case strict_args $ + HsCon con_id arg_tys (map HsVar args) + + mk_pat_match [] body = body + mk_pat_match (arg:args) body = HsLam (PatMatch (VarPat arg) (SimpleMatch (mk_pat_match args body))) + + mk_case [] body = body + mk_case (arg:args) body = HsCase (HsVar arg) + [PatMatch (VarPat arg) (SimpleMatch (mk_case args body))] + src_loc + + src_loc = nameSrcLoc (getName con_id) + in + + returnTc (con_id, VarMonoBind (RealId con_id) con_rhs) +\end{code} + We're going to build a record selector that looks like this: data T a b c = T1 { op :: a, ...} @@ -179,15 +278,14 @@ Note that the selector Id itself is used as the field label; it has to be an Id, you see! \begin{code} -tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields) - = panic "tcRecordSelector: don't typecheck" -{- +mkRecordSelector tycon fields@((first_con, first_field_label) : other_fields) = let field_ty = fieldLabelType first_field_label field_name = fieldLabelName first_field_label - other_tys = [fieldLabelType fl | (_, fl) <- fields] + other_tys = [fieldLabelType fl | (_, fl) <- other_fields] (tyvars, _, _, _) = dataConSig first_con - -- tyvars of first_con may be free in first_ty + data_ty = applyTyCon tycon (mkTyVarTys tyvars) + -- tyvars of first_con may be free in field_ty in -- Check that all the fields in the group have the same type @@ -200,41 +298,38 @@ tcRecordSelector tycon fields@((first_con, first_field_label) : other_fields) tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', tyvar_tys, tenv) -> tcInstType tenv field_ty `thenNF_Tc` \ field_ty' -> let - data_ty' = applyTyCon tycon tyvar_tys + data_ty' = applyTyCon tycon tyvar_tys in newLocalId SLIT("x") field_ty' `thenNF_Tc` \ field_id -> newLocalId SLIT("r") data_ty' `thenNF_Tc` \ record_id -> -- Now build the selector let - tycon_src_loc = getSrcLoc tycon - - selector_ty = mkForAllTys tyvars' $ - mkFunTy data_ty' $ - field_ty' + selector_ty :: Type + selector_ty = mkForAllTys tyvars $ + mkFunTy data_ty $ + field_ty + selector_id :: Id selector_id = mkRecordSelId first_field_label selector_ty -- HsSyn is dreadfully verbose for defining the selector! selector_rhs = mkHsTyLam tyvars' $ HsLam $ PatMatch (VarPat record_id) $ - GRHSMatch $ - GRHSsAndBindsOut [OtherwiseGRHS selector_body tycon_src_loc] - EmptyBinds field_ty' + SimpleMatch $ + selector_body - selector_body = HsCase (HsVar record_id) (map mk_match fields) tycon_src_loc + selector_body = HsCase (HsVar record_id) (map mk_match fields) (getSrcLoc tycon) mk_match (con_id, field_label) - = PatMatch (RecPat con_id data_ty' [(selector_id, VarPat field_id, False)]) $ - GRHSMatch $ - GRHSsAndBindsOut [OtherwiseGRHS (HsVar field_id) - (getSrcLoc (fieldLabelName field_label))] - EmptyBinds - field_ty' + = PatMatch (RecPat con_id data_ty' [(RealId selector_id, VarPat field_id, False)]) $ + SimpleMatch $ + HsVar field_id in - returnTc (selector_id, VarMonoBind selector_id selector_rhs) --} + returnTc (selector_id, if isLocallyDefinedName (getName tycon) + then VarMonoBind (RealId selector_id) selector_rhs + else EmptyMonoBinds) \end{code} Constructors @@ -340,4 +435,7 @@ tyNewCtxt tycon_name sty fieldTypeMisMatch field_name sty = ppSep [ppStr "Declared types differ for field", ppr sty field_name] + +missingDataErr tyvar sty + = ppStr "Missing `data' (???)" -- ToDo: improve \end{code} diff --git a/ghc/compiler/typecheck/TcType.lhs b/ghc/compiler/typecheck/TcType.lhs index f3f04524d8..8426310f01 100644 --- a/ghc/compiler/typecheck/TcType.lhs +++ b/ghc/compiler/typecheck/TcType.lhs @@ -20,7 +20,7 @@ module TcType ( tcInstTyVars, -- TyVar -> NF_TcM s (TcTyVar s) tcInstSigTyVars, - tcInstType, tcInstTcType, tcInstTheta, + tcInstType, tcInstTcType, tcInstTheta, tcInstId, zonkTcTyVars, -- TcTyVarSet s -> NF_TcM s (TcTyVarSet s) zonkTcType, -- TcType s -> NF_TcM s (TcType s) @@ -32,17 +32,21 @@ module TcType ( -- friends: -import Type ( Type(..), ThetaType(..), GenType(..), tyVarsOfTypes, getTyVar_maybe ) +import Type ( Type(..), ThetaType(..), GenType(..), + tyVarsOfTypes, getTyVar_maybe, + splitForAllTy, splitRhoTy + ) import TyVar ( TyVar(..), GenTyVar(..), TyVarSet(..), GenTyVarSet(..), tyVarSetToList ) -- others: -import Kind ( Kind ) -import Usage ( Usage(..), GenUsage, UVar(..), duffUsage ) import Class ( GenClass ) +import Id ( idType ) +import Kind ( Kind ) import TcKind ( TcKind ) import TcMonad +import Usage ( Usage(..), GenUsage, UVar(..), duffUsage ) import Ubiq import Unique ( Unique ) @@ -193,7 +197,24 @@ tcInstTheta tenv theta go (clas,ty) = tcInstType tenv ty `thenNF_Tc` \ tc_ty -> returnNF_Tc (clas, tc_ty) ---???tcSpecTy :: Type -> NF_TcM s ( +-- A useful function that takes an occurrence of a global thing +-- and instantiates its type with fresh type variables +tcInstId :: Id + -> NF_TcM s ([TcTyVar s], -- It's instantiated type + TcThetaType s, -- + TcType s) -- + +tcInstId id + = let + (tyvars, rho) = splitForAllTy (idType id) + in + tcInstTyVars tyvars `thenNF_Tc` \ (tyvars', arg_tys, tenv) -> + tcInstType tenv rho `thenNF_Tc` \ rho' -> + let + (theta', tau') = splitRhoTy rho' + in + returnNF_Tc (tyvars', theta', tau') + tcInstTcType :: [(TcTyVar s,TcType s)] -> TcType s -> NF_TcM s (TcType s) tcInstTcType tenv ty_to_inst diff --git a/ghc/compiler/types/Class.lhs b/ghc/compiler/types/Class.lhs index 12b4231089..7174e8eec0 100644 --- a/ghc/compiler/types/Class.lhs +++ b/ghc/compiler/types/Class.lhs @@ -37,9 +37,9 @@ import TyVar ( TyVar(..), GenTyVar ) import Usage ( GenUsage, Usage(..), UVar(..) ) import Maybes ( assocMaybe, Maybe ) -import Name ( Name ) +--import Name ( Name ) import Unique -- Keys for built-in classes -import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) +--import Outputable ( Outputable(..), NamedThing(..), ExportFlag ) import Pretty ( Pretty(..), PrettyRep ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc ) diff --git a/ghc/compiler/types/Kind.lhs b/ghc/compiler/types/Kind.lhs index 945c66b3b7..9fe3df3dfc 100644 --- a/ghc/compiler/types/Kind.lhs +++ b/ghc/compiler/types/Kind.lhs @@ -19,7 +19,7 @@ module Kind ( import Ubiq{-uitous-} import Util ( panic ) -import Outputable ( Outputable(..) ) +--import Outputable ( Outputable(..) ) import Pretty \end{code} diff --git a/ghc/compiler/types/PprType.lhs b/ghc/compiler/types/PprType.lhs index 506c4d2284..5ba046388a 100644 --- a/ghc/compiler/types/PprType.lhs +++ b/ghc/compiler/types/PprType.lhs @@ -38,10 +38,10 @@ import Kind ( Kind(..) ) import CStrings ( identToC ) import CmdLineOpts ( opt_OmitInterfacePragmas ) import Maybes ( maybeToBool ) -import Name ( Name ) -import Outputable ( isAvarop, isPreludeDefined, getOrigName, - ifPprShowAll, interpp'SP +import Name ( isAvarop, isPreludeDefined, getOrigName, + Name{-instance Outputable-} ) +import Outputable ( ifPprShowAll, interpp'SP ) import PprStyle ( PprStyle(..), codeStyle, showUserishTypes ) import Pretty import TysWiredIn ( listTyCon ) diff --git a/ghc/compiler/types/TyCon.lhs b/ghc/compiler/types/TyCon.lhs index 4e03f96974..87dfc622d6 100644 --- a/ghc/compiler/types/TyCon.lhs +++ b/ghc/compiler/types/TyCon.lhs @@ -53,7 +53,6 @@ import PrelMods ( pRELUDE_BUILTIN ) import Maybes import Name ( Name, RdrName(..), appendRdr, nameUnique ) import Unique ( Unique, funTyConKey, mkTupleTyConUnique ) -import Outputable import Pretty ( Pretty(..), PrettyRep ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc, mkBuiltinSrcLoc ) diff --git a/ghc/compiler/types/TyLoop.lhi b/ghc/compiler/types/TyLoop.lhi index 36506e621a..d36e74e1cb 100644 --- a/ghc/compiler/types/TyLoop.lhi +++ b/ghc/compiler/types/TyLoop.lhi @@ -9,7 +9,7 @@ import Unique ( Unique ) import FieldLabel ( FieldLabel ) import Id ( Id, GenId, StrictnessMark, mkTupleCon, mkDataCon, - dataConSig, getInstantiatedDataConSig ) + dataConSig, dataConArgTys ) import PprType ( specMaybeTysSuffix ) import Name ( Name ) import TyCon ( TyCon ) @@ -36,7 +36,7 @@ specMaybeTysSuffix :: [Maybe Type] -> _PackedString instance Eq (GenClass a b) -- Needed in Type -getInstantiatedDataConSig :: Id -> [Type] -> ([Type],[Type],Type) +dataConArgTys :: Id -> [Type] -> [Type] -- Needed in TysWiredIn data StrictnessMark = MarkedStrict | NotMarkedStrict diff --git a/ghc/compiler/types/TyVar.lhs b/ghc/compiler/types/TyVar.lhs index 0a9675e25f..1b700f6269 100644 --- a/ghc/compiler/types/TyVar.lhs +++ b/ghc/compiler/types/TyVar.lhs @@ -38,7 +38,7 @@ import Maybes ( Maybe(..) ) import Name ( mkLocalName, Name, RdrName(..) ) import Pretty ( Pretty(..), PrettyRep, ppBeside, ppPStr ) import PprStyle ( PprStyle ) -import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) ) +--import Outputable ( Outputable(..), NamedThing(..), ExportFlag(..) ) import SrcLoc ( mkUnknownSrcLoc, SrcLoc ) import Unique ( showUnique, mkAlphaTyVarUnique, Unique ) import Util ( panic, Ord3(..) ) diff --git a/ghc/compiler/types/Type.lhs b/ghc/compiler/types/Type.lhs index d84a1da679..0d25048aa1 100644 --- a/ghc/compiler/types/Type.lhs +++ b/ghc/compiler/types/Type.lhs @@ -377,8 +377,8 @@ maybeBoxedPrimType :: Type -> Maybe (Id, Type) maybeBoxedPrimType ty = case (maybeAppDataTyCon ty) of -- Data type, Just (tycon, tys_applied, [data_con]) -- with exactly one constructor - -> case (getInstantiatedDataConSig data_con tys_applied) of - (_, [data_con_arg_ty], _) -- Applied to exactly one type, + -> case (dataConArgTys data_con tys_applied) of + [data_con_arg_ty] -- Applied to exactly one type, | isPrimType data_con_arg_ty -- which is primitive -> Just (data_con, data_con_arg_ty) other_cases -> Nothing diff --git a/ghc/compiler/utils/Outputable.lhs b/ghc/compiler/utils/Outputable.lhs index 3d123847af..aeb06ebbae 100644 --- a/ghc/compiler/utils/Outputable.lhs +++ b/ghc/compiler/utils/Outputable.lhs @@ -10,33 +10,17 @@ Defines classes for pretty-printing and forcing, both forms of #include "HsVersions.h" module Outputable ( - -- NAMED-THING-ERY - NamedThing(..), -- class - ExportFlag(..), - - getItsUnique, getOrigName, getOccName, getExportFlag, - getSrcLoc, isLocallyDefined, isPreludeDefined, isExported, - getLocalName, getOrigNameRdr, ltLexical, - - -- PRINTERY AND FORCERY Outputable(..), -- class interppSP, interpp'SP, ifnotPprForUser, ifPprDebug, ifPprShowAll, ifnotPprShowAll, - ifPprInterface, - - isOpLexeme, pprOp, pprNonOp, - isConop, isAconop, isAvarid, isAvarop + ifPprInterface ) where import Ubiq{-uitous-} -import Name ( nameUnique, nameOrigName, nameOccName, - nameExportFlag, nameSrcLoc, - isLocallyDefinedName, isPreludeDefinedName - ) import PprStyle ( PprStyle(..) ) import Pretty import Util ( cmpPString ) @@ -44,99 +28,6 @@ import Util ( cmpPString ) %************************************************************************ %* * -\subsection[NamedThing-class]{The @NamedThing@ class} -%* * -%************************************************************************ - -\begin{code} -class NamedThing a where - getName :: a -> Name - -getItsUnique :: NamedThing a => a -> Unique -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 - -getItsUnique = nameUnique . getName -getOrigName = nameOrigName . getName -getOccName = nameOccName . getName -getExportFlag = nameExportFlag . getName -getSrcLoc = nameSrcLoc . getName -isLocallyDefined = isLocallyDefinedName . getName -isPreludeDefined = isPreludeDefinedName . getName - -isExported a - = case (getExportFlag a) of - NotExported -> False - _ -> True - -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 - -#ifdef USE_ATTACK_PRAGMAS -{-# SPECIALIZE isExported :: Class -> Bool #-} -{-# SPECIALIZE isExported :: Id -> Bool #-} -{-# SPECIALIZE isExported :: TyCon -> Bool #-} -#endif -\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} - -%************************************************************************ -%* * -\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 -\end{code} - -%************************************************************************ -%* * \subsection[Outputable-class]{The @Outputable@ class} %* * %************************************************************************ @@ -180,81 +71,6 @@ ifnotPprForUser sty p = case sty of PprForUser -> ppNil ; _ -> p ifnotPprShowAll sty p = case sty of PprShowAll -> ppNil ; _ -> p \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} - \begin{code} instance Outputable Bool where ppr sty True = ppPStr SLIT("True") diff --git a/ghc/compiler/utils/Ubiq.lhi b/ghc/compiler/utils/Ubiq.lhi index 2b02a6aef4..922c0c67bc 100644 --- a/ghc/compiler/utils/Ubiq.lhi +++ b/ghc/compiler/utils/Ubiq.lhi @@ -30,8 +30,8 @@ import Kind ( Kind ) import Literal ( Literal ) import Maybes ( MaybeErr ) import MatchEnv ( MatchEnv ) -import Name ( Module(..), RdrName, Name ) -import Outputable ( ExportFlag, NamedThing(..), Outputable(..) ) +import Name ( Module(..), RdrName, Name, ExportFlag, NamedThing(..) ) +import Outputable ( Outputable(..) ) import PprStyle ( PprStyle ) import PragmaInfo ( PragmaInfo ) import Pretty ( PrettyRep ) @@ -44,9 +44,9 @@ import TcType ( TcMaybe ) import TyCon ( TyCon, Arity(..) ) import TyVar ( GenTyVar, TyVar(..) ) import Type ( GenType, Type(..) ) -import UniqFM ( UniqFM ) +import UniqFM ( UniqFM, Uniquable(..) ) import UniqSupply ( UniqSupply ) -import Unique ( Unique, Uniquable(..) ) +import Unique ( Unique ) import Usage ( GenUsage, Usage(..) ) import Util ( Ord3(..) ) diff --git a/ghc/compiler/utils/UniqFM.lhs b/ghc/compiler/utils/UniqFM.lhs index f23ef1f8f7..eb3cffbc9a 100644 --- a/ghc/compiler/utils/UniqFM.lhs +++ b/ghc/compiler/utils/UniqFM.lhs @@ -21,6 +21,7 @@ Basically, the things need to be in class @Uniquable@, and we use the module UniqFM ( UniqFM, -- abstract type + Uniquable(..), -- class to go with it emptyUFM, unitUFM, @@ -54,12 +55,12 @@ module UniqFM ( ) where #if defined(COMPILING_GHC) -CHK_Ubiq() -- debugging consistency check +import Ubiq{-uitous-} #endif -import Unique ( Unique, Uniquable(..), u2i, mkUniqueGrimily ) +import Unique ( Unique, u2i, mkUniqueGrimily ) import Util -import Outputable ( Outputable(..), ExportFlag ) +--import Outputable ( Outputable(..), ExportFlag ) import Pretty ( Pretty(..), PrettyRep ) import PprStyle ( PprStyle ) import SrcLoc ( SrcLoc ) @@ -261,6 +262,9 @@ data UniqFM ele (UniqFM ele) (UniqFM ele) +class Uniquable a where + uniqueOf :: a -> Unique + -- for debugging only :-) {- instance Text (UniqFM a) where diff --git a/ghc/compiler/utils/UniqSet.lhs b/ghc/compiler/utils/UniqSet.lhs index 67db337745..9df9fc852a 100644 --- a/ghc/compiler/utils/UniqSet.lhs +++ b/ghc/compiler/utils/UniqSet.lhs @@ -20,12 +20,12 @@ module UniqSet ( isEmptyUniqSet ) where -CHK_Ubiq() -- debugging consistency check +import Ubiq{-uitous-} import Maybes ( maybeToBool, Maybe ) import UniqFM -import Unique ( Uniquable(..), Unique ) -import Outputable ( Outputable(..), ExportFlag ) +import Unique ( Unique ) +--import Outputable ( Outputable(..), ExportFlag ) import SrcLoc ( SrcLoc ) import Pretty ( Pretty(..), PrettyRep ) import PprStyle ( PprStyle ) @@ -44,7 +44,7 @@ import Util ( Ord3(..) ) %* * %************************************************************************ -We use @UniqFM@, with a (@getItsUnique@-able) @Unique@ as ``key'' +We use @UniqFM@, with a (@uniqueOf@-able) @Unique@ as ``key'' and the thing itself as the ``value'' (for later retrieval). \begin{code} |