X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Ftypecheck%2FTcSplice.lhs;h=31dfd3141aceab76bf17d4fea054de3cc8bc9aa3;hb=ff845ab59d1d465d874d3908fd0cdd61b8594da2;hp=7dda60c6c24b7fd1d3e6737849a31c55bff789cd;hpb=f0ec96ba1003654ee277a0ca78ceaedec687b5df;p=ghc-hetmet.git diff --git a/ghc/compiler/typecheck/TcSplice.lhs b/ghc/compiler/typecheck/TcSplice.lhs index 7dda60c..31dfd31 100644 --- a/ghc/compiler/typecheck/TcSplice.lhs +++ b/ghc/compiler/typecheck/TcSplice.lhs @@ -1,4 +1,4 @@ -2% +% % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[TcSplice]{Template Haskell splices} @@ -13,32 +13,62 @@ import TcRnDriver ( tcTopSrcDecls ) -- These imports are the reason that TcSplice -- is very high up the module hierarchy -import qualified Language.Haskell.THSyntax as Meta - -import HscTypes ( HscEnv(..) ) -import HsSyn ( HsBracket(..), HsExpr(..) ) -import Convert ( convertToHsExpr, convertToHsDecls ) -import RnExpr ( rnExpr ) -import RdrHsSyn ( RdrNameHsExpr, RdrNameHsDecl ) -import RnHsSyn ( RenamedHsExpr ) +import qualified Language.Haskell.TH as TH +-- THSyntax gives access to internal functions and data types +import qualified Language.Haskell.TH.Syntax as TH + +import HsSyn ( HsBracket(..), HsExpr(..), HsSplice(..), LHsExpr, LHsDecl, + HsType, LHsType ) +import Convert ( convertToHsExpr, convertToHsDecls, convertToHsType ) +import RnExpr ( rnLExpr ) +import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe ) +import RdrName ( RdrName, mkRdrUnqual, lookupLocalRdrEnv ) +import RnTypes ( rnLHsType ) import TcExpr ( tcCheckRho, tcMonoExpr ) -import TcHsSyn ( TcExpr, TypecheckedHsExpr, mkHsLet, zonkTopExpr ) +import TcHsSyn ( mkHsLet, zonkTopLExpr ) import TcSimplify ( tcSimplifyTop, tcSimplifyBracket ) import TcUnify ( Expected, zapExpectedTo, zapExpectedType ) -import TcType ( TcType, openTypeKind, mkAppTy ) +import TcType ( TcType, TcKind, liftedTypeKind, mkAppTy, tcSplitSigmaTy ) import TcEnv ( spliceOK, tcMetaTy, bracketOK ) -import TcMType ( newTyVarTy, UserTypeCtxt(ExprSigCtxt) ) -import TcHsType ( tcHsSigType ) -import Name ( Name ) +import TcMType ( newTyFlexiVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType, zonkTcTyVar ) +import TcHsType ( tcHsSigType, kcHsType ) +import TcIface ( tcImportDecl ) +import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification +import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName, + mkInternalName, nameIsLocalOrFrom ) +import NameEnv ( lookupNameEnv ) +import HscTypes ( lookupType, ExternalPackageState(..) ) +import OccName +import Var ( Id, TyVar, idType ) +import Module ( moduleUserString, mkModuleName ) import TcRnMonad - +import IfaceEnv ( lookupOrig ) +import Class ( Class, classExtraBigSig ) +import TyCon ( TyCon, AlgTyConRhs(..), tyConTyVars, getSynTyConDefn, + isSynTyCon, isNewTyCon, tyConDataCons, algTyConRhs ) +import DataCon ( DataCon, dataConTyCon, dataConOrigArgTys, dataConStrictMarks, + dataConName, dataConFieldLabels, dataConWrapId, dataConIsInfix, + isVanillaDataCon ) +import Id ( idName, globalIdDetails ) +import IdInfo ( GlobalIdDetails(..) ) import TysWiredIn ( mkListTy ) -import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName ) -import ErrUtils (Message) +import DsMeta ( expQTyConName, typeQTyConName, decTyConName, qTyConName, nameTyConName ) +import ErrUtils ( Message ) +import SrcLoc ( noLoc, unLoc, getLoc, noSrcLoc ) import Outputable +import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily ) + +import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) ) import Panic ( showException ) -import GHC.Base ( unsafeCoerce# ) -- Should have a better home in the module hierarchy -import Monad (liftM) +import FastString ( LitString ) + +import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy +import Monad ( liftM ) +import Maybes ( orElse ) + +#ifdef GHCI +import FastString ( mkFastString ) +#endif \end{code} @@ -49,12 +79,9 @@ import Monad (liftM) %************************************************************************ \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) @@ -69,7 +96,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 { @@ -79,6 +106,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 -> @@ -92,18 +120,17 @@ 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 (ExpBr v) - = panic "tc_bracket" --- tcMetaTy varTyConName +tc_bracket (VarBr v) + = 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) @@ -113,7 +140,7 @@ tc_bracket (TypBr typ) -- Result type is Type (= Q Typ) tc_bracket (DecBr decls) - = tcTopSrcDecls decls `thenM_` + = tcTopSrcDecls [{- no boot-names -}] decls `thenM_` -- Typecheck the declarations, dicarding the result -- We'll get all that stuff later, when we splice it in @@ -131,14 +158,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 @@ -147,7 +176,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 $ @@ -168,6 +197,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 -> @@ -179,42 +209,113 @@ tcTopSplice expr res_ty runMetaE zonked_q_expr `thenM` \ simple_expr -> let - -- simple_expr :: Meta.Exp + -- simple_expr :: TH.Exp - expr2 :: RdrNameHsExpr + expr2 :: LHsExpr RdrName 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 (mkHsLet 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) + ; simple_ty <- runMetaT zonked_q_expr + + ; let -- simple_ty :: TH.Type + hs_ty2 :: LHsType RdrName + hs_ty2 = convertToHsType simple_ty + + ; 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} %* * %************************************************************************ @@ -222,23 +323,22 @@ tcTopSpliceExpr expr meta_ty \begin{code} -- Always at top level 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 -> - - -- Run the expression - traceTc (text "About to run" <+> ppr zonked_q_expr) `thenM_` - runMetaD zonked_q_expr `thenM` \ simple_expr -> - -- simple_expr :: [Meta.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 + = 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) + ; simple_expr <- runMetaD zonked_q_expr + + -- simple_expr :: [TH.Dec] + -- decls :: [RdrNameHsDecl] + ; decls <- handleErrors (convertToHsDecls simple_expr) + ; traceTc (text "Got result" <+> vcat (map ppr decls)) + ; showSplice "declarations" + zonked_q_expr (vcat (map ppr decls)) + ; returnM decls } where handleErrors :: [Either a Message] -> TcM [a] handleErrors [] = return [] @@ -255,128 +355,61 @@ tcSpliceDecls expr %************************************************************************ \begin{code} -runMetaE :: TypecheckedHsExpr -- Of type (Q Exp) - -> TcM Meta.Exp -- Of type Exp +runMetaE :: LHsExpr Id -- Of type (Q Exp) + -> TcM TH.Exp -- Of type Exp runMetaE e = runMeta e -runMetaD :: TypecheckedHsExpr -- Of type Q [Dec] - -> TcM [Meta.Dec] -- Of type [Dec] +runMetaT :: LHsExpr Id -- Of type (Q Type) + -> TcM TH.Type -- Of type Type +runMetaT e = runMeta e + +runMetaD :: LHsExpr Id -- Of type Q [Dec] + -> TcM [TH.Dec] -- Of type [Dec] runMetaD e = runMeta e -runMeta :: TypecheckedHsExpr -- Of type X +runMeta :: LHsExpr Id -- Of type X -> TcM t -- Of type t runMeta expr - = getTopEnv `thenM` \ hsc_env -> - getGblEnv `thenM` \ tcg_env -> - getModule `thenM` \ this_mod -> - let - type_env = tcg_type_env tcg_env - rdr_env = tcg_rdr_env tcg_env - in + = 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 - tryM (ioToTcRn (do - hval <- HscMain.compileExpr - hsc_env this_mod - rdr_env type_env expr - Meta.runQ (unsafeCoerce# hval) -- Coerce it to Q t, and run it - )) `thenM` \ either_tval -> - - case either_tval of - Left exn -> failWithTc (vcat [text "Exception when trying to run compile-time code:", - nest 4 (vcat [text "Code:" <+> ppr expr, + ; either_tval <- tryM $ do + { -- Compile it + hval <- ioToTcRn (HscMain.compileExpr + hsc_env this_mod + rdr_env type_env expr) + -- Coerce it to Q t, and run it + ; TH.runQ (unsafeCoerce# hval) } + + ; 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 v -> returnM v } \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 + ; let i = getKey u + ; return (TH.mkNameU s i) } ------------------------------------ - Random comments - - - module Foo where - import Lib( g :: Int -> M Exp ) - h x = not x - f x y = [| \z -> (x, $(g y), z, map, h) |] - - h p = $( (\q r -> if q then [| \s -> (p,r,s) |] - else ... ) True 3) ) - -==> core - - f :: Liftable a => a -> Int -> M Exp - f = /\a -> \d::Liftable a -> - \ x y -> genSym "z" `bindM` \ z::String -> - g y `bindM` \ vv::Exp -> - Lam z (Tup [lift d x, v, Var z, - Glob "Prelude" "map", - Glob "Foo" "h"]) - - - h :: Tree Int -> M Exp - h = \p -> \s' -> (p,3,s') - - - Bound Used - - map: C0 C1 (top-level/imp) - x: C0 C1 (lam/case) - y: C0 C0 - z: C1 C1 - - p: C0 S1 - r: S0 S1 - q: S0 S0 - s: S1 S1 - -------- - - f x y = lam "z" (tup [lift x, g y, var "z", - [| map |], [| h |] ]) -==> core - - f = \x y -> lam "z" (tup [lift d x, g y, var "z", - return (Glob "Prelude" "map"), - return (Glob "Foo" "h")]) - - - - - - - - h :: M Exp -> M Exp - h v = [| \x -> map $v x |] - - g :: Tree Int -> M Exp - g x = $(h [| x |]) -==> - g x = \x' -> map x x' - -*** Simon claims x does not have to be liftable! ** - -Level 0 compile time -Level 1 run time -Level 2 code returned by run time (generation time) - -Non-top-level variables - x occurs at level 1 - inside brackets - bound at level 0 --> x - bound at level 1 --> var "x" - - not inside brackets --> x - - x at level 2 - inside brackets - bound at level 0 --> x - bound at level 1 --> var "x" + qReport True msg = addErr (text msg) + qReport False msg = addReport (text msg) - f x = x + qCurrentModule = do { m <- getModule; return (moduleUserString m) } + qReify v = reify v + qRecover = recoverM -Two successive brackets aren't allowed + qRunIO io = ioToTcRn io +\end{code} %************************************************************************ @@ -386,9 +419,9 @@ Two successive brackets aren't allowed %************************************************************************ \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 "======>", @@ -402,3 +435,250 @@ illegalSplice level #endif /* GHCI */ \end{code} + + +%************************************************************************ +%* * + Reification +%* * +%************************************************************************ + + +\begin{code} +reify :: TH.Name -> TcM TH.Info +reify th_name + = do { name <- lookupThName th_name + ; thing <- tcLookupTh name + -- ToDo: this tcLookup could fail, which would give a + -- rather unhelpful error message + ; reifyThing thing + } + +lookupThName :: TH.Name -> TcM Name +lookupThName (TH.Name occ (TH.NameG th_ns mod)) + = lookupOrig (mkModuleName (TH.modString mod)) + (OccName.mkOccName ghc_ns (TH.occString occ)) + where + ghc_ns = case th_ns of + TH.DataName -> dataName + TH.TcClsName -> tcClsName + TH.VarName -> varName + +lookupThName th_name@(TH.Name occ TH.NameS) + = do { let rdr_name = mkRdrUnqual (OccName.mkOccFS ns occ_fs) + ; rdr_env <- getLocalRdrEnv + ; case lookupLocalRdrEnv rdr_env rdr_name of + Just name -> return name + Nothing -> do + { mb_name <- lookupSrcOcc_maybe rdr_name + ; case mb_name of + Just name -> return name ; + Nothing -> failWithTc (notInScope th_name) + }} + where + ns | isLexCon occ_fs = OccName.dataName + | otherwise = OccName.varName + occ_fs = mkFastString (TH.occString occ) + +lookupThName (TH.Name occ (TH.NameU uniq)) + = return (mkInternalName (mk_uniq uniq) (OccName.mkOccFS bogus_ns occ_fs) noSrcLoc) + where + occ_fs = mkFastString (TH.occString occ) + bogus_ns = OccName.varName -- Not yet recorded in the TH name + -- but only the unique matters + +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 { traceIf (text "tcLookupGlobal" <+> ppr name) + ; thing <- initIfaceTcRn (tcImportDecl name) + ; return (AGlobal thing) } + -- Imported names should always be findable; + -- if not, we fail hard in tcImportDecl + }}} + +mk_uniq :: Int# -> Unique +mk_uniq u = mkUniqueGrimily (I# u) + +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 +-- The only reason this is monadic is for error reporting, +-- which in turn is mainly for the case when TH can't express +-- some random GHC extension + +reifyThing (AGlobal (AnId id)) + = do { ty <- reifyType (idType id) + ; fix <- reifyFixity (idName id) + ; let v = reifyName id + ; case globalIdDetails id of + ClassOpId cls -> return (TH.ClassOpI v ty (reifyName cls) fix) + 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 (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 _ _) + = 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 + ; ty2 <- reifyType ty1 + ; return (TH.TyVarI (reifyName tv) ty2) } + +------------------------------ +reifyTyCon :: TyCon -> TcM TH.Dec +reifyTyCon tc + | isSynTyCon tc + = do { let (tvs, rhs) = getSynTyConDefn tc + ; rhs' <- reifyType rhs + ; return (TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') } + +reifyTyCon tc + = case algTyConRhs tc of + NewTyCon data_con _ _ + -> do { con <- reifyDataCon data_con + ; return (TH.NewtypeD [] (reifyName tc) (reifyTyVars (tyConTyVars tc)) + con [{- Don't know about deriving -}]) } + + DataTyCon mb_cxt cons _ + -> do { cxt <- reifyCxt (mb_cxt `orElse` []) + ; cons <- mapM reifyDataCon (tyConDataCons tc) + ; return (TH.DataD cxt (reifyName tc) (reifyTyVars (tyConTyVars tc)) + cons [{- Don't know about deriving -}]) } + +reifyDataCon :: DataCon -> TcM TH.Con +reifyDataCon dc + | isVanillaDataCon dc + = do { arg_tys <- reifyTypes (dataConOrigArgTys dc) + ; 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 (s1,a2)) + else + 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 cls + = do { cxt <- reifyCxt theta + ; ops <- mapM reify_op op_stuff + ; return (TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) } + where + (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) } + +------------------------------ +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 (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) } +reifyType ty@(ForAllTy _ _) = do { cxt' <- reifyCxt cxt; + ; tau' <- reifyType tau + ; return (TH.ForallT (reifyTyVars tvs) cxt' tau') } + where + (tvs, cxt, tau) = tcSplitSigmaTy ty +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 + +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 p@(IParam _ _) = noTH SLIT("implicit parameters") (ppr p) + + +------------------------------ +reifyName :: NamedThing n => n -> TH.Name +reifyName thing + | isExternalName name = mk_varg mod occ_str + | otherwise = TH.mkNameU occ_str (getKey (getUnique name)) + where + name = getName thing + mod = moduleUserString (nameModule name) + occ_str = occNameUserString occ + occ = nameOccName name + mk_varg | OccName.isDataOcc occ = TH.mkNameG_d + | OccName.isVarOcc occ = TH.mkNameG_v + | OccName.isTcOcc occ = TH.mkNameG_tc + | otherwise = pprPanic "reifyName" (ppr name) + +------------------------------ +reifyFixity :: Name -> TcM TH.Fixity +reifyFixity name + = do { fix <- lookupFixityRn name + ; return (conv_fix fix) } + where + conv_fix (BasicTypes.Fixity i d) = TH.Fixity i (conv_dir d) + conv_dir BasicTypes.InfixR = TH.InfixR + 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 + +------------------------------ +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}