module FFICXX.Generate.Code.HsCast where

--
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,
    tyPtr,
    tyapp,
    tycon,
    unqual,
  )
import Language.Haskell.Exts.Build (app)
import Language.Haskell.Exts.Syntax (Decl (..), InstDecl (..))

-----

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