X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=db007865852cc8fb89d90df6966a831a90693c6e;hp=17d6be92e664fd94e7a043ece9e79e6513939997;hb=940524aec90652b5ef81789c9a453c57c0e42cc9;hpb=9cbee1b3381d4eac1f54e9f0b4c333e6ead3a4cf

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 17d6be9..db00786 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -1,45 +1,42 @@
 %
+% (c) The University of Glasgow 2006
 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
 %
 
 This module converts Template Haskell syntax into HsSyn
 
-
 \begin{code}
-module Convert( convertToHsExpr, convertToHsDecls, convertToHsType, thRdrName ) where
+module Convert( convertToHsExpr, convertToHsDecls, 
+                convertToHsType, thRdrName ) where
 
 #include "HsVersions.h"
 
-import Language.Haskell.TH as TH hiding (sigP)
-import Language.Haskell.TH.Syntax as TH
-
 import HsSyn as Hs
-import qualified Class (FunDep)
-import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
-import qualified Name	( Name, mkInternalName, getName )
-import Module   ( ModuleName, mkModuleName, mkModule )
-import RdrHsSyn	( mkClassDecl, mkTyData )
+import qualified Class
+import RdrName
+import qualified Name
+import Module
+import RdrHsSyn
 import qualified OccName
-import PackageConfig    ( PackageId, stringToPackageId )
-import OccName	( startsVarId, startsVarSym, startsConId, startsConSym,
-		  pprNameSpace )
-import SrcLoc	( Located(..), SrcSpan )
-import Type	( Type )
-import TysWiredIn ( unitTyCon, tupleTyCon, tupleCon, trueDataCon, nilDataCon, consDataCon )
-import BasicTypes( Boxity(..) ) 
-import ForeignCall ( Safety(..), CCallConv(..), CCallTarget(..),
-                     CExportSpec(..)) 
-import Char 	( isAscii, isAlphaNum, isAlpha )
-import List	( partition )
-import Unique	( Unique, mkUniqueGrimily )
-import ErrUtils ( Message )
-import GLAEXTS	( Int(..), Int# )
-import SrcLoc	( noSrcLoc )
-import Bag	( listToBag )
+import PackageConfig
+import OccName
+import SrcLoc
+import Type
+import TysWiredIn
+import BasicTypes
+import ForeignCall
+import Char
+import List
+import Unique
+import ErrUtils
+import Bag
 import FastString
 import Outputable
 
+import Language.Haskell.TH as TH hiding (sigP)
+import Language.Haskell.TH.Syntax as TH
 
+import GHC.Exts
 
 -------------------------------------------------------------------
 --		The external interface
@@ -125,17 +122,21 @@ cvtTop (NewtypeD ctxt tc tvs constr derivs)
 	; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }
 
 cvtTop (ClassD ctxt cl tvs fds decs)
-  = do	{ stuff <- cvt_tycl_hdr ctxt cl tvs
+  = do	{ (cxt', tc', tvs', _) <- cvt_tycl_hdr ctxt cl tvs
 	; fds'  <- mapM cvt_fundep fds
 	; (binds', sigs') <- cvtBindsAndSigs decs
-	; returnL $ TyClD $ mkClassDecl stuff fds' sigs' binds' }
+	; returnL $ TyClD $ mkClassDecl (cxt', tc', tvs') fds' sigs' binds' [] []
+						    -- no ATs or docs in TH ^^ ^^
+	}
 
 cvtTop (InstanceD tys ty decs)
   = do 	{ (binds', sigs') <- cvtBindsAndSigs decs
 	; ctxt' <- cvtContext tys
 	; L loc pred' <- cvtPred ty
 	; inst_ty' <- returnL $ mkImplicitHsForAllTy ctxt' (L loc (HsPredTy pred'))
-	; returnL $ InstD (InstDecl inst_ty' binds' sigs') }
+	; returnL $ InstD (InstDecl inst_ty' binds' sigs' [])
+						       -- ^^no ATs in TH
+	}
 
 cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
 
@@ -143,7 +144,7 @@ cvt_tycl_hdr cxt tc tvs
   = do	{ cxt' <- cvtContext cxt
 	; tc'  <- tconNameL tc
 	; tvs' <- cvtTvs tvs
-	; return (cxt', tc', tvs') }
+	; return (cxt', tc', tvs', Nothing) }
 
 ---------------------------------------------------
 -- 	Data types
@@ -154,20 +155,20 @@ cvtConstr (NormalC c strtys)
   = do	{ c'   <- cNameL c 
 	; cxt' <- returnL []
 	; tys' <- mapM cvt_arg strtys
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 }
+	; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 Nothing }
 
 cvtConstr (RecC c varstrtys)
   = do 	{ c'    <- cNameL c 
 	; cxt'  <- returnL []
 	; args' <- mapM cvt_id_arg varstrtys
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 }
+	; returnL $ ConDecl c' Explicit noExistentials cxt' (RecCon args') ResTyH98 Nothing }
 
 cvtConstr (InfixC st1 c st2)
   = do 	{ c' <- cNameL c 
 	; cxt' <- returnL []
 	; st1' <- cvt_arg st1
 	; st2' <- cvt_arg st2
-	; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 }
+	; returnL $ ConDecl c' Explicit noExistentials cxt' (InfixCon st1' st2') ResTyH98 Nothing }
 
 cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
   = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
@@ -177,8 +178,8 @@ cvtConstr (ForallC tvs ctxt con)
 	; tvs'  <- cvtTvs tvs
 	; ctxt' <- cvtContext ctxt
 	; case con' of
-	    ConDecl l _ [] (L _ []) x ResTyH98
-	      -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98
+	    ConDecl l _ [] (L _ []) x ResTyH98 _
+	      -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98 Nothing
 	    c -> panic "ForallC: Can't happen" }
 
 cvt_arg (IsStrict, ty)  = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
@@ -186,7 +187,7 @@ cvt_arg (NotStrict, ty) = cvtType ty
 
 cvt_id_arg (i, str, ty) = do { i' <- vNameL i
 			     ; ty' <- cvt_arg (str,ty)
-			     ; return (i', ty') }
+			     ; return (mkRecField i' ty') }
 
 cvtDerivs [] = return Nothing
 cvtDerivs cs = do { cs' <- mapM cvt_one cs
@@ -226,8 +227,8 @@ cvtForD (ExportF callconv as nm ty)
 	; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
  	; return $ ForeignExport nm' ty' e }
 
-cvt_conv CCall   = CCallConv
-cvt_conv StdCall = StdCallConv
+cvt_conv TH.CCall   = CCallConv
+cvt_conv TH.StdCall = StdCallConv
 
 parse_ccall_impent :: String -> String -> Maybe (FastString, CImportSpec)
 parse_ccall_impent nm s
@@ -363,10 +364,10 @@ cvtl e = wrapL (cvt e)
 			      ; return $ ExprWithTySig e' t' }
     cvt (RecConE c flds) = do { c' <- cNameL c
 			      ; flds' <- mapM cvtFld flds
-			      ; return $ RecordCon c' noPostTcExpr flds' }
+			      ; return $ RecordCon c' noPostTcExpr (HsRecordBinds flds') }
     cvt (RecUpdE e flds) = do { e' <- cvtl e
 			      ; flds' <- mapM cvtFld flds
-			      ; return $ RecordUpd e' flds' placeHolderType placeHolderType }
+			      ; return $ RecordUpd e' (HsRecordBinds flds') [] [] [] }
 
 cvtFld (v,e) = do { v' <- vNameL v; e' <- cvtl e; return (v',e') }
 
@@ -417,6 +418,7 @@ cvtpair (PatG gs,rhs)    = do { gs' <- cvtStmts gs; rhs' <- cvtl rhs
 cvtOverLit :: Lit -> CvtM (HsOverLit RdrName)
 cvtOverLit (IntegerL i)  = do { force i; return $ mkHsIntegral i }
 cvtOverLit (RationalL r) = do { force r; return $ mkHsFractional r }
+cvtOverLit (StringL s)   = do { let { s' = mkFastString s }; force s'; return $ mkHsIsString s' }
 -- An Integer is like an an (overloaded) '3' in a Haskell source program
 -- Similarly 3.5 for fractionals
 
@@ -454,7 +456,7 @@ cvtp (RecP c fs)      = do { c' <- cNameL c; fs' <- mapM cvtPatFld fs
 cvtp (ListP ps)       = do { ps' <- cvtPats ps; return $ ListPat ps' void }
 cvtp (SigP p t)       = do { p' <- cvtPat p; t' <- cvtType t; return $ SigPatIn p' t' }
 
-cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (s',p') }
+cvtPatFld (s,p) = do { s' <- vNameL s; p' <- cvtPat p; return (mkRecField s' p') }
 
 -----------------------------------------------------------
 --	Types and type variables
@@ -571,7 +573,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 -- 
 -- The strict applications ensure that any buried exceptions get forced
 thRdrName ctxt_ns occ (TH.NameG th_ns pkg mod) = (mkOrig $! (mkModule (mk_pkg pkg) (mk_mod mod))) $! (mk_occ (mk_ghc_ns th_ns) occ)
-thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcLoc)
+thRdrName ctxt_ns occ (TH.NameL uniq)      = nameRdrName $! (((Name.mkInternalName $! (mk_uniq uniq)) $! (mk_occ ctxt_ns occ)) noSrcSpan)
 thRdrName ctxt_ns occ (TH.NameQ mod)       = (mkRdrQual  $! (mk_mod mod)) $! (mk_occ ctxt_ns occ)
 thRdrName ctxt_ns occ (TH.NameU uniq)      = mkRdrUnqual $! (mk_uniq_occ ctxt_ns occ uniq)
 thRdrName ctxt_ns occ TH.NameS