X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=6146dfcacbe49f2368b9d53ecace7a42d3ffe1e3;hb=95408c6b0ed3f44e37f716ca172ed6ad21cb8678;hp=49f1bf8b2080289c8679669c5ca44e78673f22c5;hpb=4abece290a5790cae1b1d994477af8166ca23e7a;p=ghc-hetmet.git diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs index 49f1bf8..6146dfc 100644 --- a/compiler/typecheck/TcSplice.lhs +++ b/compiler/typecheck/TcSplice.lhs @@ -13,8 +13,9 @@ TcSplice: Template Haskell splices -- 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" @@ -64,7 +65,7 @@ import ErrUtils import SrcLoc import Outputable import Unique -import Maybe +import Data.Maybe import BasicTypes import Panic import FastString @@ -81,6 +82,65 @@ import GHC.Desugar ( AnnotationWrapper(..) ) 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] @@ -213,30 +273,31 @@ Desugared: f = do { s7 <- g Int 3 ; 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] @@ -256,17 +317,17 @@ 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 @@ -311,7 +372,7 @@ tcSpliceExpr (HsSplice name expr) res_ty -- 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 $ @@ -347,8 +408,7 @@ tcTopSplice expr res_ty = do 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 @@ -381,7 +441,6 @@ runAnnotation target expr = do expr_ty <- newFlexiTyVarTy liftedTypeKind -- Find the classes we want instances for in order to call toAnnotationWrapper - _typeable_class <- tcLookupClass typeableClassName data_class <- tcLookupClass dataClassName -- Check the instances we require live in another module (we want to execute it..) @@ -489,7 +548,7 @@ runQuasiQuote (HsQuasiQuote _name quoter q_span quote) quote_selector desc meta_ ; 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 } @@ -559,14 +618,14 @@ kcTopSpliceType expr ; 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} %************************************************************************ @@ -591,7 +650,7 @@ tcSpliceDecls expr ; 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} @@ -764,13 +823,18 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where %************************************************************************ \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 @@ -826,11 +890,7 @@ lookupThName_maybe th_name ; rdr_env <- getLocalRdrEnv ; case lookupLocalRdrEnv rdr_env rdr_name of Just name -> return (Just name) - Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig - -> do { name <- lookupImportedName rdr_name - ; return (Just name) } - | otherwise -- Unqual, Qual - -> lookupSrcOcc_maybe rdr_name } + Nothing -> lookupGlobalOccRn_maybe rdr_name } tcLookupTh :: Name -> TcM TcTyThing -- This is a specialised version of TcEnv.tcLookup; specialised mainly in that @@ -877,7 +937,7 @@ reifyThing (AGlobal (AnId id)) = 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) } @@ -888,7 +948,9 @@ reifyThing (AGlobal (ADataCon dc)) = 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 @@ -907,13 +969,26 @@ reifyThing (AThing {}) = panic "reifyThing AThing" ------------------------------ 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) @@ -923,7 +998,7 @@ reifyTyCon 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 @@ -945,7 +1020,7 @@ reifyDataCon tys dc 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)) ------------------------------ @@ -975,23 +1050,55 @@ reifyType (PredTy {}) = panic "reifyType PredTy" 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' + } ------------------------------