-cvt_top (InstanceD tys ty decs)
- = Left $ InstD (InstDecl (noLoc inst_ty) binds sigs)
- where
- (binds, sigs) = cvtBindsAndSigs decs
- inst_ty = mkImplicitHsForAllTy (cvt_context tys) (noLoc (HsPredTy (cvt_pred ty)))
-
-cvt_top (TH.SigD nm typ) = Left $ Hs.SigD (Sig (noLoc (vName nm)) (cvtType typ))
-
-cvt_top (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 $ ForD (ForeignImport (noLoc (vName nm)) (cvtType 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 (ForeignD (ExportF callconv as nm typ))
- = let e = CExport (CExportStatic (mkFastString as) callconv')
- in Left $ ForD (ForeignExport (noLoc (vName nm)) (cvtType typ) e False)
- where callconv' = case callconv of
- CCall -> CCallConv
- StdCall -> StdCallConv
-
-cvt_fundep :: FunDep -> Class.FunDep RdrName
-cvt_fundep (FunDep xs ys) = (map tName xs, map tName ys)
+convertToHsExpr :: SrcSpan -> TH.Exp -> Either Message (LHsExpr RdrName)
+convertToHsExpr loc e = initCvt loc (cvtl e)
+
+convertToHsType :: SrcSpan -> TH.Type -> Either Message (LHsType RdrName)
+convertToHsType loc t = initCvt loc (cvtType t)
+
+
+-------------------------------------------------------------------
+newtype CvtM a = CvtM { unCvtM :: SrcSpan -> Either Message a }
+ -- Push down the source location;
+ -- Can fail, with a single error message
+
+-- NB: If the conversion succeeds with (Right x), there should
+-- be no exception values hiding in x
+-- Reason: so a (head []) in TH code doesn't subsequently
+-- make GHC crash when it tries to walk the generated tree
+
+-- Use the loc everywhere, for lack of anything better
+-- In particular, we want it on binding locations, so that variables bound in
+-- the spliced-in declarations get a location that at least relates to the splice point
+
+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