%
+% (c) The University of Glasgow 2006
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-\section[TcSplice]{Template Haskell splices}
+
+TcSplice: Template Haskell splices
\begin{code}
+{-# OPTIONS -w #-}
+-- The above warning supression flag is a temporary kludge.
+-- While working on this module you are encouraged to remove it and fix
+-- any warnings in the module. See
+-- http://hackage.haskell.org/trac/ghc/wiki/CodingStyle#Warnings
+-- for details
+
module TcSplice( tcSpliceExpr, tcSpliceDecls, tcBracket ) where
#include "HsVersions.h"
-import HscMain ( compileExpr )
-import TcRnDriver ( tcTopSrcDecls )
+import HscMain
+import TcRnDriver
-- These imports are the reason that TcSplice
-- is very high up the module hierarchy
+import HsSyn
+import Convert
+import RnExpr
+import RnEnv
+import RdrName
+import RnTypes
+import TcExpr
+import TcHsSyn
+import TcSimplify
+import TcUnify
+import TcType
+import TcEnv
+import TcMType
+import TcHsType
+import TcIface
+import TypeRep
+import Name
+import NameEnv
+import HscTypes
+import OccName
+import Var
+import Module
+import TcRnMonad
+import IfaceEnv
+import Class
+import TyCon
+import DataCon
+import Id
+import IdInfo
+import TysWiredIn
+import DsMeta
+import DsExpr
+import DsMonad hiding (Splice)
+import ErrUtils
+import SrcLoc
+import Outputable
+import Unique
+import DynFlags
+import PackageConfig
+import BasicTypes
+import Panic
+import FastString
+
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, thRdrName )
-import RnExpr ( rnLExpr )
-import RnEnv ( lookupFixityRn, lookupSrcOcc_maybe, lookupImportedName )
-import RdrName ( RdrName, lookupLocalRdrEnv, isSrcRdrName )
-import RnTypes ( rnLHsType )
-import TcExpr ( tcMonoExpr )
-import TcHsSyn ( mkHsDictLet, zonkTopLExpr )
-import TcSimplify ( tcSimplifyTop, tcSimplifyBracket )
-import TcUnify ( boxyUnify, unBox )
-import TcType ( TcType, TcKind, BoxyRhoType, liftedTypeKind, mkAppTy, tcSplitSigmaTy )
-import TcEnv ( spliceOK, tcMetaTy, bracketOK )
-import TcMType ( newFlexiTyVarTy, newKindVar, UserTypeCtxt(ExprSigCtxt), zonkTcType )
-import TcHsType ( tcHsSigType, kcHsType )
-import TcIface ( tcImportDecl )
-import TypeRep ( Type(..), PredType(..), TyThing(..) ) -- For reification
-import PrelNames ( thFAKE )
-import Name ( Name, NamedThing(..), nameOccName, nameModule, isExternalName,
- nameIsLocalOrFrom )
-import NameEnv ( lookupNameEnv )
-import HscTypes ( lookupType, ExternalPackageState(..), emptyModDetails )
-import OccName
-import Var ( Id, TyVar, idType )
-import Module ( moduleName, moduleNameString, modulePackageId )
-import TcRnMonad
-import IfaceEnv ( lookupOrig )
-import Class ( Class, classExtraBigSig )
-import TyCon ( TyCon, tyConTyVars, synTyConDefn,
- isSynTyCon, isNewTyCon, tyConDataCons, isPrimTyCon, isFunTyCon,
- tyConArity, tyConStupidTheta, isUnLiftedTyCon )
-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, nameTyConName )
-import DsExpr ( dsLExpr )
-import DsMonad ( initDsTc )
-import ErrUtils ( Message )
-import SrcLoc ( SrcSpan, noLoc, unLoc, getLoc )
-import Outputable
-import Unique ( Unique, Uniquable(..), getKey, mkUniqueGrimily )
-import PackageConfig ( packageIdString )
-import BasicTypes ( StrictnessMark(..), Fixity(..), FixityDirection(..) )
-import Panic ( showException )
-import FastString ( LitString )
-
-import GHC.Base ( unsafeCoerce#, Int#, Int(..) ) -- Should have a better home in the module hierarchy
-import Monad ( liftM )
-
-#ifdef GHCI
-import FastString ( mkFastString )
-#endif
+import GHC.Exts ( unsafeCoerce#, Int#, Int(..) )
+import Control.Monad ( liftM )
\end{code}
tcSpliceDecls :: LHsExpr Name -> TcM [LHsDecl RdrName]
tcSpliceExpr :: HsSplice Name -> BoxyRhoType -> TcM (HsExpr TcId)
kcSpliceType :: HsSplice Name -> TcM (HsType Name, TcKind)
+ -- None of these functions add constraints to the LIE
#ifndef GHCI
tcSpliceExpr n e ty = pprPanic "Cant do tcSpliceExpr without GHCi" (ppr e)
%* *
%************************************************************************
+Note [Handling brackets]
+~~~~~~~~~~~~~~~~~~~~~~~~
+Source: f = [| Just $(g 3) |]
+ The [| |] part is a HsBracket
+
+Typechecked: f = [| Just ${s7}(g 3) |]{s7 = g Int 3}
+ The [| |] part is a HsBracketOut, containing *renamed* (not typechecked) expression
+ The "s7" is the "splice point"; the (g Int 3) part is a typechecked expression
+
+Desugared: f = do { s7 <- g Int 3
+ ; return (ConE "Data.Maybe.Just" s7) }
+
\begin{code}
tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
tcBracket brack res_ty
runMeta convert expr
= do { -- Desugar
ds_expr <- initDsTc (dsLExpr expr)
-
-- Compile and link it; might fail if linking fails
; hsc_env <- getTopEnv
; src_span <- getSrcSpanM
-- exception-cacthing thing so that if there are any lurking
-- exceptions in the data structure returned by hval, we'll
-- encounter them inside the try
- 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
- Right (Just v) -> return v
- Right Nothing -> failM -- Error already in Tc monad
- Left exn -> failWithTc (mk_msg "run" exn) -- Exception
- }}}
+ either_th_syn <- tryAllM $ tryM $ TH.runQ $ unsafeCoerce# hval
+ ; case either_th_syn of
+ Left exn -> failWithTc (mk_msg "run" exn)
+ Right (Left exn) -> failM -- Error already in Tc monad
+ Right (Right th_syn) -> do
+ { either_hs_syn <- tryAllM $ return $! convert (getLoc expr) th_syn
+ ; case either_hs_syn of
+ Left exn -> failWithTc (mk_msg "interpret result of" exn)
+ Right (Left err) -> do { addErrTc err; failM }
+ Right (Right hs_syn) -> return hs_syn
+ }}}}
where
mk_msg s exn = vcat [text "Exception when trying to" <+> text s <+> text "compile-time code:",
nest 2 (text (Panic.showException exn)),
Nothing | not (isSrcRdrName rdr_name) -- Exact, Orig
-> lookupImportedName rdr_name
| otherwise -- Unqual, Qual
- -> do {
- mb_name <- lookupSrcOcc_maybe rdr_name
+ -> do { mb_name <- lookupSrcOcc_maybe rdr_name
; case mb_name of
Just name -> return name
Nothing -> failWithTc (notInScope th_name) }
| 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) = synTyConDefn tc
- ; rhs' <- reifyType rhs
- ; return (TH.TyConI $ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
+ = do { let (tvs, rhs) = synTyConDefn tc
+ ; rhs' <- reifyType rhs
+ ; return (TH.TyConI $
+ TH.TySynD (reifyName tc) (reifyTyVars tvs) rhs') }
reifyTyCon tc
= do { cxt <- reifyCxt (tyConStupidTheta tc)
- ; cons <- mapM reifyDataCon (tyConDataCons tc)
+ ; let tvs = tyConTyVars tc
+ ; cons <- mapM (reifyDataCon (mkTyVarTys tvs)) (tyConDataCons tc)
; let name = reifyName tc
- tvs = reifyTyVars (tyConTyVars tc)
+ r_tvs = reifyTyVars tvs
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
+ decl | isNewTyCon tc = TH.NewtypeD cxt name r_tvs (head cons) deriv
+ | otherwise = TH.DataD cxt name r_tvs cons deriv
; return (TH.TyConI decl) }
-reifyDataCon :: DataCon -> TcM TH.Con
-reifyDataCon dc
+reifyDataCon :: [Type] -> DataCon -> TcM TH.Con
+reifyDataCon tys dc
| isVanillaDataCon dc
- = do { arg_tys <- reifyTypes (dataConOrigArgTys dc)
+ = do { arg_tys <- reifyTypes (dataConInstOrigArgTys dc tys)
; let stricts = map reifyStrict (dataConStrictMarks dc)
fields = dataConFieldLabels dc
name = reifyName dc
; ops <- mapM reify_op op_stuff
; return (TH.ClassI $ TH.ClassD cxt (reifyName cls) (reifyTyVars tvs) fds' ops) }
where
- (tvs, fds, theta, _, op_stuff) = classExtraBigSig 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) }
projects / ghc-hetmet.git / blobdiff