X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSplice.lhs;h=34e03945fbe5a2c9c0acbaf9cbe27e230c1d8eb6;hb=380148608fa354ac972d45aa933400a1a5c4dd7f;hp=b7b3c298b4147408cfc06afecd5f3ed9569b7ac2;hpb=1f5e55804b97d2b9a77207d568d602ba88d8855d;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index b7b3c29..34e0394 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -13,51 +13,63 @@ import TcRnDriver ( tcTopSrcDecls ) -- These imports are the reason that TcSplice -- is very high up the module hierarchy -import qualified Language.Haskell.TH.THSyntax as TH +import qualified Language.Haskell.TH as TH -- THSyntax gives access to internal functions and data types - -import HscTypes ( HscEnv(..) ) -import HsSyn ( HsBracket(..), HsExpr(..) ) -import Convert ( convertToHsExpr, convertToHsDecls ) -import RnExpr ( rnExpr ) -import RnEnv ( lookupFixityRn ) -import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl ) -import RnHsSyn ( RenamedHsExpr ) +import qualified Language.Haskell.TH.Syntax as TH + +import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, + HsType, LHsType ) +import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) +import RnExpr ( rnLExpr ) +import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName ) +import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName ) +import RnTypes ( rnLHsType ) import TcExpr ( tcCheckRho, tcMonoExpr ) -import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) +import TcHsSyn ( mkHsDictLet, zonkTopLExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) -import TcType ( TcType, openTypeKind, mkAppTy, tcSplitSigmaTy ) -import TcEnv ( spliceOK, tcMetaTy, bracketOK, tcLookup ) -import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) -import TcHsType ( tcHsSigType ) +import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) +import TcEnv ( spliceOK, tcMetaTy, bracketOK ) +import TcMType ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType ) +import TcHsType ( tcHsSigType, kcHsType ) +import TcIface ( tcImportDecl ) import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification -import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName ) +import PrelNames ( thFAKE ) +import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, + nameIsLocalOrFrom ) +import NameEnv ( lookupNameEnv ) +import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails ) import OccName -import Var ( TyVar, idType ) -import Module ( moduleUserString, mkModuleName ) +import Var ( Id, TyVar, idType ) +import Module ( moduleString ) import TcRnMonad import IfaceEnv ( lookupOrig ) - -import Class ( Class, classBigSig ) -import TyCon ( TyCon, tyConTheta, tyConTyVars, getSynTyConDefn, isSynTyCon, isNewTyCon, tyConDataCons ) +import Class ( Class, classExtraBigSig ) +import TyCon ( TyCon, tyConTyVars, getSynTyConDefn, + isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon, + tyConArity, tyConStupidTheta, isUnLiftedTyCon ) import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, - dataConName, dataConFieldLabels, dataConWrapId ) + dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, + isVanillaDataCon ) import Id ( idName, globalIdDetails ) import IdInfo ( GlobalIdDetails(..) ) import TysWiredIn ( mkListTy ) import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName ) import ErrUtils ( Message ) +import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc ) import Outputable -import Unique ( Unique, Uniquable(..), getKey ) -import IOEnv ( IOEnv ) +import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) + import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) -import Module ( moduleUserString ) import Panic ( showException ) -import GHC.Base ( unsafeCoerce#, Int(..) ) -- Should have a better home in the module hierarchy -import Monad ( liftM ) import FastString ( LitString ) -import FastTypes ( iBox ) + +import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy +import Monad ( liftM ) + +#ifdef GHCI +import FastString ( mkFastString ) +#endif \end{code} @@ -68,12 +80,9 @@ import FastTypes ( iBox ) %************************************************************************ \begin{code} -tcSpliceDecls :: RenamedHsExpr -> TcM [RdrNameHsDecl] - -tcSpliceExpr :: Name - -> RenamedHsExpr - -> Expected TcType - -> TcM TcExpr +tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] +tcSpliceExpr :: HsSplice Name -> Expected TcType -> TcM (HsExpr TcId) +kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind) #ifndef GHCI tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e) @@ -88,7 +97,7 @@ tcSpliceDecls e = pprPanic "Cant do tcSpliceDecls without GHCi" (ppr e) %************************************************************************ \begin{code} -tcBracket :: HsBracket Name -> Expected TcType -> TcM TcExpr +tcBracket :: HsBracket Name -> Expected TcType -> TcM (LHsExpr Id) tcBracket brack res_ty = getStage `thenM` \ level -> case bracketOK level of { @@ -98,6 +107,7 @@ tcBracket brack res_ty -- 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 `thenM_` newMutVar [] `thenM` \ pending_splices -> getLIEVar `thenM` \ lie_var -> @@ -111,17 +121,16 @@ tcBracket brack res_ty -- Return the original expression, not the type-decorated one readMutVar pending_splices `thenM` \ pendings -> - returnM (HsBracketOut brack pendings) + returnM (noLoc (HsBracketOut brack pendings)) } tc_bracket :: HsBracket Name -> TcM TcType tc_bracket (VarBr v) - = tcMetaTy nameTyConName - -- Result type is Var (not Q-monadic) + = tcMetaTy nameTyConName -- Result type is Var (not Q-monadic) tc_bracket (ExpBr expr) - = newTyVarTy openTypeKind `thenM` \ any_ty -> - tcCheckRho expr any_ty `thenM_` + = newTyFlexiVarTy liftedTypeKind `thenM` \ any_ty -> + tcCheckRho expr any_ty `thenM_` tcMetaTy expQTyConName -- Result type is Expr (= Q Exp) @@ -131,14 +140,18 @@ tc_bracket (TypBr typ) -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) - = tcTopSrcDecls decls `thenM_` + = do { tcTopSrcDecls emptyModDetails decls -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in - tcMetaTy decTyConName `thenM` \ decl_ty -> - tcMetaTy qTyConName `thenM` \ q_ty -> - returnM (mkAppTy q_ty (mkListTy decl_ty)) + ; decl_ty <- tcMetaTy decTyConName + ; q_ty <- tcMetaTy qTyConName + ; return (mkAppTy q_ty (mkListTy decl_ty)) -- Result type is Q [Dec] + } + +tc_bracket (PatBr _) + = failWithTc (ptext SLIT("Tempate Haskell pattern brackets are not supported yet")) \end{code} @@ -149,14 +162,16 @@ tc_bracket (DecBr decls) %************************************************************************ \begin{code} -tcSpliceExpr name expr res_ty - = getStage `thenM` \ level -> +tcSpliceExpr (HsSplice name expr) res_ty + = setSrcSpan (getLoc expr) $ + getStage `thenM` \ level -> case spliceOK level of { Nothing -> failWithTc (illegalSplice level) ; Just next_level -> case level of { - Comp -> tcTopSplice expr res_ty ; + Comp -> do { e <- tcTopSplice expr res_ty + ; returnM (unLoc e) } ; Brack _ ps_var lie_var -> -- A splice inside brackets @@ -165,7 +180,7 @@ tcSpliceExpr name expr res_ty -- Here (h 4) :: Q Exp -- but $(h 4) :: forall a.a i.e. anything! - zapExpectedType res_ty `thenM_` + zapExpectedType res_ty liftedTypeKind `thenM_` tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> setStage (Splice next_level) ( setLIEVar lie_var $ @@ -186,6 +201,7 @@ tcSpliceExpr name expr res_ty -- The recursive call to tcMonoExpr will simply expand the -- inner escape before dealing with the outer one +tcTopSplice :: LHsExpr Name -> Expected TcType -> TcM (LHsExpr Id) tcTopSplice expr res_ty = tcMetaTy expQTyConName `thenM` \ meta_exp_ty -> @@ -194,69 +210,129 @@ tcTopSplice expr res_ty -- Run the expression traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` - runMetaE zonked_q_expr `thenM` \ simple_expr -> + runMetaE convertToHsExpr zonked_q_expr `thenM` \ expr2 -> - let - -- simple_expr :: TH.Exp - - expr2 :: RdrNameHsExpr - expr2 = convertToHsExpr simple_expr - in traceTc (text "Got result" <+> ppr expr2) `thenM_` showSplice "expression" zonked_q_expr (ppr expr2) `thenM_` - rnExpr expr2 `thenM` \ (exp3, fvs) -> + + -- Rename it, but bale out if there are errors + -- otherwise the type checker just gives more spurious errors + checkNoErrs (rnLExpr expr2) `thenM` \ (exp3, fvs) -> tcMonoExpr exp3 res_ty -tcTopSpliceExpr :: RenamedHsExpr -> TcType -> TcM TypecheckedHsExpr +tcTopSpliceExpr :: LHsExpr Name -> TcType -> TcM (LHsExpr Id) -- Type check an expression that is the body of a top-level splice -- (the caller will compile and run it) tcTopSpliceExpr expr meta_ty = checkNoErrs $ -- checkNoErrs: must not try to run the thing -- if the type checker fails! - setStage topSpliceStage $ + setStage topSpliceStage $ do - -- Typecheck the expression - getLIE (tcCheckRho expr meta_ty) `thenM` \ (expr', lie) -> + + do { recordThUse -- Record that TH is used (for pkg depdendency) + -- Typecheck the expression + ; (expr', lie) <- getLIE (tcCheckRho expr meta_ty) + -- Solve the constraints - tcSimplifyTop lie `thenM` \ const_binds -> + ; const_binds <- tcSimplifyTop lie -- And zonk it - zonkTopExpr (mkHsLet const_binds expr') + ; zonkTopLExpr (mkHsDictLet const_binds expr') } \end{code} %************************************************************************ %* * + Splicing a type +%* * +%************************************************************************ + +Very like splicing an expression, but we don't yet share code. + +\begin{code} +kcSpliceType (HsSplice name hs_expr) + = setSrcSpan (getLoc hs_expr) $ do + { level <- getStage + ; case spliceOK level of { + Nothing -> failWithTc (illegalSplice level) ; + Just next_level -> do + + { case level of { + Comp -> do { (t,k) <- kcTopSpliceType hs_expr + ; return (unLoc t, k) } ; + Brack _ ps_var lie_var -> do + + { -- A splice inside brackets + ; meta_ty <- tcMetaTy typeQTyConName + ; expr' <- setStage (Splice next_level) $ + setLIEVar lie_var $ + tcCheckRho hs_expr meta_ty + + -- Write the pending splice into the bucket + ; ps <- readMutVar ps_var + ; writeMutVar ps_var ((name,expr') : ps) + + -- e.g. [| Int -> $(h 4) |] + -- Here (h 4) :: Q Type + -- but $(h 4) :: forall a.a i.e. any kind + ; kind <- newKindVar + ; returnM (panic "kcSpliceType", kind) -- The returned type is ignored + }}}}} + +kcTopSpliceType :: LHsExpr Name -> TcM (LHsType Name, TcKind) +kcTopSpliceType expr + = do { meta_ty <- tcMetaTy typeQTyConName + + -- Typecheck the expression + ; zonked_q_expr <- tcTopSpliceExpr expr meta_ty + + -- Run the expression + ; traceTc (text "About to run" <+> ppr zonked_q_expr) + ; hs_ty2 <- runMetaT convertToHsType zonked_q_expr + + ; traceTc (text "Got result" <+> ppr hs_ty2) + + ; showSplice "type" zonked_q_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 } +\end{code} + +%************************************************************************ +%* * \subsection{Splicing an expression} %* * %************************************************************************ \begin{code} -- Always at top level +-- Type sig at top of file: +-- tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName] tcSpliceDecls expr - = tcMetaTy decTyConName `thenM` \ meta_dec_ty -> - tcMetaTy qTyConName `thenM` \ meta_q_ty -> - let - list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty) - in - tcTopSpliceExpr expr list_q `thenM` \ zonked_q_expr -> + = do { meta_dec_ty <- tcMetaTy decTyConName + ; meta_q_ty <- tcMetaTy qTyConName + ; let list_q = mkAppTy meta_q_ty (mkListTy meta_dec_ty) + ; zonked_q_expr <- tcTopSpliceExpr expr list_q - -- Run the expression - traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` - runMetaD zonked_q_expr `thenM` \ simple_expr -> - -- simple_expr :: [TH.Dec] - -- decls :: [RdrNameHsDecl] - handleErrors (convertToHsDecls simple_expr) `thenM` \ decls -> - traceTc (text "Got result" <+> vcat (map ppr decls)) `thenM_` - showSplice "declarations" - zonked_q_expr (vcat (map ppr decls)) `thenM_` - returnM decls + -- Run the expression + ; traceTc (text "About to run" <+> ppr zonked_q_expr) + ; decls <- runMetaD convertToHsDecls zonked_q_expr + + ; traceTc (text "Got result" <+> vcat (map ppr decls)) + ; showSplice "declarations" + zonked_q_expr + (ppr (getLoc expr) $$ (vcat (map ppr decls))) + ; returnM decls } where handleErrors :: [Either a Message] -> TcM [a] handleErrors [] = return [] @@ -273,52 +349,77 @@ tcSpliceDecls expr %************************************************************************ \begin{code} -runMetaE :: TypecheckedHsExpr -- Of type (Q Exp) - -> TcM TH.Exp -- Of type Exp -runMetaE e = runMeta e - -runMetaD :: TypecheckedHsExpr -- Of type Q [Dec] - -> TcM [TH.Dec] -- Of type [Dec] -runMetaD e = runMeta e - -runMeta :: TypecheckedHsExpr -- Of type X - -> TcM t -- Of type t -runMeta expr +runMetaE :: (SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)) + -> LHsExpr Id -- Of type (Q Exp) + -> TcM (LHsExpr RdrName) +runMetaE = runMeta + +runMetaT :: (SrcSpan -> TH.Type -> Either Message (LHsType RdrName)) + -> LHsExpr Id -- Of type (Q Type) + -> TcM (LHsType RdrName) +runMetaT = runMeta + +runMetaD :: (SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]) + -> LHsExpr Id -- Of type Q [Dec] + -> TcM [LHsDecl RdrName] +runMetaD = runMeta + +runMeta :: (SrcSpan -> th_syn -> Either Message hs_syn) + -> 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 - -- Wrap the compile-and-run in an exception-catcher - -- Compiling might fail if linking fails - -- Running might fail if it throws an exception - ; either_tval <- tryM $ do - { -- Compile it - hval <- ioToTcRn (HscMain.compileExpr + + -- Compile and link it; might fail if linking fails + ; either_hval <- tryM $ ioToTcRn $ + HscMain.compileExpr hsc_env this_mod - rdr_env type_env expr) - -- Coerce it to Q t, and run it - ; TH.runQ (unsafeCoerce# hval) } + rdr_env type_env expr + ; case either_hval of { + Left exn -> failWithTc (mk_msg "compile and link" exn) ; + Right hval -> do + + { -- Coerce it to Q t, and run it + -- Running might fail if it throws an exception of any kind (hence tryAllM) + -- including, say, a pattern-match exception in the code we are running + -- + -- We also do the TH -> HS syntax conversion inside the same + -- exception-cacthing thing so that if there are any lurking + -- exceptions in the data structure returned by hval, we'll + -- encounter them inside the tryALlM + either_tval <- tryAllM $ do + { th_syn <- TH.runQ (unsafeCoerce# hval) + ; case convert (getLoc expr) th_syn of + Left err -> do { addErrTc err; return Nothing } + Right hs_syn -> return (Just hs_syn) } ; case either_tval of - Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:", - nest 4 (vcat [text "Code:" <+> ppr expr, - text ("Exn: " ++ Panic.showException exn)])]) - Right v -> returnM v } + Right (Just v) -> return v + Right Nothing -> failM -- Error already in Tc monad + Left exn -> failWithTc (mk_msg "run" exn) -- Exception + }}} + where + mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:", + nest 2 (text (Panic.showException exn)), + nest 2 (text "Code:" <+> ppr expr)] \end{code} To call runQ in the Tc monad, we need to make TcM an instance of Quasi: \begin{code} instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where - qNewName s = do { u <- newUnique + qNewName s = do { u <- newUnique ; let i = getKey u ; return (TH.mkNameU s i) } qReport True msg = addErr (text msg) qReport False msg = addReport (text msg) - qCurrentModule = do { m <- getModule; return (moduleUserString m) } + qCurrentModule = do { m <- getModule; return (moduleString m) } qReify v = reify v qRecover = recoverM @@ -333,9 +434,9 @@ instance TH.Quasi (IOEnv (Env TcGblEnv TcLclEnv)) where %************************************************************************ \begin{code} -showSplice :: String -> TypecheckedHsExpr -> SDoc -> TcM () +showSplice :: String -> LHsExpr Id -> SDoc -> TcM () showSplice what before after - = getSrcLocM `thenM` \ loc -> + = getSrcSpanM `thenM` \ loc -> traceSplice (vcat [ppr loc <> colon <+> text "Splicing" <+> text what, nest 2 (sep [nest 2 (ppr before), text "======>", @@ -360,17 +461,76 @@ illegalSplice level \begin{code} reify :: TH.Name -> TcM TH.Info -reify (TH.Name occ (TH.NameG th_ns mod)) - = do { name <- lookupOrig (mkModuleName (TH.modString mod)) - (OccName.mkOccName ghc_ns (TH.occString occ)) - ; thing <- tcLookup name +reify th_name + = do { name <- lookupThName th_name + ; thing <- tcLookupTh name + -- ToDo: this tcLookup could fail, which would give a + -- rather unhelpful error message + ; traceIf (text "reify" <+> text (show th_name) <+> brackets (ppr_ns th_name) <+> ppr name) ; reifyThing thing } where - ghc_ns = case th_ns of - TH.DataName -> dataName - TH.TcClsName -> tcClsName - TH.VarName -> varName + 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" + +lookupThName :: TH.Name -> TcM Name +lookupThName th_name@(TH.Name occ flavour) + = do { let rdr_name = thRdrName guessed_ns occ_str flavour + + -- Repeat much of lookupOccRn, becase we want + -- to report errors in a TH-relevant way + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return name + Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig + -> lookupImportedName rdr_name + | otherwise -- Unqual, Qual + -> do { + mb_name <- lookupSrcOcc_maybe rdr_name + ; case mb_name of + Just name -> return name + Nothing -> failWithTc (notInScope th_name) } + } + where + -- guessed_ns is the name space guessed from looking at the TH name + guessed_ns | isLexCon (mkFastString occ_str) = OccName.dataName + | otherwise = OccName.varName + occ_str = TH.occString occ + +tcLookupTh :: Name -> TcM TcTyThing +-- This is a specialised version of TcEnv.tcLookup; specialised mainly in that +-- it gives a reify-related error message on failure, whereas in the normal +-- tcLookup, failure is a bug. +tcLookupTh name + = do { (gbl_env, lcl_env) <- getEnvs + ; case lookupNameEnv (tcl_env lcl_env) name of { + Just thing -> returnM thing; + Nothing -> do + { if nameIsLocalOrFrom (tcg_mod gbl_env) name + then -- It's defined in this module + case lookupNameEnv (tcg_type_env gbl_env) name of + Just thing -> return (AGlobal thing) + Nothing -> failWithTc (notInEnv name) + + else do -- It's imported + { (eps,hpt) <- getEpsAndHpt + ; case lookupType hpt (eps_PTE eps) name of + Just thing -> return (AGlobal thing) + Nothing -> do { thing <- tcImportDecl name + ; return (AGlobal thing) } + -- Imported names should always be findable; + -- if not, we fail hard in tcImportDecl + }}}} + +notInScope :: TH.Name -> SDoc +notInScope th_name = quotes (text (TH.pprint th_name)) <+> + ptext SLIT("is not in scope at a reify") + -- Ugh! Rather an indirect way to display the name + +notInEnv :: Name -> SDoc +notInEnv name = quotes (ppr name) <+> + ptext SLIT("is not in the type environment at a reify") ------------------------------ reifyThing :: TcTyThing -> TcM TH.Info @@ -387,65 +547,77 @@ reifyThing (AGlobal (AnId id)) other -> return (TH.VarI v ty Nothing fix) } -reifyThing (AGlobal (ATyCon tc)) = do { dec <- reifyTyCon tc; return (TH.TyConI dec) } -reifyThing (AGlobal (AClass cls)) = do { dec <- reifyClass cls; return (TH.ClassI dec) } +reifyThing (AGlobal (ATyCon tc)) = reifyTyCon tc +reifyThing (AGlobal (AClass cls)) = reifyClass cls 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) } -reifyThing (ATcId id _ _) +reifyThing (ATcId 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 (ATyVar tv) - = do { ty1 <- zonkTcTyVar tv +reifyThing (ATyVar tv ty) + = do { ty1 <- zonkTcType ty ; ty2 <- reifyType ty1 ; return (TH.TyVarI (reifyName tv) ty2) } ------------------------------ -reifyTyCon :: TyCon -> TcM TH.Dec +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)) | isSynTyCon tc = do { let (tvs, rhs) = getSynTyConDefn tc ; rhs' <- reifyType rhs - ; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } + ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } - | isNewTyCon tc - = do { cxt <- reifyCxt (tyConTheta tc) - ; con <- reifyDataCon (head (tyConDataCons tc)) - ; return (TH.NewtypeD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) - con [{- Don't know about deriving -}]) } - - | otherwise -- Algebraic - = do { cxt <- reifyCxt (tyConTheta tc) +reifyTyCon tc + = do { cxt <- reifyCxt (tyConStupidTheta tc) ; cons <- mapM reifyDataCon (tyConDataCons tc) - ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) - cons [{- Don't know about deriving -}]) } + ; let name = reifyName tc + tvs = reifyTyVars (tyConTyVars tc) + deriv = [] -- Don't know about deriving + decl | isNewTyCon tc = TH.NewtypeD cxt name tvs (head cons) deriv + | otherwise = TH.DataD cxt name tvs cons deriv + ; return (TH.TyConI decl) } reifyDataCon :: DataCon -> TcM TH.Con reifyDataCon dc + | isVanillaDataCon dc = do { arg_tys <- reifyTypes (dataConOrigArgTys dc) ; let stricts = map reifyStrict (dataConStrictMarks dc) fields = dataConFieldLabels dc - ; if null fields then - return (TH.NormalC (reifyName dc) (stricts `zip` arg_tys)) + 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.RecC (reifyName dc) (zip3 (map reifyName fields) stricts arg_tys)) } - -- NB: we don't remember whether the constructor was declared in an infix way + return (TH.NormalC name (stricts `zip` arg_tys)) } + | otherwise + = failWithTc (ptext SLIT("Can't reify a non-Haskell-98 data constructor:") + <+> quotes (ppr dc)) ------------------------------ -reifyClass :: Class -> TcM TH.Dec +reifyClass :: Class -> TcM TH.Info reifyClass cls = do { cxt <- reifyCxt theta ; ops <- mapM reify_op op_stuff - ; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) ops) } + ; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } where - (tvs, theta, _, op_stuff) = classBigSig 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) } @@ -453,7 +625,6 @@ reifyClass cls reifyType :: TypeRep.Type -> TcM TH.Type reifyType (TyVarTy tv) = return (TH.VarT (reifyName tv)) reifyType (TyConApp tc tys) = reify_tc_app (reifyName tc) tys -reifyType (NewTcApp tc tys) = reify_tc_app (reifyName tc) tys reifyType (NoteTy _ ty) = reifyType ty 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) } @@ -465,6 +636,9 @@ reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; reifyTypes = mapM reifyType 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 @@ -482,10 +656,14 @@ reifyName :: NamedThing n => n -> TH.Name reifyName thing | isExternalName name = mk_varg mod 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 + -- we use NameU. When/if we start to reify nested things, that + -- have free variables, we may need to generate NameL's for them. where name = getName thing - mod = moduleUserString (nameModule name) - occ_str = occNameUserString occ + mod = moduleString (nameModule name) + occ_str = occNameString occ occ = nameOccName name mk_varg | OccName.isDataOcc occ = TH.mkNameG_d | OccName.isVarOcc occ = TH.mkNameG_v @@ -513,4 +691,4 @@ noTH :: LitString -> SDoc -> TcM a noTH s d = failWithTc (hsep [ptext SLIT("Can't represent") <+> ptext s <+> ptext SLIT("in Template Haskell:"), nest 2 d]) -\end{code} \ No newline at end of file +\end{code}