-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
-- for details
-module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket,
+module TcSplice( kcSpliceType, tcSpliceExpr, tcSpliceDecls, tcBracket,
lookupThName_maybe,
+todoSession, todoTcM,
runQuasiQuoteExpr, runQuasiQuotePat, runAnnotation ) where
#include "HsVersions.h"
import SrcLoc
import Outputable
import Unique
-import Maybe
+import Data.Maybe
import BasicTypes
import Panic
import FastString
import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
import System.IO.Error
+
+
+--here for every bad reason :-)
+import InstEnv
+import FamInstEnv
+--Session
+todoSession :: HscEnv -> Name -> IO (Messages, Maybe (LHsDecl RdrName))
+todoSession hsc_env name
+ = initTcPrintErrors hsc_env iNTERACTIVE $
+ setInteractiveContext hsc_env (hsc_IC hsc_env) $
+ todoTcM name
+
+
+todoTcM :: Name -> TcM (LHsDecl RdrName)
+todoTcM name = do
+ tcTyThing <- TcEnv.tcLookup name
+ thInfo <- TcSplice.reifyThing tcTyThing
+ let Just thDec = thGetDecFromInfo thInfo --BUG!
+ let Right [hsdecl] = Convert.convertToHsDecls
+ (error "srcspan of different package?")
+ [thDec]
+ return hsdecl
+
+thGetDecFromInfo :: TH.Info -> Maybe TH.Dec
+thGetDecFromInfo (TH.ClassI dec) = Just dec
+thGetDecFromInfo (TH.ClassOpI {}) = error "classop"
+thGetDecFromInfo (TH.TyConI dec) = Just dec
+thGetDecFromInfo (TH.PrimTyConI {}) = Nothing --error "sometimes we can invent a signature? or it's better not to?"
+thGetDecFromInfo (TH.DataConI {}) = error "datacon"
+thGetDecFromInfo (TH.VarI _name _type (Just dec) _fixity) = Just dec
+thGetDecFromInfo (TH.VarI _name _type Nothing _fixity) = error "vari"
+thGetDecFromInfo (TH.TyVarI {}) = Nothing --tyvars don't have decls? they kinda have a type though...
+
+setInteractiveContext :: HscEnv -> InteractiveContext -> TcRn a -> TcRn a
+setInteractiveContext hsc_env icxt thing_inside
+ = let -- Initialise the tcg_inst_env with instances from all home modules.
+ -- This mimics the more selective call to hptInstances in tcRnModule.
+ (home_insts, home_fam_insts) = hptInstances hsc_env (\mod -> True)
+ in
+ updGblEnv (\env -> env {
+ tcg_rdr_env = ic_rn_gbl_env icxt,
+ tcg_inst_env = extendInstEnvList (tcg_inst_env env) home_insts,
+ tcg_fam_inst_env = extendFamInstEnvList (tcg_fam_inst_env env)
+ home_fam_insts
+ }) $
+
+ tcExtendGhciEnv (ic_tmp_ids icxt) $
+ -- tcExtendGhciEnv does lots:
+ -- - it extends the local type env (tcl_env) with the given Ids,
+ -- - it extends the local rdr env (tcl_rdr) with the Names from
+ -- the given Ids
+ -- - it adds the free tyvars of the Ids to the tcl_tyvars
+ -- set.
+ --
+ -- later ids in ic_tmp_ids must shadow earlier ones with the same
+ -- OccName, and tcExtendIdEnv implements this behaviour.
+
+ do { traceTc (text "setIC" <+> ppr (ic_tmp_ids icxt))
+ ; thing_inside }
\end{code}
Note [Template Haskell levels]
; return (ConE "Data.Maybe.Just" s7) }
\begin{code}
-tcBracket brack res_ty = do
- level <- getStage
- case bracketOK level of {
- Nothing -> failWithTc (illegalBracket level) ;
- Just next_level -> do
+tcBracket brack res_ty
+ = addErrCtxt (hang (ptext (sLit "In the Template Haskell quotation"))
+ 2 (ppr brack)) $
+ do { level <- getStage
+ ; case bracketOK level of {
+ Nothing -> failWithTc (illegalBracket level) ;
+ Just next_level -> do {
-- Typecheck expr to make sure it is valid,
-- but throw away the results. We'll type check
-- it again when we actually use it.
- recordThUse
- pending_splices <- newMutVar []
- lie_var <- getLIEVar
+ recordThUse
+ ; pending_splices <- newMutVar []
+ ; lie_var <- getLIEVar
- (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
- (getLIE (tc_bracket next_level brack))
- tcSimplifyBracket lie
+ ; (meta_ty, lie) <- setStage (Brack next_level pending_splices lie_var)
+ (getLIE (tc_bracket next_level brack))
+ ; tcSimplifyBracket lie
-- Make the expected type have the right shape
- boxyUnify meta_ty res_ty
+ ; _ <- boxyUnify meta_ty res_ty
-- Return the original expression, not the type-decorated one
- pendings <- readMutVar pending_splices
- return (noLoc (HsBracketOut brack pendings))
- }
+ ; pendings <- readMutVar pending_splices
+ ; return (noLoc (HsBracketOut brack pendings)) }}}
tc_bracket :: ThLevel -> HsBracket Name -> TcM TcType
tc_bracket use_lvl (VarBr name) -- Note [Quoting names]
tc_bracket _ (ExpBr expr)
= do { any_ty <- newFlexiTyVarTy liftedTypeKind
- ; tcMonoExpr expr any_ty
+ ; _ <- tcMonoExprNC expr any_ty -- NC for no context; tcBracket does that
; tcMetaTy expQTyConName }
-- Result type is Expr (= Q Exp)
tc_bracket _ (TypBr typ)
- = do { tcHsSigType ExprSigCtxt typ
+ = do { _ <- tcHsSigTypeNC ThBrackCtxt typ
; tcMetaTy typeQTyConName }
-- Result type is Type (= Q Typ)
tc_bracket _ (DecBr decls)
- = do { tcTopSrcDecls emptyModDetails decls
+ = do { _ <- tcTopSrcDecls emptyModDetails decls
-- Typecheck the declarations, dicarding the result
-- We'll get all that stuff later, when we splice it in
-- Here (h 4) :: Q Exp
-- but $(h 4) :: forall a.a i.e. anything!
- unBox res_ty
+ _ <- unBox res_ty
meta_exp_ty <- tcMetaTy expQTyConName
expr' <- setStage (Splice next_level) (
setLIEVar lie_var $
traceTc (text "Got result" <+> ppr expr2)
- showSplice "expression"
- zonked_q_expr (ppr expr2)
+ showSplice "expression" expr (ppr expr2)
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
; traceTc (text "About to run" <+> ppr zonked_q_expr)
; result <- runMetaQ convert zonked_q_expr
; traceTc (text "Got result" <+> ppr result)
- ; showSplice desc zonked_q_expr (ppr result)
+ ; showSplice desc quoteExpr (ppr result)
; return result
}
; traceTc (text "Got result" <+> ppr hs_ty2)
- ; showSplice "type" zonked_q_expr (ppr hs_ty2)
+ ; showSplice "type" expr (ppr hs_ty2)
-- Rename it, but bale out if there are errors
-- otherwise the type checker just gives more spurious errors
; let doc = ptext (sLit "In the spliced type") <+> ppr hs_ty2
; hs_ty3 <- checkNoErrs (rnLHsType doc hs_ty2)
- ; kcHsType hs_ty3 }
+ ; kcLHsType hs_ty3 }
\end{code}
%************************************************************************
; traceTc (text "Got result" <+> vcat (map ppr decls))
; showSplice "declarations"
- zonked_q_expr
+ expr
(ppr (getLoc expr) $$ (vcat (map ppr decls)))
; return decls }
\end{code}
%************************************************************************
\begin{code}
-showSplice :: String -> LHsExpr Id -> SDoc -> TcM ()
-showSplice what before after = do
- loc <- getSrcSpanM
- traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
- nest 2 (sep [nest 2 (ppr before),
- text "======>",
- nest 2 after])])
+showSplice :: String -> LHsExpr Name -> SDoc -> TcM ()
+-- Note that 'before' is *renamed* but not *typechecked*
+-- Reason (a) less typechecking crap
+-- (b) data constructors after type checking have been
+-- changed to their *wrappers*, and that makes them
+-- print always fully qualified
+showSplice what before after
+ = do { loc <- getSrcSpanM
+ ; traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what,
+ nest 2 (sep [nest 2 (ppr before),
+ text "======>",
+ nest 2 after])]) }
illegalBracket :: ThStage -> SDoc
illegalBracket level
= do { ty <- reifyType (idType id)
; fix <- reifyFixity (idName id)
; let v = reifyName id
- ; case globalIdDetails id of
+ ; case idDetails id of
ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix)
_ -> return (TH.VarI v ty Nothing fix)
}
= do { let name = dataConName dc
; ty <- reifyType (idType (dataConWrapId dc))
; fix <- reifyFixity name
- ; return (TH.DataConI (reifyName name) ty (reifyName (dataConTyCon dc)) fix) }
+ ; return (TH.DataConI (reifyName name) ty
+ (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
------------------------------
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))
+ | isFunTyCon tc
+ = return (TH.PrimTyConI (reifyName tc) 2 False)
+ | isPrimTyCon tc
+ = return (TH.PrimTyConI (reifyName tc) (tyConArity tc) (isUnLiftedTyCon tc))
+ | isOpenTyCon tc
+ = let flavour = reifyFamFlavour tc
+ tvs = tyConTyVars tc
+ kind = tyConKind tc
+ kind'
+ | isLiftedTypeKind kind = Nothing
+ | otherwise = Just $ reifyKind kind
+ in
+ return (TH.TyConI $
+ TH.FamilyD flavour (reifyName tc) (reifyTyVars tvs) kind')
| isSynTyCon tc
= do { let (tvs, rhs) = synTyConDefn tc
; rhs' <- reifyType rhs
; return (TH.TyConI $
- TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs')
+ }
reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
r_tvs = reifyTyVars tvs
deriv = [] -- Don't know about deriving
decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
- | otherwise = TH.DataD cxt name r_tvs cons deriv
+ | otherwise = TH.DataD cxt name r_tvs cons deriv
; return (TH.TyConI decl) }
reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
else
return (TH.NormalC name (stricts `zip` arg_tys)) }
| otherwise
- = failWithTc (ptext (sLit "Can't reify a non-Haskell-98 data constructor:")
+ = failWithTc (ptext (sLit "Can't reify a GADT data constructor:")
<+> quotes (ppr dc))
------------------------------
reifyTypes :: [Type] -> TcM [TH.Type]
reifyTypes = mapM reifyType
-reifyCxt :: [PredType] -> TcM [TH.Type]
+
+reifyKind :: Kind -> TH.Kind
+reifyKind ki
+ = let (kis, ki') = splitKindFunTys ki
+ kis_rep = map reifyKind kis
+ ki'_rep = reifyNonArrowKind ki'
+ in
+ foldl TH.ArrowK ki'_rep kis_rep
+ where
+ reifyNonArrowKind k | isLiftedTypeKind k = TH.StarK
+ | otherwise = pprPanic "Exotic form of kind"
+ (ppr k)
+
+reifyCxt :: [PredType] -> TcM [TH.Pred]
reifyCxt = mapM reifyPred
reifyFunDep :: ([TyVar], [TyVar]) -> TH.FunDep
reifyFunDep (xs, ys) = TH.FunDep (map reifyName xs) (map reifyName ys)
-reifyTyVars :: [TyVar] -> [TH.Name]
-reifyTyVars = map reifyName
+reifyFamFlavour :: TyCon -> TH.FamFlavour
+reifyFamFlavour tc | isOpenSynTyCon tc = TH.TypeFam
+ | isOpenTyCon tc = TH.DataFam
+ | otherwise
+ = panic "TcSplice.reifyFamFlavour: not a type family"
+
+reifyTyVars :: [TyVar] -> [TH.TyVarBndr]
+reifyTyVars = map reifyTyVar
+ where
+ reifyTyVar tv | isLiftedTypeKind kind = TH.PlainTV name
+ | otherwise = TH.KindedTV name (reifyKind kind)
+ where
+ 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') }
-reifyPred :: TypeRep.PredType -> TcM TH.Type
-reifyPred (ClassP cls tys) = reify_tc_app (reifyName cls) tys
+reifyPred :: TypeRep.PredType -> TcM TH.Pred
+reifyPred (ClassP cls tys)
+ = do { tys' <- reifyTypes tys
+ ; return $ TH.ClassP (reifyName cls) tys'
+ }
reifyPred p@(IParam _ _) = noTH (sLit "implicit parameters") (ppr p)
-reifyPred (EqPred {}) = panic "reifyPred EqPred"
+reifyPred (EqPred ty1 ty2)
+ = do { ty1' <- reifyType ty1
+ ; ty2' <- reifyType ty2
+ ; return $ TH.EqualP ty1' ty2'
+ }
------------------------------