-- Ranamer types
ErrCtxt,
ImportAvails(..), emptyImportAvails, plusImportAvails,
- plusAvail, pruneAvails,
- AvailEnv, emptyAvailEnv, unitAvailEnv, plusAvailEnv,
- mkAvailEnv, lookupAvailEnv, lookupAvailEnv_maybe, availEnvElts, addAvail,
WhereFrom(..), mkModDeps,
-- Typechecker types
ArrowCtxt(NoArrowCtxt), newArrowScope, escapeArrowScope,
-- Insts
- Inst(..), InstOrigin(..), InstLoc(..), pprInstLoc,
- instLocSrcLoc, instLocSrcSpan,
- LIE, emptyLIE, unitLIE, plusLIE, consLIE,
+ Inst(..), InstOrigin(..), InstLoc(..),
+ pprInstLoc, pprInstArising, instLocSpan, instLocOrigin,
+ LIE, emptyLIE, unitLIE, plusLIE, consLIE, instLoc, instSpan,
plusLIEs, mkLIE, isEmptyLIE, lieToList, listToLIE,
-- Misc other types
import Packages
import Type
import TcType
+import TcGadt
import InstEnv
import FamInstEnv
import IOEnv
It is used * when processing the export list
* when constructing usage info for the inteface file
* to identify the list of directly imported modules
- for initialisation purposes
+ for initialisation purposes and
+ for optimsed overlap checking of family instances
* when figuring out what things are really unused
\begin{code}
data ImportAvails
= ImportAvails {
- imp_env :: ModuleNameEnv [AvailInfo],
- -- All the things imported *unqualified*, classified by
- -- the *module qualifier* for its import
- -- e.g. import List as Foo
- -- would add a binding Foo |-> ...stuff from List...
- -- to imp_env.
- --
- -- This is exactly the list of things that will be exported
- -- by a 'module M' specifier in the export list.
- -- (see Haskell 98 Report Section 5.2).
- --
- -- Warning: there may be duplciates in this list,
- -- duplicates are removed at the use site (rnExports).
- -- We might consider turning this into a NameEnv at
- -- some point.
-
imp_mods :: ModuleEnv (Module, Bool, SrcSpan),
-- Domain is all directly-imported modules
-- Bool means:
-- Orphan modules below us in the import tree (and maybe
-- including us for imported modules)
- imp_finsts :: [Module],
+ imp_finsts :: [Module]
-- Family instance modules below us in the import tree (and
-- maybe including us for imported modules)
-
- imp_parent :: NameEnv AvailInfo
- -- for the names in scope in this module, tells us
- -- the relationship between parents and children
- -- (eg. a TyCon is the parent of its DataCons, a
- -- class is the parent of its methods, etc.).
}
mkModDeps :: [(ModuleName, IsBootInterface)]
add env elt@(m,_) = addToUFM env m elt
emptyImportAvails :: ImportAvails
-emptyImportAvails = ImportAvails { imp_env = emptyUFM,
- imp_mods = emptyModuleEnv,
+emptyImportAvails = ImportAvails { imp_mods = emptyModuleEnv,
imp_dep_mods = emptyUFM,
imp_dep_pkgs = [],
imp_orphs = [],
- imp_finsts = [],
- imp_parent = emptyNameEnv }
+ imp_finsts = [] }
plusImportAvails :: ImportAvails -> ImportAvails -> ImportAvails
plusImportAvails
- (ImportAvails { imp_env = env1, imp_mods = mods1,
+ (ImportAvails { imp_mods = mods1,
imp_dep_mods = dmods1, imp_dep_pkgs = dpkgs1,
- imp_orphs = orphs1, imp_finsts = finsts1,
- imp_parent = parent1 })
- (ImportAvails { imp_env = env2, imp_mods = mods2,
+ imp_orphs = orphs1, imp_finsts = finsts1 })
+ (ImportAvails { imp_mods = mods2,
imp_dep_mods = dmods2, imp_dep_pkgs = dpkgs2,
- imp_orphs = orphs2, imp_finsts = finsts2,
- imp_parent = parent2 })
- = ImportAvails { imp_env = plusUFM_C (++) env1 env2,
- imp_mods = mods1 `plusModuleEnv` mods2,
+ imp_orphs = orphs2, imp_finsts = finsts2 })
+ = ImportAvails { imp_mods = mods1 `plusModuleEnv` mods2,
imp_dep_mods = plusUFM_C plus_mod_dep dmods1 dmods2,
imp_dep_pkgs = dpkgs1 `unionLists` dpkgs2,
imp_orphs = orphs1 `unionLists` orphs2,
- imp_finsts = finsts1 `unionLists` finsts2,
- imp_parent = plusNameEnv_C plus_avails parent1 parent2 }
+ imp_finsts = finsts1 `unionLists` finsts2 }
where
- plus_avails (AvailTC tc subs1) (AvailTC _ subs2)
- = AvailTC tc (nub (subs1 ++ subs2))
- plus_avails avail _ = avail
-
plus_mod_dep (m1, boot1) (m2, boot2)
= WARN( not (m1 == m2), (ppr m1 <+> ppr m2) $$ (ppr boot1 <+> ppr boot2) )
-- Check mod-names match
%************************************************************************
%* *
- Avails, AvailEnv, etc
-%* *
-v%************************************************************************
-
-\begin{code}
-plusAvail (Avail n1) (Avail n2) = Avail n1
-plusAvail (AvailTC n1 ns1) (AvailTC n2 ns2) = AvailTC n2 (ns1 `unionLists` ns2)
--- Added SOF 4/97
-#ifdef DEBUG
-plusAvail a1 a2 = pprPanic "RnEnv.plusAvail" (hsep [ppr a1,ppr a2])
-#endif
-
--------------------------
-pruneAvails :: (Name -> Bool) -- Keep if this is True
- -> [AvailInfo]
- -> [AvailInfo]
-pruneAvails keep avails
- = mapMaybe del avails
- where
- del :: AvailInfo -> Maybe AvailInfo -- Nothing => nothing left!
- del (Avail n) | keep n = Just (Avail n)
- | otherwise = Nothing
- del (AvailTC n ns) | null ns' = Nothing
- | otherwise = Just (AvailTC n ns')
- where
- ns' = filter keep ns
-\end{code}
-
----------------------------------------
- AvailEnv and friends
----------------------------------------
-
-\begin{code}
-type AvailEnv = NameEnv AvailInfo -- Maps a Name to the AvailInfo that contains it
-
-emptyAvailEnv :: AvailEnv
-emptyAvailEnv = emptyNameEnv
-
-unitAvailEnv :: AvailInfo -> AvailEnv
-unitAvailEnv a = unitNameEnv (availName a) a
-
-plusAvailEnv :: AvailEnv -> AvailEnv -> AvailEnv
-plusAvailEnv = plusNameEnv_C plusAvail
-
-lookupAvailEnv_maybe :: AvailEnv -> Name -> Maybe AvailInfo
-lookupAvailEnv_maybe = lookupNameEnv
-
-lookupAvailEnv :: AvailEnv -> Name -> AvailInfo
-lookupAvailEnv env n = case lookupNameEnv env n of
- Just avail -> avail
- Nothing -> pprPanic "lookupAvailEnv" (ppr n)
-
-availEnvElts = nameEnvElts
-
-addAvail :: AvailEnv -> AvailInfo -> AvailEnv
-addAvail avails avail = extendNameEnv_C plusAvail avails (availName avail) avail
-
-mkAvailEnv :: [AvailInfo] -> AvailEnv
- -- 'avails' may have several items with the same availName
- -- E.g import Ix( Ix(..), index )
- -- will give Ix(Ix,index,range) and Ix(index)
- -- We want to combine these; addAvail does that
-mkAvailEnv avails = foldl addAvail emptyAvailEnv avails
-\end{code}
-
-%************************************************************************
-%* *
\subsection{Where from}
%* *
%************************************************************************
tci_loc :: InstLoc
}
+ | ImplicInst { -- An implication constraint
+ -- forall tvs. (reft, given) => wanted
+ tci_name :: Name,
+ tci_tyvars :: [TcTyVar], -- Includes coercion variables
+ -- mentioned in tci_reft
+ tci_reft :: Refinement,
+ tci_given :: [Inst], -- Only Dicts
+ -- (no Methods, LitInsts, ImplicInsts)
+ tci_wanted :: [Inst], -- Only Dicts and ImplicInsts
+ -- (no Methods or LitInsts)
+ tci_loc :: InstLoc
+ }
+
| Method {
tci_id :: TcId, -- The Id for the Inst
@Insts@ are ordered by their class/type info, rather than by their
unique. This allows the context-reduction mechanism to use standard finite
-maps to do their stuff.
+maps to do their stuff. It's horrible that this code is here, rather
+than with the Avails handling stuff in TcSimplify
\begin{code}
instance Ord Inst where
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
+
+ -- Implication constraints are compared by *name*
+ -- not by type; that is, we make no attempt to do CSE on them
+cmpInst (ImplicInst {}) (Dict {}) = GT
+cmpInst (ImplicInst {}) (Method {}) = GT
+cmpInst (ImplicInst {}) (LitInst {}) = GT
+cmpInst i1@(ImplicInst {}) i2@(ImplicInst {}) = tci_name i1 `compare` tci_name i2
\end{code}
functions that deal with it.
\begin{code}
+-------------------------------------------
data InstLoc = InstLoc InstOrigin SrcSpan ErrCtxt
-instLocSrcLoc :: InstLoc -> SrcLoc
-instLocSrcLoc (InstLoc _ src_span _) = srcSpanStart src_span
+instLoc :: Inst -> InstLoc
+instLoc inst = tci_loc inst
+
+instSpan :: Inst -> SrcSpan
+instSpan wanted = instLocSpan (instLoc wanted)
-instLocSrcSpan :: InstLoc -> SrcSpan
-instLocSrcSpan (InstLoc _ src_span _) = src_span
+instLocSpan :: InstLoc -> SrcSpan
+instLocSpan (InstLoc _ s _) = s
+instLocOrigin :: InstLoc -> InstOrigin
+instLocOrigin (InstLoc o _ _) = o
+
+pprInstArising :: Inst -> SDoc
+pprInstArising loc = ptext SLIT("arising from") <+> pprInstLoc (tci_loc loc)
+
+pprInstLoc :: InstLoc -> SDoc
+pprInstLoc (InstLoc orig span _) = sep [ppr orig, text "at" <+> ppr span]
+
+-------------------------------------------
data InstOrigin
= SigOrigin SkolemInfo -- Pattern, class decl, inst decl etc;
-- Places that bind type variables and introduce
| DefaultOrigin -- Typechecking a default decl
| DoOrigin -- Arising from a do expression
| ProcOrigin -- Arising from a proc expression
-\end{code}
-
-\begin{code}
-pprInstLoc :: InstLoc -> SDoc
-pprInstLoc (InstLoc orig locn _)
- = sep [text "arising from" <+> pp_orig orig,
- text "at" <+> ppr locn]
- where
- pp_orig (OccurrenceOf name) = hsep [ptext SLIT("use of"), quotes (ppr name)]
- pp_orig (IPOccOrigin name) = hsep [ptext SLIT("use of implicit parameter"), quotes (ppr name)]
- pp_orig (IPBindOrigin name) = hsep [ptext SLIT("binding for implicit parameter"), quotes (ppr name)]
- pp_orig RecordUpdOrigin = ptext SLIT("a record update")
- pp_orig (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
- pp_orig (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
- pp_orig (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
- pp_orig InstSigOrigin = ptext SLIT("instantiating a type signature")
- pp_orig InstScOrigin = ptext SLIT("the superclasses of an instance declaration")
- pp_orig DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration")
- pp_orig StandAloneDerivOrigin = ptext SLIT("a 'deriving' declaration")
- pp_orig DefaultOrigin = ptext SLIT("a 'default' declaration")
- pp_orig DoOrigin = ptext SLIT("a do statement")
- pp_orig ProcOrigin = ptext SLIT("a proc expression")
- pp_orig (SigOrigin info) = pprSkolInfo info
+ | ImplicOrigin SDoc -- An implication constraint
+
+instance Outputable InstOrigin where
+ ppr (OccurrenceOf name) = hsep [ptext SLIT("a use of"), quotes (ppr name)]
+ ppr (IPOccOrigin name) = hsep [ptext SLIT("a use of implicit parameter"), quotes (ppr name)]
+ ppr (IPBindOrigin name) = hsep [ptext SLIT("a binding for implicit parameter"), quotes (ppr name)]
+ ppr RecordUpdOrigin = ptext SLIT("a record update")
+ ppr (LiteralOrigin lit) = hsep [ptext SLIT("the literal"), quotes (ppr lit)]
+ ppr (ArithSeqOrigin seq) = hsep [ptext SLIT("the arithmetic sequence"), quotes (ppr seq)]
+ ppr (PArrSeqOrigin seq) = hsep [ptext SLIT("the parallel array sequence"), quotes (ppr seq)]
+ ppr InstSigOrigin = ptext SLIT("instantiating a type signature")
+ ppr InstScOrigin = ptext SLIT("the superclasses of an instance declaration")
+ ppr DerivOrigin = ptext SLIT("the 'deriving' clause of a data type declaration")
+ ppr StandAloneDerivOrigin = ptext SLIT("a 'deriving' declaration")
+ ppr DefaultOrigin = ptext SLIT("a 'default' declaration")
+ ppr DoOrigin = ptext SLIT("a do statement")
+ ppr ProcOrigin = ptext SLIT("a proc expression")
+ ppr (ImplicOrigin doc) = doc
+ ppr (SigOrigin info) = pprSkolInfo info
\end{code}
projects / ghc-hetmet.git / blobdiff