X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2FhsSyn%2FConvert.lhs;h=dff6a1405b9c3cd3c6a7c6b468532bf0ea3634b6;hp=77e9e082243518701ea98018676ceb1dd0a55127;hb=190f24892156953d73b55401d0467a6f1a88ce5d;hpb=7f546581e86c816ece1f7c877560ffa1cf385165

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 77e9e08..dff6a14 100644
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -17,9 +17,10 @@ import HsSyn as Hs
 import qualified Class (FunDep)
 import RdrName	( RdrName, mkRdrUnqual, mkRdrQual, mkOrig, getRdrName, nameRdrName )
 import qualified Name	( Name, mkInternalName, getName )
-import Module   ( Module, mkModule )
+import Module   ( ModuleName, mkModuleName, mkModule )
 import RdrHsSyn	( mkClassDecl, mkTyData )
 import qualified OccName
+import PackageConfig    ( PackageId, stringToPackageId )
 import OccName	( startsVarId, startsVarSym, startsConId, startsConSym,
 		  pprNameSpace )
 import SrcLoc	( Located(..), SrcSpan )
@@ -108,7 +109,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
@@ -124,17 +125,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' }
 
@@ -142,7 +147,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
@@ -153,20 +158,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')
@@ -176,8 +181,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' }
@@ -185,7 +190,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
@@ -209,7 +214,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")
@@ -223,7 +228,7 @@ 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
@@ -453,7 +458,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
@@ -569,7 +574,7 @@ thRdrName :: OccName.NameSpace -> String -> TH.NameFlavour -> RdrName
 -- 	 which will give confusing error messages later
 -- 
 -- The strict applications ensure that any buried exceptions get forced
-thRdrName ctxt_ns occ (TH.NameG th_ns mod) = (mkOrig     $! (mk_mod mod)) $! (mk_occ (mk_ghc_ns th_ns) occ)
+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.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)
@@ -617,8 +622,11 @@ mk_ghc_ns TH.DataName  = OccName.dataName
 mk_ghc_ns TH.TcClsName = OccName.tcClsName
 mk_ghc_ns TH.VarName   = OccName.varName
 
-mk_mod :: TH.ModName -> Module
-mk_mod mod = mkModule (TH.modString mod)
+mk_mod :: TH.ModName -> ModuleName
+mk_mod mod = mkModuleName (TH.modString mod)
+
+mk_pkg :: TH.ModName -> PackageId
+mk_pkg pkg = stringToPackageId (TH.pkgString pkg)
 
 mk_uniq :: Int# -> Unique
 mk_uniq u = mkUniqueGrimily (I# u)