X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcRnTypes.lhs;h=7b4f85a2e1b46e1f751fb430b30473422b2486cb;hp=a72caa48556b39d9c4ff4538784b9dbf0bd069d9;hb=61bcd16d4f3d4cf84b26bf7bb92f16f0440b7071;hpb=526c3af1dc98987b6949f4df73c0debccf9875bd diff --git a/compiler/typecheck/TcRnTypes.lhs b/compiler/typecheck/TcRnTypes.lhs index a72caa4..7b4f85a 100644 --- a/compiler/typecheck/TcRnTypes.lhs +++ b/compiler/typecheck/TcRnTypes.lhs @@ -3,13 +3,6 @@ % (c) The GRASP Project, Glasgow University, 1992-2002 % \begin{code} -{-# OPTIONS -w #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details - module TcRnTypes( TcRnIf, TcRn, TcM, RnM, IfM, IfL, IfG, -- The monad is opaque outside this module TcRef, @@ -20,7 +13,7 @@ module TcRnTypes( IfGblEnv(..), IfLclEnv(..), -- Ranamer types - ErrCtxt, RecFieldEnv, + ErrCtxt, RecFieldEnv(..), ImportAvails(..), emptyImportAvails, plusImportAvails, WhereFrom(..), mkModDeps, @@ -35,7 +28,7 @@ module TcRnTypes( ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope, -- Insts - Inst(..), InstOrigin(..), InstLoc(..), + Inst(..), EqInstCo, InstOrigin(..), InstLoc(..), pprInstLoc, pprInstArising, instLocSpan, instLocOrigin, LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan, plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE, @@ -49,7 +42,6 @@ module TcRnTypes( import HsSyn hiding (LIE) import HscTypes -import Packages import Type import Coercion import TcType @@ -73,7 +65,6 @@ import Util import Bag import Outputable import ListSetOps -import FiniteMap import FastString import Data.Maybe @@ -217,18 +208,13 @@ data TcGblEnv -- The binds, rules and foreign-decl fiels are collected -- initially in un-zonked form and are finally zonked in tcRnSrcDecls - -- The next fields accumulate the payload of the - -- module The binds, rules and foreign-decl fiels are - -- collected initially in un-zonked form and are - -- finally zonked in tcRnSrcDecls - tcg_rn_imports :: Maybe [LImportDecl Name], tcg_rn_exports :: Maybe [Located (IE Name)], tcg_rn_decls :: Maybe (HsGroup Name), -- renamed decls, maybe -- Nothing <=> Don't retain renamed decls tcg_binds :: LHsBinds Id, -- Value bindings in this module - tcg_deprecs :: Deprecations, -- ...Deprecations + tcg_warns :: Warnings, -- ...Warnings and deprecations tcg_insts :: [Instance], -- ...Instances tcg_fam_insts :: [FamInst], -- ...Family instances tcg_rules :: [LRuleDecl Id], -- ...Rules @@ -239,13 +225,18 @@ data TcGblEnv tcg_hpc :: AnyHpcUsage -- True if any part of the prog uses hpc instrumentation. } -type RecFieldEnv = NameEnv [Name] -- Maps a constructor name *in this module* - -- to the fields for that constructor +data RecFieldEnv + = RecFields (NameEnv [Name]) -- Maps a constructor name *in this module* + -- to the fields for that constructor + NameSet -- Set of all fields declared *in this module*; + -- used to suppress name-shadowing complaints + -- when using record wild cards + -- E.g. let fld = e in C {..} -- This is used when dealing with ".." notation in record -- construction and pattern matching. - -- The FieldEnv deals *only* with constructors defined in - -- *thie* module. For imported modules, we get the same info - -- from the TypeEnv + -- The FieldEnv deals *only* with constructors defined in *this* + -- module. For imported modules, we get the same info from the + -- TypeEnv \end{code} %************************************************************************ @@ -647,7 +638,7 @@ I am not convinced that this duplication is necessary or useful! -=chak data Inst = Dict { tci_name :: Name, - tci_pred :: TcPredType, + tci_pred :: TcPredType, -- Class or implicit parameter only tci_loc :: InstLoc } @@ -709,27 +700,26 @@ data Inst -- co :: ty1 ~ ty2 tci_left :: TcType, -- ty1 -- both types are... tci_right :: TcType, -- ty2 -- ...free of boxes - tci_co :: Either -- co - TcTyVar -- - a wanted equation, with a hole, to be - -- filled with a witness for the equality; - -- for equation arising from deferring - -- unification, 'ty1' is the actual and - -- 'ty2' the expected type - Coercion, -- - a given equation, with a coercion - -- witnessing the equality; - -- a coercion that originates from a - -- signature or a GADT is a CoVar, but - -- after normalisation of coercions, they - -- can be arbitrary Coercions involving - -- constructors and pseudo-constructors - -- like sym and trans. + tci_co :: EqInstCo, -- co tci_loc :: InstLoc, tci_name :: Name -- Debugging help only: this makes it easier to -- follow where a constraint is used in a morass - -- of trace messages! Unlike other Insts, it has - -- no semantic significance whatsoever. + -- of trace messages! Unlike other Insts, it + -- has no semantic significance whatsoever. } + +type EqInstCo = Either -- Distinguish between given and wanted coercions + TcTyVar -- - a wanted equation, with a hole, to be filled + -- with a witness for the equality; for equation + -- arising from deferring unification, 'ty1' is + -- the actual and 'ty2' the expected type + Coercion -- - a given equation, with a coercion witnessing + -- the equality; a coercion that originates + -- from a signature or a GADT is a CoVar, but + -- after normalisation of coercions, they can + -- be arbitrary Coercions involving constructors + -- and pseudo-constructors like sym and trans. \end{code} @Insts@ are ordered by their class/type info, rather than by their @@ -739,26 +729,28 @@ than with the Avails handling stuff in TcSimplify \begin{code} instance Ord Inst where - compare = cmpInst + compare = cmpInst + -- Used *only* for AvailEnv in TcSimplify instance Eq Inst where (==) i1 i2 = case i1 `cmpInst` i2 of - EQ -> True - other -> False + EQ -> True + _ -> False +cmpInst :: Inst -> Inst -> Ordering cmpInst d1@(Dict {}) d2@(Dict {}) = tci_pred d1 `tcCmpPred` tci_pred d2 -cmpInst (Dict {}) other = LT +cmpInst (Dict {}) _ = LT cmpInst (Method {}) (Dict {}) = GT cmpInst m1@(Method {}) m2@(Method {}) = (tci_oid m1 `compare` tci_oid m2) `thenCmp` (tci_tys m1 `tcCmpTypes` tci_tys m2) -cmpInst (Method {}) other = LT +cmpInst (Method {}) _ = LT cmpInst (LitInst {}) (Dict {}) = GT cmpInst (LitInst {}) (Method {}) = GT cmpInst l1@(LitInst {}) l2@(LitInst {}) = (tci_lit l1 `compare` tci_lit l2) `thenCmp` (tci_ty l1 `tcCmpType` tci_ty l2) -cmpInst (LitInst {}) other = LT +cmpInst (LitInst {}) _ = LT -- Implication constraints are compared by *name* -- not by type; that is, we make no attempt to do CSE on them @@ -766,14 +758,15 @@ cmpInst (ImplicInst {}) (Dict {}) = GT cmpInst (ImplicInst {}) (Method {}) = GT cmpInst (ImplicInst {}) (LitInst {}) = GT cmpInst i1@(ImplicInst {}) i2@(ImplicInst {}) = tci_name i1 `compare` tci_name i2 -cmpInst (ImplicInst {}) other = LT +cmpInst (ImplicInst {}) _ = LT -- same for Equality constraints -cmpInst (EqInst {}) (Dict {}) = GT -cmpInst (EqInst {}) (Method {}) = GT -cmpInst (EqInst {}) (LitInst {}) = GT -cmpInst (EqInst {}) (ImplicInst {}) = GT -cmpInst i1@(EqInst {}) i2@(EqInst {}) = tci_name i1 `compare` tci_name i2 +cmpInst (EqInst {}) (Dict {}) = GT +cmpInst (EqInst {}) (Method {}) = GT +cmpInst (EqInst {}) (LitInst {}) = GT +cmpInst (EqInst {}) (ImplicInst {}) = GT +cmpInst i1@(EqInst {}) i2@(EqInst {}) = (tci_left i1 `tcCmpType` tci_left i2) `thenCmp` + (tci_right i1 `tcCmpType` tci_right i2) \end{code} @@ -787,15 +780,31 @@ cmpInst i1@(EqInst {}) i2@(EqInst {}) = tci_name i1 `compare` tci_name i -- FIXME: Rename this. It clashes with (Located (IE ...)) type LIE = Bag Inst -isEmptyLIE = isEmptyBag -emptyLIE = emptyBag -unitLIE inst = unitBag inst -mkLIE insts = listToBag insts +isEmptyLIE :: LIE -> Bool +isEmptyLIE = isEmptyBag + +emptyLIE :: LIE +emptyLIE = emptyBag + +unitLIE :: Inst -> LIE +unitLIE inst = unitBag inst + +mkLIE :: [Inst] -> LIE +mkLIE insts = listToBag insts + +plusLIE :: LIE -> LIE -> LIE plusLIE lie1 lie2 = lie1 `unionBags` lie2 -plusLIEs lies = unionManyBags lies -lieToList = bagToList -listToLIE = listToBag +plusLIEs :: [LIE] -> LIE +plusLIEs lies = unionManyBags lies + +lieToList :: LIE -> [Inst] +lieToList = bagToList + +listToLIE :: [Inst] -> LIE +listToLIE = listToBag + +consLIE :: Inst -> LIE -> LIE consLIE inst lie = lie `snocBag` inst -- Putting the new Inst at the *end* of the bag is a half-hearted attempt -- to ensure that we tend to report the *leftmost* type-constraint error @@ -904,4 +913,5 @@ instance Outputable InstOrigin where ppr (ImplicOrigin doc) = doc ppr (SigOrigin info) = pprSkolInfo info ppr EqOrigin = ptext (sLit "a type equality") + ppr InstSigOrigin = panic "ppr InstSigOrigin" \end{code}