%
\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 TcEnv(
TyThing(..), TcTyThing(..), TcId,
-- New Ids
newLocalName, newDFunName, newFamInstTyConName,
-
- -- Errors
- famInstNotFound
) where
#include "HsVersions.h"
import TcMType
import TcType
import TcGadt
+-- import TcSuspension
import qualified Type
import Var
import VarSet
import FamInstEnv
import DataCon
import TyCon
+import TypeRep
+import Coercion
import Class
import Name
import PrelNames
import HscTypes
import SrcLoc
import Outputable
+import Maybes
\end{code}
= do { env <- getGblEnv
-- Try local envt
- ; case lookupNameEnv (tcg_type_env env) name of {
+ ; case lookupNameEnv (tcg_type_env env) name of {
Just thing -> return thing ;
Nothing -> do
-- Should it have been in the local envt?
{ case nameModule_maybe name of
- Nothing -> notFound name -- Internal names can happen in GHCi
+ Nothing -> notFound name env -- Internal names can happen in GHCi
Just mod | mod == tcg_mod env -- Names from this module
- -> notFound name -- should be in tcg_type_env
+ -> notFound name env -- should be in tcg_type_env
| mod == thFAKE -- Names bound in TH declaration brackets
- -> notFound name -- should be in tcg_env
+ -> notFound name env -- should be in tcg_env
| otherwise
-> tcImportDecl name -- Go find it in an interface
}}}}}
tcLookupLocatedTyCon :: Located Name -> TcM TyCon
tcLookupLocatedTyCon = addLocM tcLookupTyCon
--- Look up the representation tycon of a family instance.
+-- 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
--
-- which implies that :R42T was declared as 'data instance T [a]'.
--
-tcLookupFamInst :: TyCon -> [Type] -> TcM (TyCon, [Type])
+tcLookupFamInst :: TyCon -> [Type] -> TcM (Maybe (TyCon, [Type]))
tcLookupFamInst tycon tys
| not (isOpenTyCon tycon)
- = return (tycon, tys)
+ = return Nothing
| otherwise
= do { env <- getGblEnv
; 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 (famInstTyCon fam_inst, rep_tys)
- other -> famInstNotFound tycon tys other
+ [(fam_inst, rep_tys)] -> return $ Just (famInstTyCon fam_inst,
+ rep_tys)
+ other -> return Nothing
}
\end{code}
extra_env = [ (name, ATcId { tct_id = id,
tct_level = th_lvl,
tct_type = id_ty,
- tct_co = if isRefineableTy id_ty
- then Just idHsWrapper
- else Nothing })
+ tct_co = case isRefineableTy id_ty of
+ (True,_) -> Unrefineable
+ (_,True) -> Rigid idHsWrapper
+ _ -> Wobbly})
| (name,id) <- names_w_ids, let id_ty = idType id]
le' = extendNameEnvList (tcl_env env) extra_env
rdr_env' = extendLocalRdrEnv (tcl_rdr env) [name | (name,_) <- names_w_ids]
\end{code}
\begin{code}
-refineEnvironment :: Refinement -> TcM a -> TcM a
+refineEnvironment
+ :: Refinement
+ -> Bool -- whether type equations are involved
+ -> TcM a
+ -> TcM a
-- I don't think I have to refine the set of global type variables in scope
-- Reason: the refinement never increases that set
-refineEnvironment reft thing_inside
- | isEmptyRefinement reft -- Common case
+refineEnvironment reft otherEquations thing_inside
+ | isEmptyRefinement reft -- Common case
+ , not otherEquations
= thing_inside
| otherwise
= do { env <- getLclEnv
; let le' = mapNameEnv refine (tcl_env env)
; setLclEnv (env {tcl_env = le'}) thing_inside }
where
- refine elt@(ATcId { tct_co = Just co, tct_type = ty })
+ refine elt@(ATcId { tct_co = Rigid co, tct_type = ty })
| Just (co', ty') <- refineType reft ty
- = elt { tct_co = Just (WpCo co' <.> co), tct_type = ty' }
+ = elt { tct_co = Rigid (WpCo co' <.> co), tct_type = ty' }
+ refine elt@(ATcId { tct_co = Wobbly})
+-- Main new idea: make wobbly things invisible whenever there
+-- is a refinement of any sort
+-- | otherEquations
+ = elt { tct_co = WobblyInvisible}
refine (ATyVar tv ty)
| Just (_, ty') <- refineType reft ty
= ATyVar tv ty' -- Ignore the coercion that refineType returns
checkWellStaged :: SDoc -- What the stage check is for
- -> ThLevel -- Binding level
+ -> ThLevel -- Binding level (increases inside brackets)
-> ThStage -- Use stage
-> TcM () -- Fail if badly staged, adding an error
checkWellStaged pp_thing bind_lvl use_stage
- | bind_lvl <= use_lvl -- OK!
- = returnM ()
+ | use_lvl >= bind_lvl -- OK! Used later than bound
+ = returnM () -- E.g. \x -> [| $(f x) |]
| bind_lvl == topLevel -- GHC restriction on top level splices
= failWithTc $
nest 2 (ptext SLIT("is used in a top-level splice, and must be imported, not defined locally"))]
| otherwise -- Badly staged
- = failWithTc $
+ = failWithTc $ -- E.g. \x -> $(f x)
ptext SLIT("Stage error:") <+> pp_thing <+>
hsep [ptext SLIT("is bound at stage") <+> ppr bind_lvl,
ptext SLIT("but used at stage") <+> ppr use_lvl]
data InstBindings
= VanillaInst -- The normal case
- (LHsBinds Name) -- Bindings
+ (LHsBinds Name) -- Bindings for the instance methods
[LSig Name] -- User pragmas recorded for generating
-- specialised instances
| NewTypeDerived -- Used for deriving instances of newtypes, where the
-- witness dictionary is identical to the argument
-- dictionary. Hence no bindings, no pragmas.
- (Maybe [PredType])
- -- Nothing => The newtype-derived instance involves type variables,
- -- and the dfun has a type like df :: forall a. Eq a => Eq (T a)
- -- Just (r:scs) => The newtype-defined instance has no type variables
- -- so the dfun is just a constant, df :: Eq T
- -- In this case we need to know waht the rep dict, r, and the
- -- superclasses, scs, are. (In the Nothing case these are in the
- -- dict fun's type.)
- -- Invariant: these PredTypes have no free variables
- -- NB: In both cases, the representation dict is the *first* dict.
pprInstInfo info = vcat [ptext SLIT("InstInfo:") <+> ppr (idType (iDFunId info))]
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 -> (Class, Type)
simpleInstInfoClsTy info = case instanceHead (iSpec info) of
pprBinders [bndr] = quotes (ppr bndr)
pprBinders bndrs = pprWithCommas ppr bndrs
-notFound name
- = failWithTc (ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
- ptext SLIT("is not in scope"))
+notFound name env
+ = failWithTc (vcat[ptext SLIT("GHC internal error:") <+> quotes (ppr name) <+>
+ ptext SLIT("is not in scope during type checking, but it passed the renamer"),
+ ptext SLIT("tcg_type_env of environment:") <+> ppr (tcg_type_env env)]
+ )
wrongThingErr expected thing name
= failWithTc (pprTcTyThingCategory thing <+> quotes (ppr name) <+>
ptext SLIT("used as a") <+> text expected)
-
-famInstNotFound tycon tys what
- = failWithTc (msg <+> quotes (pprTypeApp (ppr tycon) tys))
- where
- msg = ptext $ if length what > 1
- then SLIT("More than one family instance for")
- else SLIT("No family instance exactly matching")
\end{code}
projects / ghc-hetmet.git / blobdiff