X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcSplice.lhs;h=b675cf9033f6dcb5c182b1abd45a94bcb0715305;hp=cce4becd89bb0ff10ef942ea0e96fca25ee56d29;hb=cdce647711c0f46f5799b24de087622cb77e647f;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc

diff --git a/compiler/typecheck/TcSplice.lhs b/compiler/typecheck/TcSplice.lhs
index cce4bec..b675cf9 100644
--- a/compiler/typecheck/TcSplice.lhs
+++ b/compiler/typecheck/TcSplice.lhs
@@ -1,75 +1,69 @@
 %
+% (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}
 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 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}
 
 
@@ -83,6 +77,7 @@ import FastString	( mkFastString )
 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)
@@ -96,8 +91,20 @@ tcSpliceDecls e     = pprPanic "Cant do tcSpliceDecls 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 Id)
+tcBracket :: HsBracket Name -> BoxyRhoType -> TcM (LHsExpr TcId)
 tcBracket brack res_ty
   = getStage 				`thenM` \ level ->
     case bracketOK level of {
@@ -368,17 +375,13 @@ 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
-
+  = do	{ 	-- Desugar
+	  ds_expr <- initDsTc (dsLExpr expr)
 	-- Compile and link it; might fail if linking fails
+	; hsc_env <- getTopEnv
+	; src_span <- getSrcSpanM
 	; either_hval <- tryM $ ioToTcRn $
-			 HscMain.compileExpr 
-				      hsc_env this_mod 
-			              rdr_env type_env expr
+			 HscMain.compileExpr hsc_env src_span ds_expr
 	; case either_hval of {
 	    Left exn   -> failWithTc (mk_msg "compile and link" exn) ;
 	    Right hval -> do
@@ -568,9 +571,9 @@ reifyThing (AGlobal (ADataCon 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
+reifyThing (ATcId {tct_id = id, tct_type = ty}) 
+  = do	{ ty1 <- zonkTcType ty	-- 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) }
@@ -586,24 +589,26 @@ 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) = 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
@@ -629,7 +634,7 @@ reifyClass cls
 	; 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) }