module FFICXX.Generate.Code.HsCast where

import Language.Haskell.Exts.Build             (app)
import Language.Haskell.Exts.Syntax            (Decl(..),InstDecl(..))
--
import FFICXX.Generate.Name                    (hsClassName,typeclassName)
import FFICXX.Generate.Type.Class              (Class(..),isAbstractClass)
import FFICXX.Generate.Util.HaskellSrcExts     (classA
                                               ,cxEmpty,cxTuple,insDecl
                                               ,mkBind1,mkInstance,mkPVar,mkTVar,mkVar
                                               ,tyapp,tycon,tyPtr
                                               ,unqual)
-----

castBody :: [InstDecl ()]
castBody :: [InstDecl ()]
castBody =
  [ Decl () -> InstDecl ()
insDecl (String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1 String
"cast" [String -> Pat ()
mkPVar String
"x",String -> Pat ()
mkPVar String
"f"] (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"f") (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"castPtr") (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"get_fptr") (String -> Exp ()
mkVar String
"x")))) Maybe (Binds ())
forall a. Maybe a
Nothing)
  , Decl () -> InstDecl ()
insDecl (String -> [Pat ()] -> Exp () -> Maybe (Binds ()) -> Decl ()
mkBind1 String
"uncast" [String -> Pat ()
mkPVar String
"x",String -> Pat ()
mkPVar String
"f"] (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"f") (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"cast_fptr_to_obj") (Exp () -> Exp () -> Exp ()
app (String -> Exp ()
mkVar String
"castPtr") (String -> Exp ()
mkVar String
"x")))) Maybe (Binds ())
forall a. Maybe a
Nothing)
  ]

genHsFrontInstCastable :: Class -> Maybe (Decl ())
genHsFrontInstCastable :: Class -> Maybe (Decl ())
genHsFrontInstCastable Class
c
  | (Bool -> Bool
not(Bool -> Bool) -> (Class -> Bool) -> Class -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Class -> Bool
isAbstractClass) Class
c =
    let iname :: String
iname = Class -> String
typeclassName Class
c
        (String
_,String
rname) = Class -> (String, String)
hsClassName Class
c
        a :: Type ()
a = String -> Type ()
mkTVar String
"a"
        ctxt :: Context ()
ctxt = [Asst ()] -> Context ()
cxTuple [ QName () -> [Type ()] -> Asst ()
classA (String -> QName ()
unqual String
iname) [Type ()
a], QName () -> [Type ()] -> Asst ()
classA (String -> QName ()
unqual String
"FPtr") [Type ()
a] ]
    in Decl () -> Maybe (Decl ())
forall a. a -> Maybe a
Just (Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()
mkInstance Context ()
ctxt String
"Castable" [Type ()
a,Type () -> Type () -> Type ()
tyapp Type ()
tyPtr (String -> Type ()
tycon String
rname)] [InstDecl ()]
castBody)
  | Bool
otherwise = Maybe (Decl ())
forall a. Maybe a
Nothing

genHsFrontInstCastableSelf :: Class -> Maybe (Decl ())
genHsFrontInstCastableSelf :: Class -> Maybe (Decl ())
genHsFrontInstCastableSelf Class
c
  | (Bool -> Bool
not(Bool -> Bool) -> (Class -> Bool) -> Class -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
.Class -> Bool
isAbstractClass) Class
c =
    let (String
cname,String
rname) = Class -> (String, String)
hsClassName Class
c
    in Decl () -> Maybe (Decl ())
forall a. a -> Maybe a
Just (Context () -> String -> [Type ()] -> [InstDecl ()] -> Decl ()
mkInstance Context ()
cxEmpty String
"Castable" [String -> Type ()
tycon String
cname, Type () -> Type () -> Type ()
tyapp Type ()
tyPtr (String -> Type ()
tycon String
rname)] [InstDecl ()]
castBody)
  | Bool
otherwise = Maybe (Decl ())
forall a. Maybe a
Nothing