-cvt_top loc (InstanceD tys ty decs)
- = Left $ L loc $ InstD (InstDecl (L loc inst_ty) binds sigs)
- where
- (binds, sigs) = cvtBindsAndSigs loc decs
- inst_ty = mkImplicitHsForAllTy (cvt_context loc tys) (L loc (HsPredTy (cvt_pred loc ty)))
-
-cvt_top loc (ForeignD (ImportF callconv safety from nm typ))
- = case parsed of
- Just (c_header, cis) ->
- let i = CImport callconv' safety' c_header nilFS cis
- in Left $ L loc $ ForD (ForeignImport (L loc (vName nm)) (cvtType loc typ) i False)
- Nothing -> Right $ text (show from)
- <+> ptext SLIT("is not a valid ccall impent")
- where callconv' = case callconv of
- CCall -> CCallConv
- StdCall -> StdCallConv
- safety' = case safety of
- Unsafe -> PlayRisky
- Safe -> PlaySafe False
- Threadsafe -> PlaySafe True
- parsed = parse_ccall_impent (TH.nameBase nm) from
-
-cvt_top loc (ForeignD (ExportF callconv as nm typ))
- = let e = CExport (CExportStatic (mkFastString as) callconv')
- in Left $ L loc $ ForD (ForeignExport (L loc (vName nm)) (cvtType loc typ) e False)
- where callconv' = case callconv of
- CCall -> CCallConv
- StdCall -> StdCallConv
-
-mk_con loc con = L loc $ mk_nlcon con
- where
- -- Can't handle GADTs yet
- mk_nlcon con = case con of
- NormalC c strtys
- -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
- (PrefixCon (map mk_arg strtys)) ResTyH98
- RecC c varstrtys
- -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
- (RecCon (map mk_id_arg varstrtys)) ResTyH98
- InfixC st1 c st2
- -> ConDecl (L loc (cName c)) Explicit noExistentials (noContext loc)
- (InfixCon (mk_arg st1) (mk_arg st2)) ResTyH98
- ForallC tvs ctxt (ForallC tvs' ctxt' con')
- -> mk_nlcon (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
- ForallC tvs ctxt con' -> case mk_nlcon con' of
- ConDecl l _ [] (L _ []) x ResTyH98 ->
- ConDecl l Explicit (cvt_tvs loc tvs) (cvt_context loc ctxt) x ResTyH98
- c -> panic "ForallC: Can't happen"
- mk_arg (IsStrict, ty) = L loc $ HsBangTy HsStrict (cvtType loc ty)
- mk_arg (NotStrict, ty) = cvtType loc ty
-
- mk_id_arg (i, IsStrict, ty)
- = (L loc (vName i), L loc $ HsBangTy HsStrict (cvtType loc ty))
- mk_id_arg (i, NotStrict, ty)
- = (L loc (vName i), cvtType loc ty)
-
-mk_derivs loc [] = Nothing
-mk_derivs loc cs = Just [L loc $ HsPredTy $ HsClassP (tconName c) [] | c <- cs]
-
-cvt_fundep :: FunDep -> Class.FunDep RdrName
-cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
+instance Monad CvtM where
+ return x = CvtM $ \loc -> Right x
+ (CvtM m) >>= k = CvtM $ \loc -> case m loc of
+ Left err -> Left err
+ Right v -> unCvtM (k v) loc
+
+initCvt :: SrcSpan -> CvtM a -> Either Message a
+initCvt loc (CvtM m) = m loc
+
+force :: a -> CvtM a
+force a = a `seq` return a
+
+failWith :: Message -> CvtM a
+failWith m = CvtM (\loc -> Left full_msg)
+ where
+ full_msg = m $$ ptext SLIT("When splicing generated code into the program")
+
+returnL :: a -> CvtM (Located a)
+returnL x = CvtM (\loc -> Right (L loc x))
+
+wrapL :: CvtM a -> CvtM (Located a)
+wrapL (CvtM m) = CvtM (\loc -> case m loc of
+ Left err -> Left err
+ Right v -> Right (L loc v))
+
+-------------------------------------------------------------------
+cvtTop :: TH.Dec -> CvtM (LHsDecl RdrName)
+cvtTop d@(TH.ValD _ _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
+cvtTop d@(TH.FunD _ _) = do { L loc d' <- cvtBind d; return (L loc $ Hs.ValD d') }
+cvtTop (TH.SigD nm typ) = do { nm' <- vNameL nm
+ ; ty' <- cvtType typ
+ ; returnL $ Hs.SigD (TypeSig nm' ty') }
+
+cvtTop (TySynD tc tvs rhs)
+ = do { tc' <- tconNameL tc
+ ; tvs' <- cvtTvs tvs
+ ; rhs' <- cvtType rhs
+ ; returnL $ TyClD (TySynonym tc' tvs' rhs') }
+
+cvtTop (DataD ctxt tc tvs constrs derivs)
+ = do { stuff <- cvt_tycl_hdr ctxt tc tvs
+ ; cons' <- mapM cvtConstr constrs
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (mkTyData DataType stuff Nothing cons' derivs') }
+
+
+cvtTop (NewtypeD ctxt tc tvs constr derivs)
+ = do { stuff <- cvt_tycl_hdr ctxt tc tvs
+ ; con' <- cvtConstr constr
+ ; derivs' <- cvtDerivs derivs
+ ; returnL $ TyClD (mkTyData NewType stuff Nothing [con'] derivs') }
+
+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' }
+
+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') }
+
+cvtTop (ForeignD ford) = do { ford' <- cvtForD ford; returnL $ ForD ford' }
+
+cvt_tycl_hdr cxt tc tvs
+ = do { cxt' <- cvtContext cxt
+ ; tc' <- tconNameL tc
+ ; tvs' <- cvtTvs tvs
+ ; return (cxt', tc', tvs') }
+
+---------------------------------------------------
+-- Data types
+-- Can't handle GADTs yet
+---------------------------------------------------
+
+cvtConstr (NormalC c strtys)
+ = do { c' <- cNameL c
+ ; cxt' <- returnL []
+ ; tys' <- mapM cvt_arg strtys
+ ; returnL $ ConDecl c' Explicit noExistentials cxt' (PrefixCon tys') ResTyH98 }
+
+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 }
+
+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 }
+
+cvtConstr (ForallC tvs ctxt (ForallC tvs' ctxt' con'))
+ = cvtConstr (ForallC (tvs ++ tvs') (ctxt ++ ctxt') con')
+
+cvtConstr (ForallC tvs ctxt con)
+ = do { L _ con' <- cvtConstr con
+ ; tvs' <- cvtTvs tvs
+ ; ctxt' <- cvtContext ctxt
+ ; case con' of
+ ConDecl l _ [] (L _ []) x ResTyH98
+ -> returnL $ ConDecl l Explicit tvs' ctxt' x ResTyH98
+ c -> panic "ForallC: Can't happen" }
+
+cvt_arg (IsStrict, ty) = do { ty' <- cvtType ty; returnL $ HsBangTy HsStrict ty' }
+cvt_arg (NotStrict, ty) = cvtType ty
+
+cvt_id_arg (i, str, ty) = do { i' <- vNameL i
+ ; ty' <- cvt_arg (str,ty)
+ ; return (i', ty') }
+
+cvtDerivs [] = return Nothing
+cvtDerivs cs = do { cs' <- mapM cvt_one cs
+ ; return (Just cs') }
+ where
+ cvt_one c = do { c' <- tconName c
+ ; returnL $ HsPredTy $ HsClassP c' [] }
+
+cvt_fundep :: FunDep -> CvtM (Located (Class.FunDep RdrName))
+cvt_fundep (FunDep xs ys) = do { xs' <- mapM tName xs; ys' <- mapM tName ys; returnL (xs', ys') }
+
+noExistentials = []
+
+------------------------------------------
+-- Foreign declarations
+------------------------------------------
+
+cvtForD :: Foreign -> CvtM (ForeignDecl RdrName)
+cvtForD (ImportF callconv safety from nm ty)
+ | Just (c_header, cis) <- parse_ccall_impent (TH.nameBase nm) from
+ = do { nm' <- vNameL nm
+ ; ty' <- cvtType ty
+ ; let i = CImport (cvt_conv callconv) safety' c_header nilFS cis
+ ; return $ ForeignImport nm' ty' i False }
+
+ | otherwise
+ = failWith $ text (show from)<+> ptext SLIT("is not a valid ccall impent")
+ where
+ safety' = case safety of
+ Unsafe -> PlayRisky
+ Safe -> PlaySafe False
+ Threadsafe -> PlaySafe True
+
+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 }
+
+cvt_conv CCall = CCallConv
+cvt_conv StdCall = StdCallConv