import TcHsType
import TcIface
import TypeRep
+import InstEnv
import Name
import NameEnv
import NameSet
import ErrUtils
import SrcLoc
import Outputable
+import Util ( dropList )
+import Data.List ( mapAccumL )
+import Pair
import Unique
import Data.Maybe
import BasicTypes
%************************************************************************
\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
-
- ; (meta_ty, lie) <- setStage (Brack cur_stage pending_splices lie_var)
- (getLIE (tc_bracket cur_stage brack))
- ; tcSimplifyBracket lie
-
- -- Make the expected type have the right shape
- ; _ <- boxyUnify meta_ty res_ty
-
- -- Return the original expression, not the type-decorated one
+ ; lie_var <- getConstraintVar
+ ; let brack_stage = Brack cur_stage pending_splices lie_var
+
+ -- We want to check that there aren't any constraints that
+ -- can't be satisfied (e.g. Show Foo, where Foo has no Show
+ -- instance), but we aren't otherwise interested in the
+ -- results. Nor do we care about ambiguous dictionaries etc.
+ -- We will type check this bracket again at its usage site.
+ --
+ -- We build a single implication constraint with a BracketSkol;
+ -- that in turn tells simplifyCheck to report only definite
+ -- errors
+ ; (_,lie) <- captureConstraints $
+ newImplication BracketSkol [] [] $
+ setStage brack_stage $
+ do { meta_ty <- tc_bracket cur_stage brack
+ ; unifyType meta_ty res_ty }
+
+ -- It's best to simplify the constraint now, even though in
+ -- principle some later unification might be useful for it,
+ -- because we don't want these essentially-junk TH implication
+ -- contraints floating around nested inside other constraints
+ -- See for example Trac #4949
+ ; _ <- simplifyTop lie
+
+ -- Return the original expression, not the type-decorated one
; pendings <- readMutVar pending_splices
; return (noLoc (HsBracketOut brack pendings)) }
}
tc_bracket _ (ExpBr expr)
- = do { any_ty <- newFlexiTyVarTy liftedTypeKind
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
; tcMetaTy expQTyConName }
-- Result type is ExpQ (= Q Exp)
= do { _ <- tcTopSrcDecls emptyModDetails decls
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
+
+ -- Top-level declarations in the bracket get unqualified names
+ -- See Note [Top-level Names in Template Haskell decl quotes] in RnNames
+
; tcMetaTy decsQTyConName } -- Result type is Q [Dec]
tc_bracket _ (PatBr pat)
- = do { any_ty <- newFlexiTyVarTy liftedTypeKind
- ; _ <- tcPat ThPatQuote pat any_ty unitTy $ \_ ->
+ = do { any_ty <- newFlexiTyVarTy openTypeKind
+ ; _ <- 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
qReport False msg = addReport (text msg) empty
qLocation = do { m <- getModule
- ; l <- getSrcSpanM
- ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile l)
- , TH.loc_module = moduleNameString (moduleName m)
- , TH.loc_package = packageIdString (modulePackageId m)
- , TH.loc_start = (srcSpanStartLine l, srcSpanStartCol l)
- , TH.loc_end = (srcSpanEndLine l, srcSpanEndCol l) }) }
-
+ ; l <- getSrcSpanM
+ ; r <- case l of
+ UnhelpfulSpan _ -> pprPanic "qLocation: Unhelpful location"
+ (ppr l)
+ RealSrcSpan s -> return s
+ ; return (TH.Loc { TH.loc_filename = unpackFS (srcSpanFile r)
+ , TH.loc_module = moduleNameString (moduleName m)
+ , TH.loc_package = packageIdString (modulePackageId m)
+ , TH.loc_start = (srcSpanStartLine r, srcSpanStartCol r)
+ , TH.loc_end = (srcSpanEndLine r, srcSpanEndCol r) }) }
+
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.ClassInstance]
+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
+ ; mapM reifyClassInstance (map fst matches ++ unifies) } } }
+ where
+ doc = ptext (sLit "TcSplice.classInstances")
+\end{code}
+
+
+%************************************************************************
+%* *
Reification
%* *
%************************************************************************
_ -> return (TH.VarI v ty Nothing fix)
}
-reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
-reifyThing (AGlobal (AClass cls)) = reifyClass cls
+reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc
+reifyThing (AGlobal (ACoAxiom ax)) = reifyAxiom ax
+reifyThing (AGlobal (AClass cls)) = reifyClass cls
reifyThing (AGlobal (ADataCon dc))
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
(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) }
reifyThing (AThing {}) = panic "reifyThing AThing"
------------------------------
+reifyAxiom :: CoAxiom -> TcM TH.Info
+reifyAxiom ax@(CoAxiom { co_ax_lhs = lhs, co_ax_rhs = rhs })
+ | Just (tc, args) <- tcSplitTyConApp_maybe lhs
+ = do { args' <- mapM reifyType args
+ ; rhs' <- reifyType rhs
+ ; return (TH.TyConI $ TH.TySynInstD (reifyName tc) args' rhs') }
+ | otherwise
+ = failWith (ptext (sLit "Can't reify the axiom") <+> ppr ax
+ <+> dcolon <+> pprEqPred (Pair lhs rhs))
+
reifyTyCon :: TyCon -> TcM TH.Info
reifyTyCon tc
| isFunTyCon tc
= 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
in
return (TH.TyConI $
TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
+
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
}
-reifyTyCon tc
+ | otherwise
= do { cxt <- reifyCxt (tyConStupidTheta tc)
; let tvs = tyConTyVars tc
; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
; return (TH.TyConI decl) }
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
+-- For GADTs etc, see Note [Reifying data constructors]
reifyDataCon tys dc
- | isVanillaDataCon dc
- = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
- ; let stricts = map reifyStrict (dataConStrictMarks dc)
- fields = dataConFieldLabels dc
- name = reifyName dc
- [a1,a2] = arg_tys
- [s1,s2] = stricts
- ; ASSERT( length arg_tys == length stricts )
- if not (null fields) then
- return (TH.RecC name (zip3 (map reifyName fields) stricts arg_tys))
- else
- if dataConIsInfix dc then
- ASSERT( length arg_tys == 2 )
- return (TH.InfixC (s1,a1) name (s2,a2))
- else
- return (TH.NormalC name (stricts `zip` arg_tys)) }
- | otherwise
- = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
- <+> quotes (ppr dc))
+ = do { let (tvs, theta, arg_tys, _) = dataConSig dc
+ subst = mkTopTvSubst (tvs `zip` tys) -- Dicard ex_tvs
+ (subst', ex_tvs') = mapAccumL substTyVarBndr subst (dropList tys tvs)
+ theta' = substTheta subst' theta
+ arg_tys' = substTys subst' arg_tys
+ stricts = map reifyStrict (dataConStrictMarks dc)
+ fields = dataConFieldLabels dc
+ name = reifyName dc
+
+ ; r_arg_tys <- reifyTypes arg_tys'
+
+ ; let main_con | not (null fields)
+ = TH.RecC name (zip3 (map reifyName fields) stricts r_arg_tys)
+ | dataConIsInfix dc
+ = ASSERT( length arg_tys == 2 )
+ TH.InfixC (s1,r_a1) name (s2,r_a2)
+ | otherwise
+ = TH.NormalC name (stricts `zip` r_arg_tys)
+ [r_a1, r_a2] = r_arg_tys
+ [s1, s2] = stricts
+
+ ; ASSERT( length arg_tys == length stricts )
+ if null ex_tvs' && null theta then
+ return main_con
+ else do
+ { cxt <- reifyCxt theta'
+ ; return (TH.ForallC (reifyTyVars ex_tvs') cxt main_con) } }
------------------------------
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 ty@(PredTy {} `FunTy` _) = reify_for_all ty -- Types like ((?x::Int) => Char -> Char)
reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv))
-reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -- Do not expand type synonyms here
+reifyType (TyConApp tc tys) = reify_tc_app tc tys -- Do not expand type synonyms here
reifyType (AppTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (r1 `TH.AppT` r2) }
reifyType (FunTy t1 t2) = do { [r1,r2] <- reifyTypes [t1,t2] ; return (TH.ArrowT `TH.AppT` r1 `TH.AppT` r2) }
reifyType ty@(PredTy {}) = pprPanic "reifyType PredTy" (ppr ty)
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"
kind = tyVarKind tv
name = reifyName tv
-reify_tc_app :: TH.Name -> [TypeRep.Type] -> TcM TH.Type
-reify_tc_app tc tys = do { tys' <- reifyTypes tys
- ; return (foldl TH.AppT (TH.ConT tc) tys') }
+reify_tc_app :: TyCon -> [TypeRep.Type] -> TcM TH.Type
+reify_tc_app tc tys
+ = do { tys' <- reifyTypes tys
+ ; return (foldl TH.AppT r_tc tys') }
+ where
+ n_tys = length tys
+ r_tc | isTupleTyCon tc = TH.TupleT n_tys
+ | tc `hasKey` listTyConKey = TH.ListT
+ | otherwise = TH.ConT (reifyName tc)
reifyPred :: TypeRep.PredType -> TcM TH.Pred
reifyPred (ClassP cls tys)
= do { tys' <- reifyTypes tys
- ; return $ TH.ClassP (reifyName cls) tys'
- }
+ ; return $ TH.ClassP (reifyName cls) tys' }
+
reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
reifyPred (EqPred ty1 ty2)
= do { ty1' <- reifyType ty1
conv_dir BasicTypes.InfixL = TH.InfixL
conv_dir BasicTypes.InfixN = TH.InfixN
-reifyStrict :: BasicTypes.StrictnessMark -> TH.Strict
-reifyStrict MarkedStrict = TH.IsStrict
-reifyStrict MarkedUnboxed = TH.IsStrict
-reifyStrict NotMarkedStrict = TH.NotStrict
+reifyStrict :: BasicTypes.HsBang -> TH.Strict
+reifyStrict bang | isBanged bang = TH.IsStrict
+ | otherwise = TH.NotStrict
------------------------------
noTH :: LitString -> SDoc -> TcM a
ptext (sLit "in Template Haskell:"),
nest 2 d])
\end{code}
+
+Note [Reifying data constructors]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Template Haskell syntax is rich enough to express even GADTs,
+provided we do so in the equality-predicate form. So a GADT
+like
+
+ data T a where
+ MkT1 :: a -> T [a]
+ MkT2 :: T Int
+
+will appear in TH syntax like this
+
+ data T a = forall b. (a ~ [b]) => MkT1 b
+ | (a ~ Int) => MkT2
+
projects / ghc-hetmet.git / blobdiff