-- import TcSuspension
import qualified Type
import Id
+import Coercion
import Var
import VarSet
import VarEnv
import Class
import Name
import NameEnv
-import OccName
import HscTypes
import SrcLoc
import Outputable
-import Maybes
import Unique
import FastString
\end{code}
}}}}}
tcLookupField :: Name -> TcM Id -- Returns the selector Id
-tcLookupField name = do
- thing <- tcLookup name -- Note [Record field lookup]
- case thing of
- AGlobal (AnId id) -> return id
- thing -> wrongThingErr "field name" thing name
+tcLookupField name
+ = tcLookupId name -- Note [Record field lookup]
{- Note [Record field lookup]
~~~~~~~~~~~~~~~~~~~~~~~~~~
-- Look up the instance tycon of a family instance.
--
--- The match must be unique - ie, match exactly one instance - but the
--- type arguments used for matching may be more specific than those of
--- the family instance declaration.
+-- The match may be ambiguous (as we know that overlapping instances have
+-- identical right-hand sides under overlapping substitutions - see
+-- 'FamInstEnv.lookupFamInstEnvConflicts'). However, the type arguments used
+-- for matching must be equal to or be more specific than those of the family
+-- instance declaration. We pick one of the matches in case of ambiguity; as
+-- the right-hand sides are identical under the match substitution, the choice
+-- does not matter.
--
-- Return the instance tycon and its type instance. For example, if we have
--
; eps <- getEps
; let instEnv = (eps_fam_inst_env eps, tcg_fam_inst_env env)
; case lookupFamInstEnv instEnv tycon tys of
- [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst,
- rep_tys)
- _ -> return Nothing
+ [] -> return Nothing
+ ((fam_inst, rep_tys):_)
+ -> return $ Just (famInstTyCon fam_inst, rep_tys)
}
\end{code}
+\begin{code}
+instance MonadThings (IOEnv (Env TcGblEnv TcLclEnv)) where
+ lookupThing = tcLookupGlobal
+\end{code}
+
%************************************************************************
%* *
Extending the global environment
\begin{code}
instance Outputable ThStage where
- ppr Comp = text "Comp"
+ ppr (Comp l) = text "Comp" <+> int l
ppr (Brack l _ _) = text "Brack" <+> int l
ppr (Splice l) = text "Splice" <+> int l
thLevel :: ThStage -> ThLevel
-thLevel Comp = topLevel
+thLevel (Comp l) = l
thLevel (Splice l) = l
thLevel (Brack l _ _) = l
| bind_lvl == topLevel -- GHC restriction on top level splices
= failWithTc $
sep [ptext (sLit "GHC stage restriction:") <+> pp_thing,
- nest 2 (ptext (sLit "is used in a top-level splice, and must be imported, not defined locally"))]
+ nest 2 (ptext (sLit "is used in") <+> use_lvl_doc <> ptext (sLit ", and must be imported, not defined locally"))]
| otherwise -- Badly staged
= failWithTc $ -- E.g. \x -> $(f x)
ptext (sLit "but used at stage") <+> ppr use_lvl]
where
use_lvl = thLevel use_stage
-
+ use_lvl_doc | use_lvl == thLevel topStage = ptext (sLit "a top-level splice")
+ | use_lvl == thLevel topAnnStage = ptext (sLit "an annotation")
+ | otherwise = panic "checkWellStaged"
topIdLvl :: Id -> ThLevel
-- Globals may either be imported, or may be from an earlier "chunk"
(LHsBinds a) -- Bindings for the instance methods
[LSig a] -- User pragmas recorded for generating
-- specialised instances
+ Bool -- True <=> This code came from a standalone deriving clause
| NewTypeDerived -- Used for deriving instances of newtypes, where the
- -- witness dictionary is identical to the argument
+ CoercionI -- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas.
+ -- The coercion maps from newtype to the representation type
+ -- (mentioning type variables bound by the forall'd iSpec variables)
+ -- E.g. newtype instance N [a] = N1 (Tree a)
+ -- co : N [a] ~ Tree a
pprInstInfo :: InstInfo a -> SDoc
pprInstInfo info = vcat [ptext (sLit "InstInfo:") <+> ppr (idType (iDFunId info))]
pprInstInfoDetails :: OutputableBndr a => InstInfo a -> SDoc
pprInstInfoDetails info = pprInstInfo info $$ nest 2 (details (iBinds info))
where
- details (VanillaInst b _) = pprLHsBinds b
- details NewTypeDerived = text "Derived from the representation type"
+ details (VanillaInst b _ _) = pprLHsBinds b
+ details (NewTypeDerived _) = text "Derived from the representation type"
simpleInstInfoClsTy :: InstInfo a -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
\begin{code}
newDFunName :: Class -> [Type] -> SrcSpan -> TcM Name
-newDFunName clas (ty:_) loc
- = do { index <- nextDFunIndex
- ; is_boot <- tcIsHsBoot
+newDFunName clas tys loc
+ = do { is_boot <- tcIsHsBoot
; mod <- getModule
; let info_string = occNameString (getOccName clas) ++
- occNameString (getDFunTyKey ty)
- dfun_occ = mkDFunOcc info_string is_boot index
-
+ concatMap (occNameString.getDFunTyKey) tys
+ ; dfun_occ <- chooseUniqueOccTc (mkDFunOcc info_string is_boot)
; newGlobalBinder mod dfun_occ loc }
-
-newDFunName clas [] loc = pprPanic "newDFunName" (ppr clas <+> ppr loc)
\end{code}
Make a name for the representation tycon of a family instance. It's an
newGlobalBinder.
\begin{code}
-newFamInstTyConName :: Name -> SrcSpan -> TcM Name
-newFamInstTyConName tc_name loc
- = do { index <- nextDFunIndex
- ; mod <- getModule
- ; let occ = nameOccName tc_name
- ; newGlobalBinder mod (mkInstTyTcOcc index occ) loc }
+newFamInstTyConName :: Name -> [Type] -> SrcSpan -> TcM Name
+newFamInstTyConName tc_name tys loc
+ = do { mod <- getModule
+ ; let info_string = occNameString (getOccName tc_name) ++
+ concatMap (occNameString.getDFunTyKey) tys
+ ; occ <- chooseUniqueOccTc (mkInstTyTcOcc info_string)
+ ; newGlobalBinder mod occ loc }
\end{code}
Stable names used for foreign exports and annotations.
projects / ghc-hetmet.git / blobdiff