import TcHsType
import TcIface
import TypeRep
+import InstEnv
import Name
import NameEnv
import NameSet
%************************************************************************
\begin{code}
-tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
+tcBracket :: HsBracket Name -> TcRhoType -> TcM (LHsExpr TcId)
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
-tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
+tcSpliceExpr :: HsSplice Name -> TcRhoType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> FreeVars -> TcM (HsType Name, TcKind)
-- None of these functions add constraints to the LIE
-- but throw away the results. We'll type check
-- it again when we actually use it.
; pending_splices <- newMutVar []
- ; lie_var <- getLIEVar
+ ; lie_var <- getConstraintVar
; let brack_stage = Brack cur_stage pending_splices lie_var
; (meta_ty, lie) <- setStage brack_stage $
- getLIE $
+ captureConstraints $
tc_bracket cur_stage brack
- ; tcSimplifyBracket lie
+ ; simplifyBracket lie
-- Make the expected type have the right shape
- ; _ <- boxyUnify meta_ty res_ty
+ ; _ <- unifyType meta_ty res_ty
-- Return the original expression, not the type-decorated one
; pendings <- readMutVar pending_splices
tc_bracket _ (PatBr pat)
= do { any_ty <- newFlexiTyVarTy liftedTypeKind
- ; _ <- tcPat ThPatQuote pat any_ty unitTy $ \_ ->
+ ; _ <- tcPat ThPatQuote pat any_ty $
return ()
; tcMetaTy patQTyConName }
-- Result type is PatQ (= Q Pat)
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
- { _ <- unBox res_ty
- ; meta_exp_ty <- tcMetaTy expQTyConName
+ { meta_exp_ty <- tcMetaTy expQTyConName
; expr' <- setStage pop_stage $
- setLIEVar lie_var $
+ setConstraintVar lie_var $
tcMonoExpr expr meta_exp_ty
-- Write the pending splice into the bucket
; return (panic "tcSpliceExpr") -- The returned expression is ignored
}}}
-tcTopSplice :: LHsExpr Name -> BoxyRhoType -> TcM (HsExpr Id)
+tcTopSplice :: LHsExpr Name -> TcRhoType -> TcM (HsExpr Id)
-- Note [How top-level splices are handled]
tcTopSplice expr res_ty
= do { meta_exp_ty <- tcMetaTy expQTyConName
-- if the type checker fails!
setStage Splice $
do { -- Typecheck the expression
- (expr', lie) <- getLIE tc_action
+ (expr', lie) <- captureConstraints tc_action
-- Solve the constraints
- ; const_binds <- tcSimplifyTop lie
+ ; const_binds <- simplifyTop lie
-- Zonk it and tie the knot of dictionary bindings
- ; zonkTopLExpr (mkHsDictLet const_binds expr') }
+ ; zonkTopLExpr (mkHsDictLet (EvBinds const_binds) expr') }
\end{code}
-- A splice inside brackets
{ meta_ty <- tcMetaTy typeQTyConName
; expr' <- setStage pop_level $
- setLIEVar lie_var $
+ setConstraintVar lie_var $
tcMonoExpr hs_expr meta_ty
-- Write the pending splice into the bucket
-> MetaOps th_syn hs_syn
-> RnM hs_syn
runQuasiQuote (HsQuasiQuote quoter q_span quote) quote_selector meta_ty meta_ops
- = do { quoter' <- lookupOccRn quoter
+ = do { -- Drop the leading "$" from the quoter name, if present
+ -- This is old-style syntax, now deprecated
+ -- NB: when removing this backward-compat, remove
+ -- the matching code in Lexer.x (around line 310)
+ let occ_str = occNameString (rdrNameOcc quoter)
+ ; quoter <- ASSERT( not (null occ_str) ) -- Lexer ensures this
+ if head occ_str /= '$' then return quoter
+ else do { addWarn (deprecatedDollar quoter)
+ ; return (mkRdrUnqual (mkVarOcc (tail occ_str))) }
+
+ ; quoter' <- lookupOccRn quoter
-- We use lookupOcc rather than lookupGlobalOcc because in the
-- erroneous case of \x -> [x| ...|] we get a better error message
-- (stage restriction rather than out of scope).
; let is_local = nameIsLocalOrFrom this_mod quoter'
; checkTc (not is_local) (quoteStageError quoter')
- ; traceTc (text "runQQ" <+> ppr quoter <+> ppr is_local)
+ ; traceTc "runQQ" (ppr quoter <+> ppr is_local)
-- Build the expression
; let quoterExpr = L q_span $! HsVar $! quoter'
quoteStageError quoter
= sep [ptext (sLit "GHC stage restriction:") <+> ppr quoter,
nest 2 (ptext (sLit "is used in a quasiquote, and must be imported, not defined locally"))]
+
+deprecatedDollar :: RdrName -> SDoc
+deprecatedDollar quoter
+ = hang (ptext (sLit "Deprecated syntax:"))
+ 2 (ptext (sLit "quasiquotes no longer need a dollar sign:")
+ <+> ppr quoter)
\end{code}
where
run_and_cvt expr_span hval
= do { th_result <- TH.runQ hval
- ; traceTc (text "Got TH result:" <+> text (show_th th_result))
+ ; traceTc "Got TH result:" (text (show_th th_result))
; return (cvt expr_span th_result) }
runMetaE :: LHsExpr Id -- Of type (Q Exp)
-> LHsExpr Id -- Of type x; typically x = Q TH.Exp, or something like that
-> TcM hs_syn -- Of type t
runMeta show_code run_and_convert expr
- = do { traceTc (text "About to run" <+> ppr expr)
+ = do { traceTc "About to run" (ppr expr)
-- Desugar
; ds_expr <- initDsTc (dsLExpr expr)
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
; either_hval <- tryM $ liftIO $
- HscMain.compileExpr hsc_env src_span ds_expr
+ HscMain.hscCompileCoreExpr hsc_env src_span ds_expr
; case either_hval of {
Left exn -> failWithTc (mk_msg "compile and link" exn) ;
Right hval -> do
do { mb_result <- run_and_convert expr_span (unsafeCoerce# hval)
; case mb_result of
Left err -> failWithTc err
- Right result -> do { traceTc (ptext (sLit "Got HsSyn result:") <+> ppr result)
+ Right result -> do { traceTc "Got HsSyn result:" (ppr result)
; return $! result } }
; case either_tval of
, TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
qReify v = reify v
+ qClassInstances = lookupClassInstances
-- For qRecover, discard error messages if
-- the recovery action is chosen. Otherwise
%************************************************************************
%* *
+ Instance Testing
+%* *
+%************************************************************************
+
+\begin{code}
+lookupClassInstances :: TH.Name -> [TH.Type] -> TcM [TH.Name]
+lookupClassInstances c ts
+ = do { loc <- getSrcSpanM
+ ; case convertToHsPred loc (TH.ClassP c ts) of
+ Left msg -> failWithTc msg
+ Right rdr_pred -> do
+ { rn_pred <- rnLPred doc rdr_pred -- Rename
+ ; kc_pred <- kcHsLPred rn_pred -- Kind check
+ ; ClassP cls tys <- dsHsLPred kc_pred -- Type check
+
+ -- Now look up instances
+ ; inst_envs <- tcGetInstEnvs
+ ; let (matches, unifies) = lookupInstEnv inst_envs cls tys
+ dfuns = map is_dfun (map fst matches ++ unifies)
+ ; return (map reifyName dfuns) } }
+ where
+ doc = ptext (sLit "TcSplice.classInstances")
+\end{code}
+
+
+%************************************************************************
+%* *
Reification
%* *
%************************************************************************
(reifyName (dataConOrigTyCon dc)) fix)
}
-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
+reifyThing (ATcId {tct_id = id})
+ = do { ty1 <- zonkTcType (idType id) -- 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) }
= return (TH.PrimTyConI (reifyName tc) 2 False)
| isPrimTyCon tc
= return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
- | isOpenTyCon tc
+ | isFamilyTyCon tc
= let flavour = reifyFamFlavour tc
tvs = tyConTyVars tc
kind = tyConKind tc
reifyClass :: Class -> TcM TH.Info
reifyClass cls
= do { cxt <- reifyCxt theta
+ ; inst_envs <- tcGetInstEnvs
+ ; insts <- mapM reifyClassInstance (InstEnv.classInstances inst_envs cls)
; ops <- mapM reify_op op_stuff
- ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
+ ; let dec = TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops
+ ; return (TH.ClassI dec insts ) }
where
(tvs, fds, theta, _, _, op_stuff) = classExtraBigSig cls
fds' = map reifyFunDep fds
; return (TH.SigD (reifyName op) ty) }
------------------------------
+reifyClassInstance :: Instance -> TcM TH.ClassInstance
+reifyClassInstance i
+ = do { cxt <- reifyCxt theta
+ ; thtypes <- reifyTypes types
+ ; return $ (TH.ClassInstance {
+ TH.ci_tvs = reifyTyVars tvs,
+ TH.ci_cxt = cxt,
+ TH.ci_tys = thtypes,
+ TH.ci_cls = reifyName cls,
+ TH.ci_dfun = reifyName (is_dfun i) }) }
+ where
+ (tvs, theta, cls, types) = instanceHead i
+
+------------------------------
reifyType :: TypeRep.Type -> TcM TH.Type
+-- Monadic only because of failure
reifyType ty@(ForAllTy _ _) = reify_for_all ty
reifyType ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
reifyFamFlavour :: TyCon -> TH.FamFlavour
-reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
- | isOpenTyCon tc = TH.DataFam
+reifyFamFlavour tc | isSynFamilyTyCon tc = TH.TypeFam
+ | isFamilyTyCon tc = TH.DataFam
| otherwise
= panic "TcSplice.reifyFamFlavour: not a type family"
projects / ghc-hetmet.git / blobdiff