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 )
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)
= 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
; 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 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' }
= do { cxt' <- cvtContext cxt
; tc' <- tconNameL tc
; tvs' <- cvtTvs tvs
- ; return (cxt', tc', tvs') }
+ ; return (cxt', tc', tvs', Nothing) }
---------------------------------------------------
-- Data types
= 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")
= 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
-- 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)
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)