Migrate cvs diff from fptools-assoc branch

[ghc-hetmet.git] / compiler / hsSyn / Convert.lhs

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index 6c14c11..4dd3a6d 100644 (file)
--- 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 )
@@ -47,7 +48,11 @@ convertToHsDecls :: SrcSpan -> [TH.Dec] -> Either Message [LHsDecl RdrName]
 convertToHsDecls loc ds = initCvt loc (mapM cvtTop ds)
 
 convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
-convertToHsExpr loc e = initCvt loc (cvtl e)
+convertToHsExpr loc e 
+  = case initCvt loc (cvtl e) of
+       Left msg  -> Left (msg $$ (ptext SLIT("When converting TH expression")
+                                   <+> text (show e)))
+       Right res -> Right res
 
 convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
 convertToHsType loc t = initCvt loc (cvtType t)
@@ -104,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
@@ -123,14 +128,18 @@ cvtTop (ClassD ctxt cl tvs fds decs)
   = do { stuff <- 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 stuff fds' sigs' binds' []  
+                                                            -- ^^no ATs 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' }
 
@@ -138,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
@@ -205,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")
@@ -219,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
@@ -565,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)
@@ -613,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)