import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails )
import OccName
import Var ( Id, TyVar, idType )
-import Module ( moduleString )
+import Module ( moduleName, moduleNameString, modulePackageId )
import TcRnMonad
import IfaceEnv ( lookupOrig )
import Class ( Class, classExtraBigSig )
import IdInfo ( GlobalIdDetails(..) )
import TysWiredIn ( mkListTy )
import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName )
+import DsExpr ( dsLExpr )
+import DsMonad ( initDsTc )
import ErrUtils ( Message )
import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
import Outputable
import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
-
+import PackageConfig ( packageIdString )
import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
import Panic ( showException )
import FastString ( LitString )
%************************************************************************
\begin{code}
-tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr Id)
+tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcBracket brack res_ty
= getStage `thenM` \ level ->
case bracketOK level of {
-> LHsExpr Id -- Of type X
-> TcM hs_syn -- Of type t
runMeta convert expr
- = do { hsc_env <- getTopEnv
- ; tcg_env <- getGblEnv
- ; this_mod <- getModule
- ; let type_env = tcg_type_env tcg_env
- rdr_env = tcg_rdr_env tcg_env
+ = do { -- Desugar
+ ds_expr <- initDsTc (dsLExpr expr)
-- Compile and link it; might fail if linking fails
+ ; hsc_env <- getTopEnv
+ ; src_span <- getSrcSpanM
; either_hval <- tryM $ ioToTcRn $
- HscMain.compileExpr
- hsc_env this_mod
- rdr_env type_env expr
+ HscMain.compileExpr hsc_env src_span ds_expr
; case either_hval of {
Left exn -> failWithTc (mk_msg "compile and link" exn) ;
Right hval -> do
qReport True msg = addErr (text msg)
qReport False msg = addReport (text msg)
- qCurrentModule = do { m <- getModule; return (moduleString m) }
+ qCurrentModule = do { m <- getModule;
+ return (moduleNameString (moduleName m)) }
+ -- ToDo: is throwing away the package name ok here?
+
qReify v = reify v
- qRecover = recoverM
+
+ -- For qRecover, discard error messages if
+ -- the recovery action is chosen. Otherwise
+ -- we'll only fail higher up. c.f. tryTcLIE_
+ qRecover recover main = do { (msgs, mb_res) <- tryTcErrs main
+ ; case mb_res of
+ Just val -> do { addMessages msgs -- There might be warnings
+ ; return val }
+ Nothing -> recover -- Discard all msgs
+ }
qRunIO io = ioToTcRn io
\end{code}
; reifyThing thing
}
where
- ppr_ns (TH.Name _ (TH.NameG TH.DataName mod)) = text "data"
- ppr_ns (TH.Name _ (TH.NameG TH.TcClsName mod)) = text "tc"
- ppr_ns (TH.Name _ (TH.NameG TH.VarName mod)) = text "var"
+ ppr_ns (TH.Name _ (TH.NameG TH.DataName _pkg _mod)) = text "data"
+ ppr_ns (TH.Name _ (TH.NameG TH.TcClsName _pkg _mod)) = text "tc"
+ ppr_ns (TH.Name _ (TH.NameG TH.VarName _pkg _mod)) = text "var"
lookupThName :: TH.Name -> TcM Name
lookupThName th_name@(TH.Name occ flavour)
else do -- It's imported
{ (eps,hpt) <- getEpsAndHpt
- ; case lookupType hpt (eps_PTE eps) name of
+ ; dflags <- getDOpts
+ ; case lookupType dflags hpt (eps_PTE eps) name of
Just thing -> return (AGlobal thing)
Nothing -> do { thing <- tcImportDecl name
; return (AGlobal thing) }
; fix <- reifyFixity name
; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
-reifyThing (ATcId id _ _)
- = do { ty1 <- zonkTcType (idType id) -- Make use of all the info we have, even
- -- though it may be incomplete
+reifyThing (ATcId {tct_id = id, tct_type = ty})
+ = do { ty1 <- zonkTcType ty -- Make use of all the info we have, even
+ -- though it may be incomplete
; ty2 <- reifyType ty1
; fix <- reifyFixity (idName id)
; return (TH.VarI (reifyName id) ty2 Nothing fix) }
| isFunTyCon tc = return (TH.PrimTyConI (reifyName tc) 2 False)
| isPrimTyCon tc = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
| isSynTyCon tc
- = do { let (tvs, rhs) = synTyConDefn tc
- ; rhs' <- reifyType rhs
- ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+ = case synTyConDefn tc of
+ Nothing -> noTH SLIT("type family") (ppr tc)
+ Just (tvs, rhs) ->
+ do { rhs' <- reifyType rhs
+ ; return (TH.TyConI $
+ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; ops <- mapM reify_op op_stuff
; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
where
- (tvs, fds, theta, _, op_stuff) = classExtraBigSig cls
+ (tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
fds' = map reifyFunDep fds
reify_op (op, _) = do { ty <- reifyType (idType op)
; return (TH.SigD (reifyName op) ty) }
------------------------------
reifyName :: NamedThing n => n -> TH.Name
reifyName thing
- | isExternalName name = mk_varg mod occ_str
+ | isExternalName name = mk_varg pkg_str mod_str occ_str
| otherwise = TH.mkNameU occ_str (getKey (getUnique name))
-- Many of the things we reify have local bindings, and
-- NameL's aren't supposed to appear in binding positions, so
-- have free variables, we may need to generate NameL's for them.
where
name = getName thing
- mod = moduleString (nameModule name)
+ mod = nameModule name
+ pkg_str = packageIdString (modulePackageId mod)
+ mod_str = moduleNameString (moduleName mod)
occ_str = occNameString occ
occ = nameOccName name
mk_varg | OccName.isDataOcc occ = TH.mkNameG_d
projects / ghc-hetmet.git / blobdiff