X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=4ed73643d06119cfa7b743c4772c76dd1d1e8c51;hp=88d8954bf17debaa18ecb9c68c2ae5dc77d9c603;hb=102b73a3f2a2f63d3835726be625dca8053dd88c;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 88d8954..4ed7364 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
@@ -109,7 +106,7 @@ cvtTop (TySynD tc tvs rhs)
   = do	{ tc' <- tconNameL tc
 	; tvs' <- cvtTvs tvs
 	; rhs' <- cvtType rhs
-	; returnL $ TyClD (TySynonym tc' tvs' rhs') }
+	; returnL $ TyClD (TySynonym tc' tvs' Nothing rhs') }
 
 cvtTop (DataD ctxt tc tvs constrs derivs)
   = do	{ stuff <- cvt_tycl_hdr ctxt tc tvs
@@ -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
@@ -210,7 +211,7 @@ cvtForD (ImportF callconv safety from nm ty)
   = do	{ nm' <- vNameL nm
 	; ty' <- cvtType ty
 	; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
-	; return $ ForeignImport nm' ty' i False }
+	; return $ ForeignImport nm' ty' i }
 
   | otherwise
   = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent")
@@ -224,10 +225,10 @@ cvtForD (ExportF callconv as nm ty)
   = do	{ nm' <- vNameL nm
 	; ty' <- cvtType ty
 	; let e = CExport (CExportStatic (mkFastString as) (cvt_conv callconv))
- 	; return $ ForeignExport nm' ty' e False }
+ 	; 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') placeHolderType placeHolderType }
 
 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