{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module FFICXX.Generate.Code.HsFrontEnd where
import Control.Monad.State
import Control.Monad.Reader
import Data.List
import Data.Monoid ( (<>) )
import Language.Haskell.Exts.Build ( app, binds, doE, letE, letStmt
, name, pApp
, qualStmt, strE, tuple
)
import Language.Haskell.Exts.Syntax ( Asst(..), Binds(..), Boxed(..), Bracket(..)
, ClassDecl(..), DataOrNew(..), Decl(..)
, Exp(..), ExportSpec(..)
, ImportDecl(..), InstDecl(..), Literal(..)
, Name(..), Namespace(..), Pat(..)
, QualConDecl(..), Stmt(..)
, Type(..), TyVarBind (..)
)
import System.FilePath ((<.>))
import FFICXX.Generate.Type.Class
import FFICXX.Generate.Type.Annotate
import FFICXX.Generate.Type.Module
import FFICXX.Generate.Util
import FFICXX.Generate.Util.HaskellSrcExts
mkComment :: Int -> String -> String
mkComment indent str
| (not.null) str =
let str_lines = lines str
indentspace = replicate indent ' '
commented_lines =
(indentspace <> "-- | "<>head str_lines) : map (\x->indentspace <> "-- "<>x) (tail str_lines)
in unlines commented_lines
| otherwise = str
mkPostComment :: String -> String
mkPostComment str
| (not.null) str =
let str_lines = lines str
commented_lines =
("-- ^ "<>head str_lines) : map (\x->"-- "<>x) (tail str_lines)
in unlines commented_lines
| otherwise = str
genHsFrontDecl :: Class -> Reader AnnotateMap (Decl ())
genHsFrontDecl c = do
let cdecl = mkClass (classConstraints c) (typeclassName c) [mkTBind "a"] body
sigdecl f = mkFunSig (hsFuncName c f) (functionSignature c f)
body = map (clsDecl . sigdecl) . virtualFuncs . class_funcs $ c
return cdecl
genHsFrontInst :: Class -> Class -> [Decl ()]
genHsFrontInst parent child
| (not.isAbstractClass) child =
let idecl = mkInstance cxEmpty (typeclassName parent) [convertCpp2HS (Just child) SelfType] body
defn f = mkBind1 (hsFuncName child f) [] rhs Nothing
where rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName child f))
body = map (insDecl . defn) . virtualFuncs . class_funcs $ parent
in [idecl]
| otherwise = []
genHsFrontInstNew :: Class
-> Reader AnnotateMap [Decl ()]
genHsFrontInstNew c = do
let fs = filter isNewFunc (class_funcs c)
return . flip concatMap fs $ \f ->
let
rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
in mkFun (constructorName c) (functionSignature c f) [] rhs Nothing
genHsFrontInstNonVirtual :: Class -> [Decl ()]
genHsFrontInstNonVirtual c =
flip concatMap nonvirtualFuncs $ \f ->
let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing
where nonvirtualFuncs = nonVirtualNotNewFuncs (class_funcs c)
genHsFrontInstStatic :: Class -> [Decl ()]
genHsFrontInstStatic c =
flip concatMap (staticFuncs (class_funcs c)) $ \f ->
let rhs = app (mkVar (hsFuncXformer f)) (mkVar (hscFuncName c f))
in mkFun (aliasedFuncName c f) (functionSignature c f) [] rhs Nothing
castBody :: [InstDecl ()]
castBody =
[ insDecl (mkBind1 "cast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "castPtr") (app (mkVar "get_fptr") (mkVar "x")))) Nothing)
, insDecl (mkBind1 "uncast" [mkPVar "x",mkPVar "f"] (app (mkVar "f") (app (mkVar "cast_fptr_to_obj") (app (mkVar "castPtr") (mkVar "x")))) Nothing)
]
genHsFrontInstCastable :: Class -> Maybe (Decl ())
genHsFrontInstCastable c
| (not.isAbstractClass) c =
let iname = typeclassName c
(_,rname) = hsClassName c
a = mkTVar "a"
ctxt = cxTuple [ classA (unqual iname) [a], classA (unqual "FPtr") [a] ]
in Just (mkInstance ctxt "Castable" [a,tyapp tyPtr (tycon rname)] castBody)
| otherwise = Nothing
genHsFrontInstCastableSelf :: Class -> Maybe (Decl ())
genHsFrontInstCastableSelf c
| (not.isAbstractClass) c =
let (cname,rname) = hsClassName c
in Just (mkInstance cxEmpty "Castable" [tycon cname, tyapp tyPtr (tycon rname)] castBody)
| otherwise = Nothing
hsClassRawType :: Class -> [Decl ()]
hsClassRawType c =
[ mkData rawname [] [] Nothing
, mkNewtype highname [] [qualConDecl Nothing Nothing (conDecl highname [tyapp tyPtr rawtype])] mderiv
, mkInstance cxEmpty "FPtr" [hightype]
[ insType (tyapp (tycon "Raw") hightype) rawtype
, insDecl (mkBind1 "get_fptr" [pApp (name highname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)
, insDecl (mkBind1 "cast_fptr_to_obj" [] (con highname) Nothing)
]
]
where (highname,rawname) = hsClassName c
hightype = tycon highname
rawtype = tycon rawname
mderiv = Just (mkDeriving [i_eq,i_ord,i_show])
where i_eq = irule Nothing Nothing (ihcon (unqual "Eq"))
i_ord = irule Nothing Nothing (ihcon (unqual "Ord"))
i_show = irule Nothing Nothing (ihcon (unqual "Show"))
genHsFrontUpcastClass :: Class -> [Decl ()]
genHsFrontUpcastClass c = mkFun ("upcast"<>highname) typ [mkPVar "h"] rhs Nothing
where (highname,rawname) = hsClassName c
hightype = tycon highname
rawtype = tycon rawname
iname = typeclassName c
a_bind = unkindedVar (name "a")
a_tvar = mkTVar "a"
typ = tyForall (Just [a_bind])
(Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))
(tyfun a_tvar hightype)
rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing
, pbind (mkPVarSig "fh2" (tyapp tyPtr rawtype))
(app (mkVar "castPtr") (mkVar "fh")) Nothing
]
(mkVar "cast_fptr_to_obj" `app` mkVar "fh2")
genHsFrontDowncastClass :: Class -> [Decl ()]
genHsFrontDowncastClass c = mkFun ("downcast"<>highname) typ [mkPVar "h"] rhs Nothing
where (highname,_rawname) = hsClassName c
hightype = tycon highname
iname = typeclassName c
a_bind = unkindedVar (name "a")
a_tvar = mkTVar "a"
typ = tyForall (Just [a_bind])
(Just (cxTuple [classA (unqual "FPtr") [a_tvar], classA (unqual iname) [a_tvar]]))
(tyfun hightype a_tvar)
rhs = letE [ pbind (mkPVar "fh") (app (mkVar "get_fptr") (mkVar "h")) Nothing
, pbind (mkPVar "fh2") (app (mkVar "castPtr") (mkVar "fh")) Nothing
]
(mkVar "cast_fptr_to_obj" `app` mkVar "fh2")
genTopLevelFuncDef :: TopLevelFunction -> [Decl ()]
genTopLevelFuncDef f@TopLevelFunction {..} =
let fname = hsFrontNameForTopLevelFunction f
(typs,assts) = extractArgRetTypes Nothing False (toplevelfunc_args,toplevelfunc_ret)
sig = tyForall Nothing (Just (cxTuple assts)) (foldr1 tyfun typs)
xformerstr = let len = length toplevelfunc_args in if len > 0 then "xform" <> show (len-1) else "xformnull"
cfname = "c_" <> toLowers fname
rhs = app (mkVar xformerstr) (mkVar cfname)
in mkFun fname sig [] rhs Nothing
genTopLevelFuncDef v@TopLevelVariable {..} =
let fname = hsFrontNameForTopLevelFunction v
cfname = "c_" <> toLowers fname
rtyp = (tycon . ctypToHsTyp Nothing) toplevelvar_ret
sig = tyapp (tycon "IO") rtyp
rhs = app (mkVar "xformnull") (mkVar cfname)
in mkFun fname sig [] rhs Nothing
genExport :: Class -> [ExportSpec ()]
genExport c =
let espec n = if null . (filter isVirtualFunc) $ (class_funcs c)
then eabs nonamespace (unqual n)
else ethingall (unqual n)
in if isAbstractClass c
then [ espec (typeclassName c) ]
else [ ethingall (unqual ((fst.hsClassName) c))
, espec (typeclassName c)
, evar (unqual ("upcast" <> (fst.hsClassName) c))
, evar (unqual ("downcast" <> (fst.hsClassName) c)) ]
<> genExportConstructorAndNonvirtual c
<> genExportStatic c
genExportConstructorAndNonvirtual :: Class -> [ExportSpec ()]
genExportConstructorAndNonvirtual c = map (evar . unqual) fns
where fs = class_funcs c
fns = map (aliasedFuncName c) (constructorFuncs fs
<> nonVirtualNotNewFuncs fs)
genExportStatic :: Class -> [ExportSpec ()]
genExportStatic c = map (evar . unqual) fns
where fs = class_funcs c
fns = map (aliasedFuncName c) (staticFuncs fs)
genExtraImport :: ClassModule -> [ImportDecl ()]
genExtraImport cm = map mkImport (cmExtraImport cm)
genImportInModule :: [Class] -> [ImportDecl ()]
genImportInModule = concatMap (\x -> map (\y -> mkImport (getClassModuleBase x<.>y)) ["RawType","Interface","Implementation"])
genImportInFFI :: ClassModule -> [ImportDecl ()]
genImportInFFI = map (\x->mkImport (x <.> "RawType")) . cmImportedModulesForFFI
genImportInInterface :: ClassModule -> [ImportDecl ()]
genImportInInterface m =
let modlstraw = cmImportedModulesRaw m
modlstparent = cmImportedModulesHighNonSource m
modlsthigh = cmImportedModulesHighSource m
in [mkImport (cmModule m <.> "RawType")]
<> map (\x -> mkImport (x<.>"RawType")) modlstraw
<> map (\x -> mkImport (x<.>"Interface")) modlstparent
<> map (\x -> mkImportSrc (x<.>"Interface")) modlsthigh
genImportInCast :: ClassModule -> [ImportDecl ()]
genImportInCast m = [ mkImport (cmModule m <.> "RawType")
, mkImport (cmModule m <.> "Interface") ]
genImportInImplementation :: ClassModule -> [ImportDecl ()]
genImportInImplementation m =
let modlstraw' = cmImportedModulesForFFI m
modlsthigh = nub $ map getClassModuleBase $ concatMap class_allparents (cmClass m)
modlstraw = filter (not.(flip elem modlsthigh)) modlstraw'
in [ mkImport (cmModule m <.> "RawType")
, mkImport (cmModule m <.> "FFI")
, mkImport (cmModule m <.> "Interface")
, mkImport (cmModule m <.> "Cast") ]
<> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) modlstraw
<> concatMap (\x -> map (\y -> mkImport (x<.>y)) ["RawType","Cast","Interface"]) modlsthigh
genTmplInterface :: TemplateClass -> [Decl ()]
genTmplInterface t =
[ mkData rname [mkTBind tp] [] Nothing
, mkNewtype hname [mkTBind tp]
[ qualConDecl Nothing Nothing (conDecl hname [tyapp tyPtr rawtype]) ] Nothing
, mkClass cxEmpty (typeclassNameT t) [mkTBind tp] methods
, mkInstance cxEmpty "FPtr" [ hightype ] fptrbody
, mkInstance cxEmpty "Castable" [ hightype, tyapp tyPtr rawtype ] castBody
]
where (hname,rname) = hsTemplateClassName t
tp = tclass_param t
fs = tclass_funcs t
rawtype = tyapp (tycon rname) (mkTVar tp)
hightype = tyapp (tycon hname) (mkTVar tp)
sigdecl f@TFun {..} = mkFunSig tfun_name (functionSignatureT t f)
sigdecl f@TFunNew {..} = mkFunSig ("new"<>tclass_name t) (functionSignatureT t f)
sigdecl f@TFunDelete = mkFunSig ("delete"<>tclass_name t) (functionSignatureT t f)
methods = map (clsDecl . sigdecl) fs
fptrbody = [ insType (tyapp (tycon "Raw") hightype) rawtype
, insDecl (mkBind1 "get_fptr" [pApp (name hname) [mkPVar "ptr"]] (mkVar "ptr") Nothing)
, insDecl (mkBind1 "cast_fptr_to_obj" [] (con hname) Nothing)
]
genTmplImplementation :: TemplateClass -> [Decl ()]
genTmplImplementation t = concatMap gen (tclass_funcs t)
where
gen f = mkFun nh sig [p "nty", p "ncty"] rhs (Just bstmts)
where nh = case f of
TFun {..} -> "t_" <> tfun_name
TFunNew {..} -> "t_" <> "new" <> tclass_name t
TFunDelete -> "t_" <> "delete" <> tclass_name t
nc = case f of
TFun {..} -> tfun_name
TFunNew {..} -> "new"
TFunDelete -> "delete"
sig = tycon "Name" `tyfun` (tycon "String" `tyfun` tycon "ExpQ")
v = mkVar
p = mkPVar
tp = tclass_param t
prefix = tclass_name t
lit = strE (prefix<>"_"<>nc<>"_")
lam = lambda [p "n"] ( lit `app` v "<>" `app` v "n")
rhs = app (v "mkTFunc") (tuple [v "nty", v "ncty", lam, v "tyf"])
sig' = functionSignatureTT t f
bstmts = binds [ mkBind1 "tyf" [mkPVar "n"]
(letE [ pbind (p tp) (v "return" `app` (con "ConT" `app` v "n")) Nothing ]
(bracketExp (typeBracket sig')))
Nothing
]
genTmplInstance :: TemplateClass -> [TemplateFunction] -> [Decl ()]
genTmplInstance t fs = mkFun fname sig [p "n", p "ctyp"] rhs Nothing
where tname = tclass_name t
fname = "gen" <> tname <> "InstanceFor"
p = mkPVar
v = mkVar
sig = tycon "Name" `tyfun` (tycon "String" `tyfun` (tyapp (tycon "Q") (tylist (tycon "Dec"))))
nfs = zip ([1..] :: [Int]) fs
rhs = doE (map genstmt nfs <> [letStmt (lststmt nfs), qualStmt retstmt])
genstmt (n,TFun {..}) = generator (p ("f"<>show n))
(v "mkMember" `app` strE tfun_name
`app` v ("t_" <> tfun_name)
`app` v "n"
`app` v "ctyp"
)
genstmt (n,TFunNew {..}) = generator (p ("f"<>show n))
(v "mkNew" `app` strE ("new" <> tname)
`app` v ("t_new" <> tname)
`app` v "n"
`app` v "ctyp"
)
genstmt (n,TFunDelete) = generator (p ("f"<>show n))
(v "mkDelete" `app` strE ("delete"<>tname)
`app` v ("t_delete" <> tname)
`app` v "n"
`app` v "ctyp"
)
lststmt xs = [ pbind (p "lst") (list (map (v . (\n->"f"<>show n) . fst) xs)) Nothing ]
retstmt = v "return"
`app` list [ v "mkInstance"
`app` list []
`app` (con "AppT"
`app` (v "con" `app` strE (typeclassNameT t))
`app` (con "ConT" `app` (v "n"))
)
`app` (v "lst")
]